{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

\section[RnSource]{Main pass of renamer}
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module RnSource (
        rnSrcDecls, addTcgDUs, findSplice
    ) where

#include "HsVersions.h"

import GhcPrelude

import {-# SOURCE #-} RnExpr( rnLExpr )
import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )

import HsSyn
import FieldLabel
import RdrName
import RnTypes
import RnBinds
import RnEnv
import RnUtils          ( HsDocContext(..), mapFvRn, bindLocalNames
                        , checkDupRdrNames, inHsDocContext, bindLocalNamesFV
                        , checkShadowedRdrNames, warnUnusedTypePatterns
                        , extendTyVarEnvFVRn, newLocalBndrsRn
                        , withHsDocContext )
import RnUnbound        ( mkUnboundName, notInScopeErr )
import RnNames
import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
import TcAnnotations    ( annCtxt )
import TcRnMonad

import ForeignCall      ( CCallTarget(..) )
import Module
import HscTypes         ( Warnings(..), plusWarns )
import PrelNames        ( applicativeClassName, pureAName, thenAName
                        , monadClassName, returnMName, thenMName
                        , semigroupClassName, sappendName
                        , monoidClassName, mappendName
                        )
import Name
import NameSet
import NameEnv
import Avail
import Outputable
import Bag
import BasicTypes       ( pprRuleName )
import FastString
import SrcLoc
import DynFlags
import Util             ( debugIsOn, filterOut, lengthExceeds, partitionWith )
import HscTypes         ( HscEnv, hsc_dflags )
import ListSetOps       ( findDupsEq, removeDups, equivClasses )
import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)
                        , stronglyConnCompFromEdgedVerticesUniq )
import UniqSet
import qualified GHC.LanguageExtensions as LangExt

import Control.Monad
import Control.Arrow ( first )
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe ( isNothing, fromMaybe )
import qualified Data.Set as Set ( difference, fromList, toList, null )

{- | @rnSourceDecl@ "renames" declarations.
It simultaneously performs dependency analysis and precedence parsing.
It also does the following error checks:

* Checks that tyvars are used properly. This includes checking
  for undefined tyvars, and tyvars in contexts that are ambiguous.
  (Some of this checking has now been moved to module @TcMonoType@,
  since we don't have functional dependency information at this point.)

* Checks that all variable occurrences are defined.

* Checks the @(..)@ etc constraints in the export list.

Brings the binders of the group into scope in the appropriate places;
does NOT assume that anything is in scope already
-}
rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)
-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)
rnSrcDecls group :: HsGroup GhcPs
group@(HsGroup { hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds   = HsValBinds GhcPs
val_decls,
                            hs_splcds :: forall p. HsGroup p -> [LSpliceDecl p]
hs_splcds  = [LSpliceDecl GhcPs]
splice_decls,
                            hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds  = [TyClGroup GhcPs]
tycl_decls,
                            hs_derivds :: forall p. HsGroup p -> [LDerivDecl p]
hs_derivds = [LDerivDecl GhcPs]
deriv_decls,
                            hs_fixds :: forall p. HsGroup p -> [LFixitySig p]
hs_fixds   = [LFixitySig GhcPs]
fix_decls,
                            hs_warnds :: forall p. HsGroup p -> [LWarnDecls p]
hs_warnds  = [LWarnDecls GhcPs]
warn_decls,
                            hs_annds :: forall p. HsGroup p -> [LAnnDecl p]
hs_annds   = [LAnnDecl GhcPs]
ann_decls,
                            hs_fords :: forall p. HsGroup p -> [LForeignDecl p]
hs_fords   = [LForeignDecl GhcPs]
foreign_decls,
                            hs_defds :: forall p. HsGroup p -> [LDefaultDecl p]
hs_defds   = [LDefaultDecl GhcPs]
default_decls,
                            hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds  = [LRuleDecls GhcPs]
rule_decls,
                            hs_docs :: forall p. HsGroup p -> [LDocDecl]
hs_docs    = [LDocDecl]
docs })
 = do {
   -- (A) Process the fixity declarations, creating a mapping from
   --     FastStrings to FixItems.
   --     Also checks for duplicates.
   MiniFixityEnv
local_fix_env <- [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv [LFixitySig GhcPs]
fix_decls ;

   -- (B) Bring top level binders (and their fixities) into scope,
   --     *except* for the value bindings, which get done in step (D)
   --     with collectHsIdBinders. However *do* include
   --
   --        * Class ops, data constructors, and record fields,
   --          because they do not have value declarations.
   --
   --        * For hs-boot files, include the value signatures
   --          Again, they have no value declarations
   --
   (tc_envs :: (TcGblEnv, TcLclEnv)
tc_envs, tc_bndrs :: NameSet
tc_bndrs) <- MiniFixityEnv
-> HsGroup GhcPs -> RnM ((TcGblEnv, TcLclEnv), NameSet)
getLocalNonValBinders MiniFixityEnv
local_fix_env HsGroup GhcPs
group ;


   (TcGblEnv, TcLclEnv)
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
tc_envs (RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$ do {

   TcRn ()
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations

   -- (D1) Bring pattern synonyms into scope.
   --      Need to do this before (D2) because rnTopBindsLHS
   --      looks up those pattern synonyms (Trac #9889)

   HsValBinds GhcPs
-> MiniFixityEnv
-> ([Name] -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn)
forall a.
HsValBinds GhcPs
-> MiniFixityEnv
-> ([Name] -> TcRnIf TcGblEnv TcLclEnv a)
-> TcRnIf TcGblEnv TcLclEnv a
extendPatSynEnv HsValBinds GhcPs
val_decls MiniFixityEnv
local_fix_env (([Name] -> RnM (TcGblEnv, HsGroup GhcRn))
 -> RnM (TcGblEnv, HsGroup GhcRn))
-> ([Name] -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$ \pat_syn_bndrs :: [Name]
pat_syn_bndrs -> do {

   -- (D2) Rename the left-hand sides of the value bindings.
   --     This depends on everything from (B) being in scope.
   --     It uses the fixity env from (A) to bind fixities for view patterns.
   HsValBindsLR GhcRn GhcPs
new_lhs <- MiniFixityEnv -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnTopBindsLHS MiniFixityEnv
local_fix_env HsValBinds GhcPs
val_decls ;

   -- Bind the LHSes (and their fixities) in the global rdr environment
   let { id_bndrs :: [IdP GhcRn]
id_bndrs = HsValBindsLR GhcRn GhcPs -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass).
HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectHsIdBinders HsValBindsLR GhcRn GhcPs
new_lhs } ;  -- Excludes pattern-synonym binders
                                                    -- They are already in scope
   String -> SDoc -> TcRn ()
traceRn "rnSrcDecls" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
[IdP GhcRn]
id_bndrs) ;
   (TcGblEnv, TcLclEnv)
tc_envs <- [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn ((Name -> AvailInfo) -> [Name] -> [AvailInfo]
forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail [Name]
[IdP GhcRn]
id_bndrs) MiniFixityEnv
local_fix_env ;
   (TcGblEnv, TcLclEnv)
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
tc_envs (RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$ do {

   --  Now everything is in scope, as the remaining renaming assumes.

   -- (E) Rename type and class decls
   --     (note that value LHSes need to be in scope for default methods)
   --
   -- You might think that we could build proper def/use information
   -- for type and class declarations, but they can be involved
   -- in mutual recursion across modules, and we only do the SCC
   -- analysis for them in the type checker.
   -- So we content ourselves with gathering uses only; that
   -- means we'll only report a declaration as unused if it isn't
   -- mentioned at all.  Ah well.
   String -> SDoc -> TcRn ()
traceRn "Start rnTyClDecls" ([TyClGroup GhcPs] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyClGroup GhcPs]
tycl_decls) ;
   (rn_tycl_decls :: [TyClGroup GhcRn]
rn_tycl_decls, src_fvs1 :: NameSet
src_fvs1) <- [TyClGroup GhcPs] -> RnM ([TyClGroup GhcRn], NameSet)
rnTyClDecls [TyClGroup GhcPs]
tycl_decls ;

   -- (F) Rename Value declarations right-hand sides
   String -> SDoc -> TcRn ()
traceRn "Start rnmono" SDoc
empty ;
   let { val_bndr_set :: NameSet
val_bndr_set = [Name] -> NameSet
mkNameSet [Name]
[IdP GhcRn]
id_bndrs NameSet -> NameSet -> NameSet
`unionNameSet` [Name] -> NameSet
mkNameSet [Name]
pat_syn_bndrs } ;
   Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig ;
   (rn_val_decls :: HsValBinds GhcRn
rn_val_decls, bind_dus :: DefUses
bind_dus) <- if Bool
is_boot
    -- For an hs-boot, use tc_bndrs (which collects how we're renamed
    -- signatures), since val_bndr_set is empty (there are no x = ...
    -- bindings in an hs-boot.)
    then NameSet
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnTopBindsBoot NameSet
tc_bndrs HsValBindsLR GhcRn GhcPs
new_lhs
    else HsSigCtxt
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnValBindsRHS (NameSet -> HsSigCtxt
TopSigCtxt NameSet
val_bndr_set) HsValBindsLR GhcRn GhcPs
new_lhs ;
   String -> SDoc -> TcRn ()
traceRn "finish rnmono" (HsValBinds GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBinds GhcRn
rn_val_decls) ;

   -- (G) Rename Fixity and deprecations

   -- Rename fixity declarations and error if we try to
   -- fix something from another module (duplicates were checked in (A))
   let { all_bndrs :: NameSet
all_bndrs = NameSet
tc_bndrs NameSet -> NameSet -> NameSet
`unionNameSet` NameSet
val_bndr_set } ;
   [GenLocated SrcSpan (FixitySig GhcRn)]
rn_fix_decls <- (LFixitySig GhcPs
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (GenLocated SrcSpan (FixitySig GhcRn)))
-> [LFixitySig GhcPs]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [GenLocated SrcSpan (FixitySig GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((FixitySig GhcPs
 -> IOEnv (Env TcGblEnv TcLclEnv) (FixitySig GhcRn))
-> LFixitySig GhcPs
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpan (FixitySig GhcRn))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsSigCtxt
-> FixitySig GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (FixitySig GhcRn)
rnSrcFixityDecl (NameSet -> HsSigCtxt
TopSigCtxt NameSet
all_bndrs)))
                        [LFixitySig GhcPs]
fix_decls ;

   -- Rename deprec decls;
   -- check for duplicates and ensure that deprecated things are defined locally
   -- at the moment, we don't keep these around past renaming
   Warnings
rn_warns <- NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
rnSrcWarnDecls NameSet
all_bndrs [LWarnDecls GhcPs]
warn_decls ;

   -- (H) Rename Everything else

   (rn_rule_decls :: [Located (RuleDecls GhcRn)]
rn_rule_decls,    src_fvs2 :: NameSet
src_fvs2) <- Extension
-> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
-> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.ScopedTypeVariables (TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
 -> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet))
-> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
-> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
forall a b. (a -> b) -> a -> b
$
                                   (RuleDecls GhcPs -> RnM (RuleDecls GhcRn, NameSet))
-> [LRuleDecls GhcPs]
-> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList RuleDecls GhcPs -> RnM (RuleDecls GhcRn, NameSet)
rnHsRuleDecls [LRuleDecls GhcPs]
rule_decls ;
                           -- Inside RULES, scoped type variables are on
   (rn_foreign_decls :: [Located (ForeignDecl GhcRn)]
rn_foreign_decls, src_fvs3 :: NameSet
src_fvs3) <- (ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, NameSet))
-> [LForeignDecl GhcPs]
-> RnM ([Located (ForeignDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, NameSet)
rnHsForeignDecl [LForeignDecl GhcPs]
foreign_decls ;
   (rn_ann_decls :: [Located (AnnDecl GhcRn)]
rn_ann_decls,     src_fvs4 :: NameSet
src_fvs4) <- (AnnDecl GhcPs -> RnM (AnnDecl GhcRn, NameSet))
-> [LAnnDecl GhcPs] -> RnM ([Located (AnnDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList AnnDecl GhcPs -> RnM (AnnDecl GhcRn, NameSet)
rnAnnDecl       [LAnnDecl GhcPs]
ann_decls ;
   (rn_default_decls :: [Located (DefaultDecl GhcRn)]
rn_default_decls, src_fvs5 :: NameSet
src_fvs5) <- (DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, NameSet))
-> [LDefaultDecl GhcPs]
-> RnM ([Located (DefaultDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, NameSet)
rnDefaultDecl   [LDefaultDecl GhcPs]
default_decls ;
   (rn_deriv_decls :: [Located (DerivDecl GhcRn)]
rn_deriv_decls,   src_fvs6 :: NameSet
src_fvs6) <- (DerivDecl GhcPs -> RnM (DerivDecl GhcRn, NameSet))
-> [LDerivDecl GhcPs] -> RnM ([Located (DerivDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList DerivDecl GhcPs -> RnM (DerivDecl GhcRn, NameSet)
rnSrcDerivDecl  [LDerivDecl GhcPs]
deriv_decls ;
   (rn_splice_decls :: [Located (SpliceDecl GhcRn)]
rn_splice_decls,  src_fvs7 :: NameSet
src_fvs7) <- (SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, NameSet))
-> [LSpliceDecl GhcPs]
-> RnM ([Located (SpliceDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, NameSet)
rnSpliceDecl    [LSpliceDecl GhcPs]
splice_decls ;
      -- Haddock docs; no free vars
   [LDocDecl]
rn_docs <- (LDocDecl -> IOEnv (Env TcGblEnv TcLclEnv) LDocDecl)
-> [LDocDecl] -> IOEnv (Env TcGblEnv TcLclEnv) [LDocDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess LDocDecl -> TcM (SrcSpanLess LDocDecl))
-> LDocDecl -> IOEnv (Env TcGblEnv TcLclEnv) LDocDecl
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
wrapLocM SrcSpanLess LDocDecl -> TcM (SrcSpanLess LDocDecl)
DocDecl -> RnM DocDecl
rnDocDecl) [LDocDecl]
docs ;

   TcGblEnv
last_tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv ;
   -- (I) Compute the results and return
   let {rn_group :: HsGroup GhcRn
rn_group = HsGroup :: forall p.
XCHsGroup p
-> HsValBinds p
-> [LSpliceDecl p]
-> [TyClGroup p]
-> [LDerivDecl p]
-> [LFixitySig p]
-> [LDefaultDecl p]
-> [LForeignDecl p]
-> [LWarnDecls p]
-> [LAnnDecl p]
-> [LRuleDecls p]
-> [LDocDecl]
-> HsGroup p
HsGroup { hs_ext :: XCHsGroup GhcRn
hs_ext     = XCHsGroup GhcRn
NoExt
noExt,
                             hs_valds :: HsValBinds GhcRn
hs_valds   = HsValBinds GhcRn
rn_val_decls,
                             hs_splcds :: [Located (SpliceDecl GhcRn)]
hs_splcds  = [Located (SpliceDecl GhcRn)]
rn_splice_decls,
                             hs_tyclds :: [TyClGroup GhcRn]
hs_tyclds  = [TyClGroup GhcRn]
rn_tycl_decls,
                             hs_derivds :: [Located (DerivDecl GhcRn)]
hs_derivds = [Located (DerivDecl GhcRn)]
rn_deriv_decls,
                             hs_fixds :: [GenLocated SrcSpan (FixitySig GhcRn)]
hs_fixds   = [GenLocated SrcSpan (FixitySig GhcRn)]
rn_fix_decls,
                             hs_warnds :: [LWarnDecls GhcRn]
hs_warnds  = [], -- warns are returned in the tcg_env
                                             -- (see below) not in the HsGroup
                             hs_fords :: [Located (ForeignDecl GhcRn)]
hs_fords  = [Located (ForeignDecl GhcRn)]
rn_foreign_decls,
                             hs_annds :: [Located (AnnDecl GhcRn)]
hs_annds  = [Located (AnnDecl GhcRn)]
rn_ann_decls,
                             hs_defds :: [Located (DefaultDecl GhcRn)]
hs_defds  = [Located (DefaultDecl GhcRn)]
rn_default_decls,
                             hs_ruleds :: [Located (RuleDecls GhcRn)]
hs_ruleds = [Located (RuleDecls GhcRn)]
rn_rule_decls,
                             hs_docs :: [LDocDecl]
hs_docs   = [LDocDecl]
rn_docs } ;

        tcf_bndrs :: [Name]
tcf_bndrs = [TyClGroup GhcRn] -> [Located (ForeignDecl GhcRn)] -> [Name]
hsTyClForeignBinders [TyClGroup GhcRn]
rn_tycl_decls [Located (ForeignDecl GhcRn)]
rn_foreign_decls ;
        other_def :: (Maybe NameSet, NameSet)
other_def  = (NameSet -> Maybe NameSet
forall a. a -> Maybe a
Just ([Name] -> NameSet
mkNameSet [Name]
tcf_bndrs), NameSet
emptyNameSet) ;
        other_fvs :: NameSet
other_fvs  = [NameSet] -> NameSet
plusFVs [NameSet
src_fvs1, NameSet
src_fvs2, NameSet
src_fvs3, NameSet
src_fvs4,
                              NameSet
src_fvs5, NameSet
src_fvs6, NameSet
src_fvs7] ;
                -- It is tiresome to gather the binders from type and class decls

        src_dus :: DefUses
src_dus = [(Maybe NameSet, NameSet)
other_def] DefUses -> DefUses -> DefUses
`plusDU` DefUses
bind_dus DefUses -> DefUses -> DefUses
`plusDU` NameSet -> DefUses
usesOnly NameSet
other_fvs ;
                -- Instance decls may have occurrences of things bound in bind_dus
                -- so we must put other_fvs last

        final_tcg_env :: TcGblEnv
final_tcg_env = let tcg_env' :: TcGblEnv
tcg_env' = (TcGblEnv
last_tcg_env TcGblEnv -> DefUses -> TcGblEnv
`addTcgDUs` DefUses
src_dus)
                        in -- we return the deprecs in the env, not in the HsGroup above
                        TcGblEnv
tcg_env' { tcg_warns :: Warnings
tcg_warns = TcGblEnv -> Warnings
tcg_warns TcGblEnv
tcg_env' Warnings -> Warnings -> Warnings
`plusWarns` Warnings
rn_warns };
       } ;
   String -> SDoc -> TcRn ()
traceRn "finish rnSrc" (HsGroup GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsGroup GhcRn
rn_group) ;
   String -> SDoc -> TcRn ()
traceRn "finish Dus" (DefUses -> SDoc
forall a. Outputable a => a -> SDoc
ppr DefUses
src_dus ) ;
   (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
final_tcg_env, HsGroup GhcRn
rn_group)
                    }}}}
rnSrcDecls (XHsGroup _) = String -> RnM (TcGblEnv, HsGroup GhcRn)
forall a. String -> a
panic "rnSrcDecls"

addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
-- This function could be defined lower down in the module hierarchy,
-- but there doesn't seem anywhere very logical to put it.
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
addTcgDUs tcg_env :: TcGblEnv
tcg_env dus :: DefUses
dus = TcGblEnv
tcg_env { tcg_dus :: DefUses
tcg_dus = TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env DefUses -> DefUses -> DefUses
`plusDU` DefUses
dus }

rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
rnList :: (a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList f :: a -> RnM (b, NameSet)
f xs :: [Located a]
xs = (Located a -> RnM (Located b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn ((SrcSpanLess (Located a) -> TcM (SrcSpanLess (Located b), NameSet))
-> Located a -> RnM (Located b, NameSet)
forall a b c.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b, c)) -> a -> TcM (b, c)
wrapLocFstM a -> RnM (b, NameSet)
SrcSpanLess (Located a) -> TcM (SrcSpanLess (Located b), NameSet)
f) [Located a]
xs

{-
*********************************************************
*                                                       *
        HsDoc stuff
*                                                       *
*********************************************************
-}

rnDocDecl :: DocDecl -> RnM DocDecl
rnDocDecl :: DocDecl -> RnM DocDecl
rnDocDecl (DocCommentNext doc :: HsDocString
doc) = do
  HsDocString
rn_doc <- HsDocString -> RnM HsDocString
rnHsDoc HsDocString
doc
  DocDecl -> RnM DocDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDocString -> DocDecl
DocCommentNext HsDocString
rn_doc)
rnDocDecl (DocCommentPrev doc :: HsDocString
doc) = do
  HsDocString
rn_doc <- HsDocString -> RnM HsDocString
rnHsDoc HsDocString
doc
  DocDecl -> RnM DocDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDocString -> DocDecl
DocCommentPrev HsDocString
rn_doc)
rnDocDecl (DocCommentNamed str :: String
str doc :: HsDocString
doc) = do
  HsDocString
rn_doc <- HsDocString -> RnM HsDocString
rnHsDoc HsDocString
doc
  DocDecl -> RnM DocDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> HsDocString -> DocDecl
DocCommentNamed String
str HsDocString
rn_doc)
rnDocDecl (DocGroup lev :: Int
lev doc :: HsDocString
doc) = do
  HsDocString
rn_doc <- HsDocString -> RnM HsDocString
rnHsDoc HsDocString
doc
  DocDecl -> RnM DocDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> HsDocString -> DocDecl
DocGroup Int
lev HsDocString
rn_doc)

{-
*********************************************************
*                                                       *
        Source-code deprecations declarations
*                                                       *
*********************************************************

Check that the deprecated names are defined, are defined locally, and
that there are no duplicate deprecations.

It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.
-}

-- checks that the deprecations are defined locally, and that there are no duplicates
rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
rnSrcWarnDecls _ []
  = Warnings -> RnM Warnings
forall (m :: * -> *) a. Monad m => a -> m a
return Warnings
NoWarnings

rnSrcWarnDecls bndr_set :: NameSet
bndr_set decls' :: [LWarnDecls GhcPs]
decls'
  = do { -- check for duplicates
       ; (NonEmpty (GenLocated SrcSpan RdrName) -> TcRn ())
-> [NonEmpty (GenLocated SrcSpan RdrName)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ dups :: NonEmpty (GenLocated SrcSpan RdrName)
dups -> let ((GenLocated SrcSpan RdrName
-> Located (SrcSpanLess (GenLocated SrcSpan RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc rdr :: SrcSpanLess (GenLocated SrcSpan RdrName)
rdr) :| (lrdr' :: GenLocated SrcSpan RdrName
lrdr':_)) = NonEmpty (GenLocated SrcSpan RdrName)
dups
                          in SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
loc (GenLocated SrcSpan RdrName -> RdrName -> SDoc
dupWarnDecl GenLocated SrcSpan RdrName
lrdr' SrcSpanLess (GenLocated SrcSpan RdrName)
RdrName
rdr))
               [NonEmpty (GenLocated SrcSpan RdrName)]
warn_rdr_dups
       ; [[(OccName, WarningTxt)]]
pairs_s <- (LWarnDecl GhcPs
 -> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)])
-> [LWarnDecl GhcPs]
-> IOEnv (Env TcGblEnv TcLclEnv) [[(OccName, WarningTxt)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LWarnDecl GhcPs)
 -> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)])
-> LWarnDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM SrcSpanLess (LWarnDecl GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
WarnDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
rn_deprec) [LWarnDecl GhcPs]
decls
       ; Warnings -> RnM Warnings
forall (m :: * -> *) a. Monad m => a -> m a
return ([(OccName, WarningTxt)] -> Warnings
WarnSome (([[(OccName, WarningTxt)]] -> [(OccName, WarningTxt)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(OccName, WarningTxt)]]
pairs_s))) }
 where
   decls :: [LWarnDecl GhcPs]
decls = (LWarnDecls GhcPs -> [LWarnDecl GhcPs])
-> [LWarnDecls GhcPs] -> [LWarnDecl GhcPs]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (WarnDecls GhcPs -> [LWarnDecl GhcPs]
forall pass. WarnDecls pass -> [LWarnDecl pass]
wd_warnings (WarnDecls GhcPs -> [LWarnDecl GhcPs])
-> (LWarnDecls GhcPs -> WarnDecls GhcPs)
-> LWarnDecls GhcPs
-> [LWarnDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LWarnDecls GhcPs -> WarnDecls GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LWarnDecls GhcPs]
decls'

   sig_ctxt :: HsSigCtxt
sig_ctxt = NameSet -> HsSigCtxt
TopSigCtxt NameSet
bndr_set

   rn_deprec :: WarnDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
rn_deprec (Warning _ rdr_names :: [Located (IdP GhcPs)]
rdr_names txt :: WarningTxt
txt)
       -- ensures that the names are defined locally
     = do { [(RdrName, Name)]
names <- (GenLocated SrcSpan RdrName
 -> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)])
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (HsSigCtxt
-> SDoc
-> RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)]
lookupLocalTcNames HsSigCtxt
sig_ctxt SDoc
what (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)])
-> (GenLocated SrcSpan RdrName -> RdrName)
-> GenLocated SrcSpan RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc)
                                [GenLocated SrcSpan RdrName]
[Located (IdP GhcPs)]
rdr_names
          ; [(OccName, WarningTxt)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(RdrName -> OccName
rdrNameOcc RdrName
rdr, WarningTxt
txt) | (rdr :: RdrName
rdr, _) <- [(RdrName, Name)]
names] }
   rn_deprec (XWarnDecl _) = String -> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
forall a. String -> a
panic "rnSrcWarnDecls"

   what :: SDoc
what = String -> SDoc
text "deprecation"

   warn_rdr_dups :: [NonEmpty (GenLocated SrcSpan RdrName)]
warn_rdr_dups = [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
findDupRdrNames
                   ([GenLocated SrcSpan RdrName]
 -> [NonEmpty (GenLocated SrcSpan RdrName)])
-> [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
forall a b. (a -> b) -> a -> b
$ (LWarnDecl GhcPs -> [GenLocated SrcSpan RdrName])
-> [LWarnDecl GhcPs] -> [GenLocated SrcSpan RdrName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(LWarnDecl GhcPs -> Located (SrcSpanLess (LWarnDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (Warning _ ns _)) -> [GenLocated SrcSpan RdrName]
[Located (IdP GhcPs)]
ns) [LWarnDecl GhcPs]
decls

findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
findDupRdrNames :: [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
findDupRdrNames = (GenLocated SrcSpan RdrName -> GenLocated SrcSpan RdrName -> Bool)
-> [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (\ x :: GenLocated SrcSpan RdrName
x -> \ y :: GenLocated SrcSpan RdrName
y -> RdrName -> OccName
rdrNameOcc (GenLocated SrcSpan RdrName
-> SrcSpanLess (GenLocated SrcSpan RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc GenLocated SrcSpan RdrName
x) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc (GenLocated SrcSpan RdrName
-> SrcSpanLess (GenLocated SrcSpan RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc GenLocated SrcSpan RdrName
y))

-- look for duplicates among the OccNames;
-- we check that the names are defined above
-- invt: the lists returned by findDupsEq always have at least two elements

dupWarnDecl :: Located RdrName -> RdrName -> SDoc
-- Located RdrName -> DeprecDecl RdrName -> SDoc
dupWarnDecl :: GenLocated SrcSpan RdrName -> RdrName -> SDoc
dupWarnDecl d :: GenLocated SrcSpan RdrName
d rdr_name :: RdrName
rdr_name
  = [SDoc] -> SDoc
vcat [String -> SDoc
text "Multiple warning declarations for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name),
          String -> SDoc
text "also at " SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenLocated SrcSpan RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc GenLocated SrcSpan RdrName
d)]

{-
*********************************************************
*                                                      *
\subsection{Annotation declarations}
*                                                      *
*********************************************************
-}

rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, NameSet)
rnAnnDecl ann :: AnnDecl GhcPs
ann@(HsAnnotation _ s :: SourceText
s provenance :: AnnProvenance (IdP GhcPs)
provenance expr :: Located (HsExpr GhcPs)
expr)
  = SDoc
-> RnM (AnnDecl GhcRn, NameSet) -> RnM (AnnDecl GhcRn, NameSet)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (AnnDecl GhcPs -> SDoc
forall (p :: Pass).
OutputableBndrId (GhcPass p) =>
AnnDecl (GhcPass p) -> SDoc
annCtxt AnnDecl GhcPs
ann) (RnM (AnnDecl GhcRn, NameSet) -> RnM (AnnDecl GhcRn, NameSet))
-> RnM (AnnDecl GhcRn, NameSet) -> RnM (AnnDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$
    do { (provenance' :: AnnProvenance Name
provenance', provenance_fvs :: NameSet
provenance_fvs) <- AnnProvenance RdrName -> RnM (AnnProvenance Name, NameSet)
rnAnnProvenance AnnProvenance RdrName
AnnProvenance (IdP GhcPs)
provenance
       ; (expr' :: LHsExpr GhcRn
expr', expr_fvs :: NameSet
expr_fvs) <- ThStage
-> TcM (LHsExpr GhcRn, NameSet) -> TcM (LHsExpr GhcRn, NameSet)
forall a. ThStage -> TcM a -> TcM a
setStage (SpliceType -> ThStage
Splice SpliceType
Untyped) (TcM (LHsExpr GhcRn, NameSet) -> TcM (LHsExpr GhcRn, NameSet))
-> TcM (LHsExpr GhcRn, NameSet) -> TcM (LHsExpr GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$
                              Located (HsExpr GhcPs) -> TcM (LHsExpr GhcRn, NameSet)
rnLExpr Located (HsExpr GhcPs)
expr
       ; (AnnDecl GhcRn, NameSet) -> RnM (AnnDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsAnnotation GhcRn
-> SourceText
-> AnnProvenance (IdP GhcRn)
-> LHsExpr GhcRn
-> AnnDecl GhcRn
forall pass.
XHsAnnotation pass
-> SourceText
-> AnnProvenance (IdP pass)
-> Located (HsExpr pass)
-> AnnDecl pass
HsAnnotation XHsAnnotation GhcRn
NoExt
noExt SourceText
s AnnProvenance Name
AnnProvenance (IdP GhcRn)
provenance' LHsExpr GhcRn
expr',
                 NameSet
provenance_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
expr_fvs) }
rnAnnDecl (XAnnDecl _) = String -> RnM (AnnDecl GhcRn, NameSet)
forall a. String -> a
panic "rnAnnDecl"

rnAnnProvenance :: AnnProvenance RdrName
                -> RnM (AnnProvenance Name, FreeVars)
rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, NameSet)
rnAnnProvenance provenance :: AnnProvenance RdrName
provenance = do
    AnnProvenance Name
provenance' <- (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> AnnProvenance RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (AnnProvenance Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupTopBndrRn AnnProvenance RdrName
provenance
    (AnnProvenance Name, NameSet) -> RnM (AnnProvenance Name, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnProvenance Name
provenance', NameSet -> (Name -> NameSet) -> Maybe Name -> NameSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NameSet
emptyFVs Name -> NameSet
unitFV (AnnProvenance Name -> Maybe Name
forall name. AnnProvenance name -> Maybe name
annProvenanceName_maybe AnnProvenance Name
provenance'))

{-
*********************************************************
*                                                      *
\subsection{Default declarations}
*                                                      *
*********************************************************
-}

rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, NameSet)
rnDefaultDecl (DefaultDecl _ tys :: [LHsType GhcPs]
tys)
  = do { (tys' :: [LHsType GhcRn]
tys', fvs :: NameSet
fvs) <- HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], NameSet)
rnLHsTypes HsDocContext
doc_str [LHsType GhcPs]
tys
       ; (DefaultDecl GhcRn, NameSet) -> RnM (DefaultDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCDefaultDecl GhcRn -> [LHsType GhcRn] -> DefaultDecl GhcRn
forall pass.
XCDefaultDecl pass -> [LHsType pass] -> DefaultDecl pass
DefaultDecl XCDefaultDecl GhcRn
NoExt
noExt [LHsType GhcRn]
tys', NameSet
fvs) }
  where
    doc_str :: HsDocContext
doc_str = HsDocContext
DefaultDeclCtx
rnDefaultDecl (XDefaultDecl _) = String -> RnM (DefaultDecl GhcRn, NameSet)
forall a. String -> a
panic "rnDefaultDecl"

{-
*********************************************************
*                                                      *
\subsection{Foreign declarations}
*                                                      *
*********************************************************
-}

rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, NameSet)
rnHsForeignDecl (ForeignImport { fd_name :: forall pass. ForeignDecl pass -> Located (IdP pass)
fd_name = Located (IdP GhcPs)
name, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcPs
ty, fd_fi :: forall pass. ForeignDecl pass -> ForeignImport
fd_fi = ForeignImport
spec })
  = do { HscEnv
topEnv :: HscEnv <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; Located Name
name' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
Located (IdP GhcPs)
name
       ; (ty' :: LHsSigType GhcRn
ty', fvs :: NameSet
fvs) <- HsDocContext -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType (GenLocated SrcSpan RdrName -> HsDocContext
ForeignDeclCtx GenLocated SrcSpan RdrName
Located (IdP GhcPs)
name) LHsSigType GhcPs
ty

        -- Mark any PackageTarget style imports as coming from the current package
       ; let unitId :: UnitId
unitId = DynFlags -> UnitId
thisPackage (DynFlags -> UnitId) -> DynFlags -> UnitId
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags HscEnv
topEnv
             spec' :: ForeignImport
spec'      = UnitId -> ForeignImport -> ForeignImport
patchForeignImport UnitId
unitId ForeignImport
spec

       ; (ForeignDecl GhcRn, NameSet) -> RnM (ForeignDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport :: forall pass.
XForeignImport pass
-> Located (IdP pass)
-> LHsSigType pass
-> ForeignImport
-> ForeignDecl pass
ForeignImport { fd_i_ext :: XForeignImport GhcRn
fd_i_ext = XForeignImport GhcRn
NoExt
noExt
                               , fd_name :: Located (IdP GhcRn)
fd_name = Located Name
Located (IdP GhcRn)
name', fd_sig_ty :: LHsSigType GhcRn
fd_sig_ty = LHsSigType GhcRn
ty'
                               , fd_fi :: ForeignImport
fd_fi = ForeignImport
spec' }, NameSet
fvs) }

rnHsForeignDecl (ForeignExport { fd_name :: forall pass. ForeignDecl pass -> Located (IdP pass)
fd_name = Located (IdP GhcPs)
name, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcPs
ty, fd_fe :: forall pass. ForeignDecl pass -> ForeignExport
fd_fe = ForeignExport
spec })
  = do { Located Name
name' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedOccRn GenLocated SrcSpan RdrName
Located (IdP GhcPs)
name
       ; (ty' :: LHsSigType GhcRn
ty', fvs :: NameSet
fvs) <- HsDocContext -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType (GenLocated SrcSpan RdrName -> HsDocContext
ForeignDeclCtx GenLocated SrcSpan RdrName
Located (IdP GhcPs)
name) LHsSigType GhcPs
ty
       ; (ForeignDecl GhcRn, NameSet) -> RnM (ForeignDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignExport :: forall pass.
XForeignExport pass
-> Located (IdP pass)
-> LHsSigType pass
-> ForeignExport
-> ForeignDecl pass
ForeignExport { fd_e_ext :: XForeignExport GhcRn
fd_e_ext = XForeignExport GhcRn
NoExt
noExt
                               , fd_name :: Located (IdP GhcRn)
fd_name = Located Name
Located (IdP GhcRn)
name', fd_sig_ty :: LHsSigType GhcRn
fd_sig_ty = LHsSigType GhcRn
ty'
                               , fd_fe :: ForeignExport
fd_fe = ForeignExport
spec }
                , NameSet
fvs NameSet -> Name -> NameSet
`addOneFV` Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
name') }
        -- NB: a foreign export is an *occurrence site* for name, so
        --     we add it to the free-variable list.  It might, for example,
        --     be imported from another module

rnHsForeignDecl (XForeignDecl _) = String -> RnM (ForeignDecl GhcRn, NameSet)
forall a. String -> a
panic "rnHsForeignDecl"

-- | For Windows DLLs we need to know what packages imported symbols are from
--      to generate correct calls. Imported symbols are tagged with the current
--      package, so if they get inlined across a package boundary we'll still
--      know where they're from.
--
patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
patchForeignImport unitId :: UnitId
unitId (CImport cconv :: Located CCallConv
cconv safety :: Located Safety
safety fs :: Maybe Header
fs spec :: CImportSpec
spec src :: Located SourceText
src)
        = Located CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport Located CCallConv
cconv Located Safety
safety Maybe Header
fs (UnitId -> CImportSpec -> CImportSpec
patchCImportSpec UnitId
unitId CImportSpec
spec) Located SourceText
src

patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
patchCImportSpec unitId :: UnitId
unitId spec :: CImportSpec
spec
 = case CImportSpec
spec of
        CFunction callTarget :: CCallTarget
callTarget    -> CCallTarget -> CImportSpec
CFunction (CCallTarget -> CImportSpec) -> CCallTarget -> CImportSpec
forall a b. (a -> b) -> a -> b
$ UnitId -> CCallTarget -> CCallTarget
patchCCallTarget UnitId
unitId CCallTarget
callTarget
        _                       -> CImportSpec
spec

patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
patchCCallTarget unitId :: UnitId
unitId callTarget :: CCallTarget
callTarget =
  case CCallTarget
callTarget of
  StaticTarget src :: SourceText
src label :: CLabelString
label Nothing isFun :: Bool
isFun
                              -> SourceText -> CLabelString -> Maybe UnitId -> Bool -> CCallTarget
StaticTarget SourceText
src CLabelString
label (UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just UnitId
unitId) Bool
isFun
  _                           -> CCallTarget
callTarget

{-
*********************************************************
*                                                      *
\subsection{Instance declarations}
*                                                      *
*********************************************************
-}

rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, NameSet)
rnSrcInstDecl (TyFamInstD { tfid_inst :: forall pass. InstDecl pass -> TyFamInstDecl pass
tfid_inst = TyFamInstDecl GhcPs
tfi })
  = do { (tfi' :: TyFamInstDecl GhcRn
tfi', fvs :: NameSet
fvs) <- Maybe (Name, [Name])
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet)
rnTyFamInstDecl Maybe (Name, [Name])
forall a. Maybe a
Nothing TyFamInstDecl GhcPs
tfi
       ; (InstDecl GhcRn, NameSet) -> RnM (InstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyFamInstD :: forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD { tfid_ext :: XTyFamInstD GhcRn
tfid_ext = XTyFamInstD GhcRn
NoExt
noExt, tfid_inst :: TyFamInstDecl GhcRn
tfid_inst = TyFamInstDecl GhcRn
tfi' }, NameSet
fvs) }

rnSrcInstDecl (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl GhcPs
dfi })
  = do { (dfi' :: DataFamInstDecl GhcRn
dfi', fvs :: NameSet
fvs) <- Maybe (Name, [Name])
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, NameSet)
rnDataFamInstDecl Maybe (Name, [Name])
forall a. Maybe a
Nothing DataFamInstDecl GhcPs
dfi
       ; (InstDecl GhcRn, NameSet) -> RnM (InstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataFamInstD :: forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD { dfid_ext :: XDataFamInstD GhcRn
dfid_ext = XDataFamInstD GhcRn
NoExt
noExt, dfid_inst :: DataFamInstDecl GhcRn
dfid_inst = DataFamInstDecl GhcRn
dfi' }, NameSet
fvs) }

rnSrcInstDecl (ClsInstD { cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst = ClsInstDecl GhcPs
cid })
  = do { String -> SDoc -> TcRn ()
traceRn "rnSrcIstDecl {" (ClsInstDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInstDecl GhcPs
cid)
       ; (cid' :: ClsInstDecl GhcRn
cid', fvs :: NameSet
fvs) <- ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, NameSet)
rnClsInstDecl ClsInstDecl GhcPs
cid
       ; String -> SDoc -> TcRn ()
traceRn "rnSrcIstDecl end }" SDoc
empty
       ; (InstDecl GhcRn, NameSet) -> RnM (InstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstD :: forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
ClsInstD { cid_d_ext :: XClsInstD GhcRn
cid_d_ext = XClsInstD GhcRn
NoExt
noExt, cid_inst :: ClsInstDecl GhcRn
cid_inst = ClsInstDecl GhcRn
cid' }, NameSet
fvs) }

rnSrcInstDecl (XInstDecl _) = String -> RnM (InstDecl GhcRn, NameSet)
forall a. String -> a
panic "rnSrcInstDecl"

-- | Warn about non-canonical typeclass instance declarations
--
-- A "non-canonical" instance definition can occur for instances of a
-- class which redundantly defines an operation its superclass
-- provides as well (c.f. `return`/`pure`). In such cases, a canonical
-- instance is one where the subclass inherits its method
-- implementation from its superclass instance (usually the subclass
-- has a default method implementation to that effect). Consequently,
-- a non-canonical instance occurs when this is not the case.
--
-- See also descriptions of 'checkCanonicalMonadInstances' and
-- 'checkCanonicalMonoidInstances'
checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> TcRn ()
checkCanonicalInstances cls :: Name
cls poly_ty :: LHsSigType GhcRn
poly_ty mbinds :: LHsBinds GhcRn
mbinds = do
    WarningFlag -> TcRn () -> TcRn ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNonCanonicalMonadInstances
        TcRn ()
checkCanonicalMonadInstances

    WarningFlag -> TcRn () -> TcRn ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNonCanonicalMonoidInstances
        TcRn ()
checkCanonicalMonoidInstances

  where
    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
    -- declarations. Specifically, the following conditions are verified:
    --
    -- In 'Monad' instances declarations:
    --
    --  * If 'return' is overridden it must be canonical (i.e. @return = pure@)
    --  * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)
    --
    -- In 'Applicative' instance declarations:
    --
    --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).
    --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
    --
    checkCanonicalMonadInstances :: TcRn ()
checkCanonicalMonadInstances
      | Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
applicativeClassName  = do
          [LHsBindLR GhcRn GhcRn]
-> (LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (LHsBinds GhcRn -> [LHsBindLR GhcRn GhcRn]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) ((LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ())
-> (LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(LHsBindLR GhcRn GhcRn
-> Located (SrcSpanLess (LHsBindLR GhcRn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc mbind :: SrcSpanLess (LHsBindLR GhcRn GhcRn)
mbind) -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
              case SrcSpanLess (LHsBindLR GhcRn GhcRn)
mbind of
                  FunBind { fun_id = (dL->L _ name)
                          , fun_matches = mg }
                      | Name
SrcSpanLess (Located Name)
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
pureAName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Name
forall a. a -> Maybe a
Just Name
returnMName
                      -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1
                            WarningFlag
Opt_WarnNonCanonicalMonadInstances "pure" "return"

                      | Name
SrcSpanLess (Located Name)
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
thenAName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Name
forall a. a -> Maybe a
Just Name
thenMName
                      -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1
                            WarningFlag
Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"

                  _ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      | Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
monadClassName  = do
          [LHsBindLR GhcRn GhcRn]
-> (LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (LHsBinds GhcRn -> [LHsBindLR GhcRn GhcRn]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) ((LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ())
-> (LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(LHsBindLR GhcRn GhcRn
-> Located (SrcSpanLess (LHsBindLR GhcRn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc mbind :: SrcSpanLess (LHsBindLR GhcRn GhcRn)
mbind) -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
              case SrcSpanLess (LHsBindLR GhcRn GhcRn)
mbind of
                  FunBind { fun_id = (dL->L _ name)
                          , fun_matches = mg }
                      | Name
SrcSpanLess (Located Name)
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
returnMName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Maybe Name
forall a. a -> Maybe a
Just Name
pureAName
                      -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2
                            WarningFlag
Opt_WarnNonCanonicalMonadInstances "return" "pure"

                      | Name
SrcSpanLess (Located Name)
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
thenMName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Maybe Name
forall a. a -> Maybe a
Just Name
thenAName
                      -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2
                            WarningFlag
Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"

                  _ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      | Bool
otherwise = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- | Check whether Monoid(mappend) is defined in terms of
    -- Semigroup((<>)) (and not the other way round). Specifically,
    -- the following conditions are verified:
    --
    -- In 'Monoid' instances declarations:
    --
    --  * If 'mappend' is overridden it must be canonical
    --    (i.e. @mappend = (<>)@)
    --
    -- In 'Semigroup' instance declarations:
    --
    --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
    --
    checkCanonicalMonoidInstances :: TcRn ()
checkCanonicalMonoidInstances
      | Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
semigroupClassName  = do
          [LHsBindLR GhcRn GhcRn]
-> (LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (LHsBinds GhcRn -> [LHsBindLR GhcRn GhcRn]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) ((LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ())
-> (LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(LHsBindLR GhcRn GhcRn
-> Located (SrcSpanLess (LHsBindLR GhcRn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc mbind :: SrcSpanLess (LHsBindLR GhcRn GhcRn)
mbind) -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
              case SrcSpanLess (LHsBindLR GhcRn GhcRn)
mbind of
                  FunBind { fun_id      = (dL->L _ name)
                          , fun_matches = mg }
                      | Name
SrcSpanLess (Located Name)
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
sappendName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Name
forall a. a -> Maybe a
Just Name
mappendName
                      -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1
                            WarningFlag
Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"

                  _ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      | Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
monoidClassName  = do
          [LHsBindLR GhcRn GhcRn]
-> (LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (LHsBinds GhcRn -> [LHsBindLR GhcRn GhcRn]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) ((LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ())
-> (LHsBindLR GhcRn GhcRn -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(LHsBindLR GhcRn GhcRn
-> Located (SrcSpanLess (LHsBindLR GhcRn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc mbind :: SrcSpanLess (LHsBindLR GhcRn GhcRn)
mbind) -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
              case SrcSpanLess (LHsBindLR GhcRn GhcRn)
mbind of
                  FunBind { fun_id = (dL->L _ name)
                          , fun_matches = mg }
                      | Name
SrcSpanLess (Located Name)
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
mappendName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Maybe Name
forall a. a -> Maybe a
Just Name
sappendName
                      -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2NoDefault
                            WarningFlag
Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"

                  _ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      | Bool
otherwise = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
    -- binding, and return @Just rhsName@ if this is the case
    isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
    isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MG {mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = (Located [LMatch GhcRn (LHsExpr GhcRn)]
-> Located (SrcSpanLess (Located [LMatch GhcRn (LHsExpr GhcRn)]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _
                             [dL->L _ (Match { m_pats = []
                                             , m_grhss = grhss })])}
        | GRHSs _ [LGRHS GhcRn (LHsExpr GhcRn)
-> Located (SrcSpanLess (LGRHS GhcRn (LHsExpr GhcRn)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (GRHS _ [] body)] lbinds :: LHsLocalBinds GhcRn
lbinds <- GRHSs GhcRn (LHsExpr GhcRn)
grhss
        , EmptyLocalBinds _ <- LHsLocalBinds GhcRn -> SrcSpanLess (LHsLocalBinds GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsLocalBinds GhcRn
lbinds
        , HsVar _ lrhsName  <- LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
body  = Name -> Maybe Name
forall a. a -> Maybe a
Just (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
Located (IdP GhcRn)
lrhsName)
    isAliasMG _ = Maybe Name
forall a. Maybe a
Nothing

    -- got "lhs = rhs" but expected something different
    addWarnNonCanonicalMethod1 :: WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 flag :: WarningFlag
flag lhs :: String
lhs rhs :: String
rhs = do
        WarnReason -> SDoc -> TcRn ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
flag) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
                       [ String -> SDoc
text "Noncanonical" SDoc -> SDoc -> SDoc
<+>
                         SDoc -> SDoc
quotes (String -> SDoc
text (String
lhs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rhs)) SDoc -> SDoc -> SDoc
<+>
                         String -> SDoc
text "definition detected"
                       , LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
poly_ty
                       , String -> SDoc
text "Move definition from" SDoc -> SDoc -> SDoc
<+>
                         SDoc -> SDoc
quotes (String -> SDoc
text String
rhs) SDoc -> SDoc -> SDoc
<+>
                         String -> SDoc
text "to" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
lhs)
                       ]

    -- expected "lhs = rhs" but got something else
    addWarnNonCanonicalMethod2 :: WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 flag :: WarningFlag
flag lhs :: String
lhs rhs :: String
rhs = do
        WarnReason -> SDoc -> TcRn ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
flag) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
                       [ String -> SDoc
text "Noncanonical" SDoc -> SDoc -> SDoc
<+>
                         SDoc -> SDoc
quotes (String -> SDoc
text String
lhs) SDoc -> SDoc -> SDoc
<+>
                         String -> SDoc
text "definition detected"
                       , LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
poly_ty
                       , String -> SDoc
text "Either remove definition for" SDoc -> SDoc -> SDoc
<+>
                         SDoc -> SDoc
quotes (String -> SDoc
text String
lhs) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "or define as" SDoc -> SDoc -> SDoc
<+>
                         SDoc -> SDoc
quotes (String -> SDoc
text (String
lhs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rhs))
                       ]

    -- like above, but method has no default impl
    addWarnNonCanonicalMethod2NoDefault :: WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2NoDefault flag :: WarningFlag
flag lhs :: String
lhs rhs :: String
rhs = do
        WarnReason -> SDoc -> TcRn ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
flag) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
                       [ String -> SDoc
text "Noncanonical" SDoc -> SDoc -> SDoc
<+>
                         SDoc -> SDoc
quotes (String -> SDoc
text String
lhs) SDoc -> SDoc -> SDoc
<+>
                         String -> SDoc
text "definition detected"
                       , LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
poly_ty
                       , String -> SDoc
text "Define as" SDoc -> SDoc -> SDoc
<+>
                         SDoc -> SDoc
quotes (String -> SDoc
text (String
lhs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rhs))
                       ]

    -- stolen from TcInstDcls
    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 hs_inst_ty :: LHsSigType GhcRn
hs_inst_ty
      = SDoc -> SDoc
inst_decl_ctxt (LHsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsSigType GhcRn -> LHsType GhcRn
forall pass. LHsSigType pass -> LHsType pass
getLHsInstDeclHead LHsSigType GhcRn
hs_inst_ty))

    inst_decl_ctxt :: SDoc -> SDoc
    inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc :: SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "in the instance declaration for")
                         2 (SDoc -> SDoc
quotes SDoc
doc SDoc -> SDoc -> SDoc
<> String -> SDoc
text ".")


rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, NameSet)
rnClsInstDecl (ClsInstDecl { cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_poly_ty = LHsSigType GhcPs
inst_ty, cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds = LHsBinds GhcPs
mbinds
                           , cid_sigs :: forall pass. ClsInstDecl pass -> [LSig pass]
cid_sigs = [LSig GhcPs]
uprags, cid_tyfam_insts :: forall pass. ClsInstDecl pass -> [LTyFamInstDecl pass]
cid_tyfam_insts = [LTyFamInstDecl GhcPs]
ats
                           , cid_overlap_mode :: forall pass. ClsInstDecl pass -> Maybe (Located OverlapMode)
cid_overlap_mode = Maybe (Located OverlapMode)
oflag
                           , cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_datafam_insts = [LDataFamInstDecl GhcPs]
adts })
  = do { (inst_ty' :: LHsSigType GhcRn
inst_ty', inst_fvs :: NameSet
inst_fvs)
           <- HsDocContext -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType (SDoc -> HsDocContext
GenericCtx (SDoc -> HsDocContext) -> SDoc -> HsDocContext
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "an instance declaration") LHsSigType GhcPs
inst_ty
       ; let (ktv_names :: [Name]
ktv_names, _, head_ty' :: LHsType GhcRn
head_ty') = LHsSigType GhcRn -> ([Name], LHsContext GhcRn, LHsType GhcRn)
splitLHsInstDeclTy LHsSigType GhcRn
inst_ty'
       ; Name
cls <-
           case LHsType GhcRn -> Maybe (Located (IdP GhcRn))
forall (p :: Pass).
LHsType (GhcPass p) -> Maybe (Located (IdP (GhcPass p)))
hsTyGetAppHead_maybe LHsType GhcRn
head_ty' of
             Just (Located (IdP GhcRn) -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ cls :: SrcSpanLess (Located Name)
cls) -> Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
SrcSpanLess (Located Name)
cls
             Nothing -> do
               -- The instance is malformed. We'd still like
               -- to make *some* progress (rather than failing outright), so
               -- we report an error and continue for as long as we can.
               -- Importantly, this error should be thrown before we reach the
               -- typechecker, lest we encounter different errors that are
               -- hopelessly confusing (such as the one in Trac #16114).
               SrcSpan -> SDoc -> TcRn ()
addErrAt (LHsType GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsSigType GhcPs -> LHsType GhcPs
forall pass. LHsSigType pass -> LHsType pass
hsSigType LHsSigType GhcPs
inst_ty)) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                 SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Illegal class instance:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsSigType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcPs
inst_ty))
                    2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text "Class instances must be of the form"
                            , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "context => C ty_1 ... ty_n"
                            , String -> SDoc
text "where" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Char -> SDoc
char 'C')
                              SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is a class"
                            ])
               Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a b. (a -> b) -> a -> b
$ OccName -> Name
mkUnboundName (CLabelString -> OccName
mkTcOccFS (String -> CLabelString
fsLit "<class>"))

          -- Rename the bindings
          -- The typechecker (not the renamer) checks that all
          -- the bindings are for the right class
          -- (Slightly strangely) when scoped type variables are on, the
          -- forall-d tyvars scope over the method bindings too
       ; (mbinds' :: LHsBinds GhcRn
mbinds', uprags' :: [LSig GhcRn]
uprags', meth_fvs :: NameSet
meth_fvs) <- Bool
-> Name
-> [Name]
-> LHsBinds GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], NameSet)
rnMethodBinds Bool
False Name
cls [Name]
ktv_names LHsBinds GhcPs
mbinds [LSig GhcPs]
uprags

       ; Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> TcRn ()
checkCanonicalInstances Name
cls LHsSigType GhcRn
inst_ty' LHsBinds GhcRn
mbinds'

       -- Rename the associated types, and type signatures
       -- Both need to have the instance type variables in scope
       ; String -> SDoc -> TcRn ()
traceRn "rnSrcInstDecl" (LHsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
inst_ty' SDoc -> SDoc -> SDoc
$$ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
ktv_names)
       ; ((ats' :: [Located (TyFamInstDecl GhcRn)]
ats', adts' :: [Located (DataFamInstDecl GhcRn)]
adts'), more_fvs :: NameSet
more_fvs)
             <- [Name]
-> RnM
     (([Located (TyFamInstDecl GhcRn)],
       [Located (DataFamInstDecl GhcRn)]),
      NameSet)
-> RnM
     (([Located (TyFamInstDecl GhcRn)],
       [Located (DataFamInstDecl GhcRn)]),
      NameSet)
forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
extendTyVarEnvFVRn [Name]
ktv_names (RnM
   (([Located (TyFamInstDecl GhcRn)],
     [Located (DataFamInstDecl GhcRn)]),
    NameSet)
 -> RnM
      (([Located (TyFamInstDecl GhcRn)],
        [Located (DataFamInstDecl GhcRn)]),
       NameSet))
-> RnM
     (([Located (TyFamInstDecl GhcRn)],
       [Located (DataFamInstDecl GhcRn)]),
      NameSet)
-> RnM
     (([Located (TyFamInstDecl GhcRn)],
       [Located (DataFamInstDecl GhcRn)]),
      NameSet)
forall a b. (a -> b) -> a -> b
$
                do { (ats' :: [Located (TyFamInstDecl GhcRn)]
ats',  at_fvs :: NameSet
at_fvs)  <- (Maybe (Name, [Name])
 -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet))
-> Name
-> [Name]
-> [LTyFamInstDecl GhcPs]
-> RnM ([Located (TyFamInstDecl GhcRn)], NameSet)
forall (decl :: * -> *).
(Maybe (Name, [Name]) -> decl GhcPs -> RnM (decl GhcRn, NameSet))
-> Name
-> [Name]
-> [Located (decl GhcPs)]
-> RnM ([Located (decl GhcRn)], NameSet)
rnATInstDecls Maybe (Name, [Name])
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet)
rnTyFamInstDecl Name
cls [Name]
ktv_names [LTyFamInstDecl GhcPs]
ats
                   ; (adts' :: [Located (DataFamInstDecl GhcRn)]
adts', adt_fvs :: NameSet
adt_fvs) <- (Maybe (Name, [Name])
 -> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, NameSet))
-> Name
-> [Name]
-> [LDataFamInstDecl GhcPs]
-> RnM ([Located (DataFamInstDecl GhcRn)], NameSet)
forall (decl :: * -> *).
(Maybe (Name, [Name]) -> decl GhcPs -> RnM (decl GhcRn, NameSet))
-> Name
-> [Name]
-> [Located (decl GhcPs)]
-> RnM ([Located (decl GhcRn)], NameSet)
rnATInstDecls Maybe (Name, [Name])
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, NameSet)
rnDataFamInstDecl Name
cls [Name]
ktv_names [LDataFamInstDecl GhcPs]
adts
                   ; (([Located (TyFamInstDecl GhcRn)],
  [Located (DataFamInstDecl GhcRn)]),
 NameSet)
-> RnM
     (([Located (TyFamInstDecl GhcRn)],
       [Located (DataFamInstDecl GhcRn)]),
      NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ( ([Located (TyFamInstDecl GhcRn)]
ats', [Located (DataFamInstDecl GhcRn)]
adts'), NameSet
at_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
adt_fvs) }

       ; let all_fvs :: NameSet
all_fvs = NameSet
meth_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
more_fvs
                                NameSet -> NameSet -> NameSet
`plusFV` NameSet
inst_fvs
       ; (ClsInstDecl GhcRn, NameSet) -> RnM (ClsInstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstDecl :: forall pass.
XCClsInstDecl pass
-> LHsSigType pass
-> LHsBinds pass
-> [LSig pass]
-> [LTyFamInstDecl pass]
-> [LDataFamInstDecl pass]
-> Maybe (Located OverlapMode)
-> ClsInstDecl pass
ClsInstDecl { cid_ext :: XCClsInstDecl GhcRn
cid_ext = XCClsInstDecl GhcRn
NoExt
noExt
                             , cid_poly_ty :: LHsSigType GhcRn
cid_poly_ty = LHsSigType GhcRn
inst_ty', cid_binds :: LHsBinds GhcRn
cid_binds = LHsBinds GhcRn
mbinds'
                             , cid_sigs :: [LSig GhcRn]
cid_sigs = [LSig GhcRn]
uprags', cid_tyfam_insts :: [Located (TyFamInstDecl GhcRn)]
cid_tyfam_insts = [Located (TyFamInstDecl GhcRn)]
ats'
                             , cid_overlap_mode :: Maybe (Located OverlapMode)
cid_overlap_mode = Maybe (Located OverlapMode)
oflag
                             , cid_datafam_insts :: [Located (DataFamInstDecl GhcRn)]
cid_datafam_insts = [Located (DataFamInstDecl GhcRn)]
adts' },
                 NameSet
all_fvs) }
             -- We return the renamed associated data type declarations so
             -- that they can be entered into the list of type declarations
             -- for the binding group, but we also keep a copy in the instance.
             -- The latter is needed for well-formedness checks in the type
             -- checker (eg, to ensure that all ATs of the instance actually
             -- receive a declaration).
             -- NB: Even the copies in the instance declaration carry copies of
             --     the instance context after renaming.  This is a bit
             --     strange, but should not matter (and it would be more work
             --     to remove the context).
rnClsInstDecl (XClsInstDecl _) = String -> RnM (ClsInstDecl GhcRn, NameSet)
forall a. String -> a
panic "rnClsInstDecl"

rnFamInstEqn :: HsDocContext
             -> Maybe (Name, [Name]) -- Nothing => not associated
                                     -- Just (cls,tvs) => associated,
                                     --   and gives class and tyvars of the
                                     --   parent instance decl
             -> [Located RdrName]    -- Kind variables from the equation's RHS
             -> FamInstEqn GhcPs rhs
             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
             -> RnM (FamInstEqn GhcRn rhs', FreeVars)
rnFamInstEqn :: HsDocContext
-> Maybe (Name, [Name])
-> [GenLocated SrcSpan RdrName]
-> FamInstEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet)
rnFamInstEqn doc :: HsDocContext
doc mb_cls :: Maybe (Name, [Name])
mb_cls rhs_kvars :: [GenLocated SrcSpan RdrName]
rhs_kvars
    (HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = FamEqn { feqn_tycon :: forall pass pats rhs. FamEqn pass pats rhs -> Located (IdP pass)
feqn_tycon  = Located (IdP GhcPs)
tycon
                               , feqn_bndrs :: forall pass pats rhs.
FamEqn pass pats rhs -> Maybe [LHsTyVarBndr pass]
feqn_bndrs  = Maybe [LHsTyVarBndr GhcPs]
mb_bndrs
                               , feqn_pats :: forall pass pats rhs. FamEqn pass pats rhs -> pats
feqn_pats   = HsTyPats GhcPs
pats
                               , feqn_fixity :: forall pass pats rhs. FamEqn pass pats rhs -> LexicalFixity
feqn_fixity = LexicalFixity
fixity
                               , feqn_rhs :: forall pass pats rhs. FamEqn pass pats rhs -> rhs
feqn_rhs    = rhs
payload }}) rn_payload :: HsDocContext -> rhs -> RnM (rhs', NameSet)
rn_payload
  = do { Located Name
tycon'   <- Maybe Name -> GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupFamInstName (((Name, [Name]) -> Name) -> Maybe (Name, [Name]) -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, [Name]) -> Name
forall a b. (a, b) -> a
fst Maybe (Name, [Name])
mb_cls) GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon
       ; let pat_kity_vars_with_dups :: FreeKiTyVarsWithDups
pat_kity_vars_with_dups = HsTyPats GhcPs -> FreeKiTyVarsWithDups
extractHsTyArgRdrKiTyVarsDup HsTyPats GhcPs
pats
             -- Use the "...Dups" form because it's needed
             -- below to report unsed binder on the LHS
       ; let pat_kity_vars :: FreeKiTyVarsWithDups
pat_kity_vars = FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
rmDupsInRdrTyVars FreeKiTyVarsWithDups
pat_kity_vars_with_dups

         -- all pat vars not explicitly bound (see extractHsTvBndrs)
       ; let mb_imp_kity_vars :: Maybe FreeKiTyVarsWithDups
mb_imp_kity_vars = [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extractHsTvBndrs ([LHsTyVarBndr GhcPs]
 -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> Maybe [LHsTyVarBndr GhcPs]
-> Maybe (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [LHsTyVarBndr GhcPs]
mb_bndrs Maybe (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> Maybe FreeKiTyVarsWithDups -> Maybe FreeKiTyVarsWithDups
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FreeKiTyVarsWithDups -> Maybe FreeKiTyVarsWithDups
forall (f :: * -> *) a. Applicative f => a -> f a
pure FreeKiTyVarsWithDups
pat_kity_vars
             imp_vars :: [GenLocated SrcSpan RdrName]
imp_vars = case Maybe FreeKiTyVarsWithDups
mb_imp_kity_vars of
                          -- kind vars are the only ones free if we have an explicit forall
                          Just nbnd_kity_vars :: FreeKiTyVarsWithDups
nbnd_kity_vars -> FreeKiTyVarsWithDups -> [GenLocated SrcSpan RdrName]
freeKiTyVarsKindVars FreeKiTyVarsWithDups
nbnd_kity_vars
                          -- all pattern vars are free otherwise
                          Nothing             -> FreeKiTyVarsWithDups -> [GenLocated SrcSpan RdrName]
freeKiTyVarsAllVars FreeKiTyVarsWithDups
pat_kity_vars
       ; [Name]
imp_var_names <- (GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe (Name, [Name])
-> GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a
-> GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe (Name, [Name])
mb_cls) [GenLocated SrcSpan RdrName]
imp_vars

       ; let bndrs :: [LHsTyVarBndr GhcPs]
bndrs = [LHsTyVarBndr GhcPs]
-> Maybe [LHsTyVarBndr GhcPs] -> [LHsTyVarBndr GhcPs]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [LHsTyVarBndr GhcPs]
mb_bndrs
             bnd_vars :: [GenLocated SrcSpan RdrName]
bnd_vars = (LHsTyVarBndr GhcPs -> GenLocated SrcSpan RdrName)
-> [LHsTyVarBndr GhcPs] -> [GenLocated SrcSpan RdrName]
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr GhcPs -> GenLocated SrcSpan RdrName
forall pass. LHsTyVarBndr pass -> Located (IdP pass)
hsLTyVarLocName [LHsTyVarBndr GhcPs]
bndrs
             payload_kvars :: [GenLocated SrcSpan RdrName]
payload_kvars = (GenLocated SrcSpan RdrName -> Bool)
-> [GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (GenLocated SrcSpan RdrName -> [GenLocated SrcSpan RdrName] -> Bool
`elemRdr` ([GenLocated SrcSpan RdrName]
bnd_vars [GenLocated SrcSpan RdrName]
-> [GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpan RdrName]
imp_vars)) [GenLocated SrcSpan RdrName]
rhs_kvars
             -- Make sure to filter out the kind variables that were explicitly
             -- bound in the type patterns.
       ; [Name]
payload_kvar_names <- (GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe (Name, [Name])
-> GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a
-> GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe (Name, [Name])
mb_cls) [GenLocated SrcSpan RdrName]
payload_kvars

         -- all names not bound in an explict forall
       ; let all_imp_var_names :: [Name]
all_imp_var_names = [Name]
imp_var_names [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
payload_kvar_names

             -- All the free vars of the family patterns
             -- with a sensible binding location
       ; ((bndrs' :: [LHsTyVarBndr GhcRn]
bndrs', pats' :: [LHsTypeArg GhcRn]
pats', payload' :: rhs'
payload'), fvs :: NameSet
fvs)
              <- [Name]
-> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet)
-> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet)
forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
bindLocalNamesFV [Name]
all_imp_var_names (RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet)
 -> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet))
-> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet)
-> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet)
forall a b. (a -> b) -> a -> b
$
                 HsDocContext
-> Maybe SDoc
-> Maybe Any
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn]
    -> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet))
-> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet)
forall a b.
HsDocContext
-> Maybe SDoc
-> Maybe a
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindLHsTyVarBndrs HsDocContext
doc (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ HsDocContext -> SDoc
inHsDocContext HsDocContext
doc)
                                   Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr GhcPs]
bndrs (([LHsTyVarBndr GhcRn]
  -> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet))
 -> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet))
-> ([LHsTyVarBndr GhcRn]
    -> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet))
-> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet)
forall a b. (a -> b) -> a -> b
$ \bndrs' :: [LHsTyVarBndr GhcRn]
bndrs' ->
                 -- Note: If we pass mb_cls instead of Nothing here,
                 --  bindLHsTyVarBndrs will use class variables for any names
                 --  the user meant to bring in scope here. This is an explicit
                 --  forall, so we want fresh names, not class variables.
                 --  Thus: always pass Nothing
                 do { (pats' :: [LHsTypeArg GhcRn]
pats', pat_fvs :: NameSet
pat_fvs) <- HsDocContext -> HsTyPats GhcPs -> RnM ([LHsTypeArg GhcRn], NameSet)
rnLHsTypeArgs (GenLocated SrcSpan RdrName -> HsDocContext
FamPatCtx GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon) HsTyPats GhcPs
pats
                    ; (payload' :: rhs'
payload', rhs_fvs :: NameSet
rhs_fvs) <- HsDocContext -> rhs -> RnM (rhs', NameSet)
rn_payload HsDocContext
doc rhs
payload

                       -- Report unused binders on the LHS
                       -- See Note [Unused type variables in family instances]
                    ; let groups :: [NonEmpty (Located RdrName)]
                          groups :: [NonEmpty (GenLocated SrcSpan RdrName)]
groups = (GenLocated SrcSpan RdrName
 -> GenLocated SrcSpan RdrName -> Ordering)
-> [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses GenLocated SrcSpan RdrName
-> GenLocated SrcSpan RdrName -> Ordering
forall a. (HasSrcSpan a, Ord (SrcSpanLess a)) => a -> a -> Ordering
cmpLocated ([GenLocated SrcSpan RdrName]
 -> [NonEmpty (GenLocated SrcSpan RdrName)])
-> [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
forall a b. (a -> b) -> a -> b
$
                                   FreeKiTyVarsWithDups -> [GenLocated SrcSpan RdrName]
freeKiTyVarsAllVars FreeKiTyVarsWithDups
pat_kity_vars_with_dups
                    ; [Name]
nms_dups <- (GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupOccRn (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> (GenLocated SrcSpan RdrName -> RdrName)
-> GenLocated SrcSpan RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) ([GenLocated SrcSpan RdrName]
 -> IOEnv (Env TcGblEnv TcLclEnv) [Name])
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall a b. (a -> b) -> a -> b
$
                                     [ GenLocated SrcSpan RdrName
tv | (tv :: GenLocated SrcSpan RdrName
tv :| (_:_)) <- [NonEmpty (GenLocated SrcSpan RdrName)]
groups ]
                          -- Add to the used variables
                          --  a) any variables that appear *more than once* on the LHS
                          --     e.g.   F a Int a = Bool
                          --  b) for associated instances, the variables
                          --     of the instance decl.  See
                          --     Note [Unused type variables in family instances]
                    ; let nms_used :: NameSet
nms_used = NameSet -> [Name] -> NameSet
extendNameSetList NameSet
rhs_fvs ([Name] -> NameSet) -> [Name] -> NameSet
forall a b. (a -> b) -> a -> b
$
                                        [Name]
inst_tvs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
nms_dups
                          inst_tvs :: [Name]
inst_tvs = case Maybe (Name, [Name])
mb_cls of
                                       Nothing            -> []
                                       Just (_, inst_tvs :: [Name]
inst_tvs) -> [Name]
inst_tvs
                          all_nms :: [Name]
all_nms = [Name]
all_imp_var_names
                                      [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (LHsTyVarBndr GhcRn -> Name) -> [LHsTyVarBndr GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr GhcRn -> Name
forall pass. LHsTyVarBndr pass -> IdP pass
hsLTyVarName [LHsTyVarBndr GhcRn]
bndrs'
                    ; [Name] -> NameSet -> TcRn ()
warnUnusedTypePatterns [Name]
all_nms NameSet
nms_used

                    ; (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet)
-> RnM (([LHsTyVarBndr GhcRn], [LHsTypeArg GhcRn], rhs'), NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (([LHsTyVarBndr GhcRn]
bndrs', [LHsTypeArg GhcRn]
pats', rhs'
payload'), NameSet
rhs_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
pat_fvs) }

       ; let all_fvs :: NameSet
all_fvs  = NameSet
fvs NameSet -> Name -> NameSet
`addOneFV` Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
tycon'
            -- type instance => use, hence addOneFV

       ; (FamInstEqn GhcRn rhs', NameSet)
-> RnM (FamInstEqn GhcRn rhs', NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsIB :: forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
HsIB { hsib_ext :: XHsIB GhcRn (FamEqn GhcRn [LHsTypeArg GhcRn] rhs')
hsib_ext = [Name]
XHsIB GhcRn (FamEqn GhcRn [LHsTypeArg GhcRn] rhs')
all_imp_var_names -- Note [Wildcards in family instances]
                      , hsib_body :: FamEqn GhcRn [LHsTypeArg GhcRn] rhs'
hsib_body
                          = FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcRn [LHsTypeArg GhcRn] rhs'
feqn_ext    = XCFamEqn GhcRn [LHsTypeArg GhcRn] rhs'
NoExt
noExt
                                   , feqn_tycon :: Located (IdP GhcRn)
feqn_tycon  = Located Name
Located (IdP GhcRn)
tycon'
                                   , feqn_bndrs :: Maybe [LHsTyVarBndr GhcRn]
feqn_bndrs  = [LHsTyVarBndr GhcRn]
bndrs' [LHsTyVarBndr GhcRn]
-> Maybe [LHsTyVarBndr GhcPs] -> Maybe [LHsTyVarBndr GhcRn]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe [LHsTyVarBndr GhcPs]
mb_bndrs
                                   , feqn_pats :: [LHsTypeArg GhcRn]
feqn_pats   = [LHsTypeArg GhcRn]
pats'
                                   , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
                                   , feqn_rhs :: rhs'
feqn_rhs    = rhs'
payload' } },
                 NameSet
all_fvs) }
rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = String -> RnM (FamInstEqn GhcRn rhs', NameSet)
forall a. String -> a
panic "rnFamInstEqn"
rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = String -> RnM (FamInstEqn GhcRn rhs', NameSet)
forall a. String -> a
panic "rnFamInstEqn"

rnTyFamInstDecl :: Maybe (Name, [Name]) -- Just (cls,tvs) => associated,
                                        --   and gives class and tyvars of
                                        --   the parent instance decl
                -> TyFamInstDecl GhcPs
                -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl :: Maybe (Name, [Name])
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet)
rnTyFamInstDecl mb_cls :: Maybe (Name, [Name])
mb_cls (TyFamInstDecl { tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn = TyFamInstEqn GhcPs
eqn })
  = do { (eqn' :: TyFamInstEqn GhcRn
eqn', fvs :: NameSet
fvs) <- Maybe (Name, [Name])
-> ClosedTyFamInfo
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, NameSet)
rnTyFamInstEqn Maybe (Name, [Name])
mb_cls ClosedTyFamInfo
NotClosedTyFam TyFamInstEqn GhcPs
eqn
       ; (TyFamInstDecl GhcRn, NameSet)
-> RnM (TyFamInstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyFamInstDecl :: forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl { tfid_eqn :: TyFamInstEqn GhcRn
tfid_eqn = TyFamInstEqn GhcRn
eqn' }, NameSet
fvs) }

-- | Tracks whether we are renaming an equation in a closed type family
-- equation ('ClosedTyFam') or not ('NotClosedTyFam').
data ClosedTyFamInfo
  = NotClosedTyFam
  | ClosedTyFam (Located RdrName) Name
                -- The names (RdrName and Name) of the closed type family

rnTyFamInstEqn :: Maybe (Name, [Name])
               -> ClosedTyFamInfo
               -> TyFamInstEqn GhcPs
               -> RnM (TyFamInstEqn GhcRn, FreeVars)
rnTyFamInstEqn :: Maybe (Name, [Name])
-> ClosedTyFamInfo
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, NameSet)
rnTyFamInstEqn mb_cls :: Maybe (Name, [Name])
mb_cls ctf_info :: ClosedTyFamInfo
ctf_info
    eqn :: TyFamInstEqn GhcPs
eqn@(HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = FamEqn { feqn_tycon :: forall pass pats rhs. FamEqn pass pats rhs -> Located (IdP pass)
feqn_tycon = Located (IdP GhcPs)
tycon
                                   , feqn_rhs :: forall pass pats rhs. FamEqn pass pats rhs -> rhs
feqn_rhs   = LHsType GhcPs
rhs }})
  = do { let rhs_kvs :: [GenLocated SrcSpan RdrName]
rhs_kvs = LHsType GhcPs -> [GenLocated SrcSpan RdrName]
extractHsTyRdrTyVarsKindVars LHsType GhcPs
rhs
       ; (eqn' :: TyFamInstEqn GhcRn
eqn'@(HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body =
                       FamEqn { feqn_tycon :: forall pass pats rhs. FamEqn pass pats rhs -> Located (IdP pass)
feqn_tycon = Located (IdP GhcRn) -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL -> L _ tycon' :: SrcSpanLess (Located Name)
tycon' }}), fvs :: NameSet
fvs)
           <- HsDocContext
-> Maybe (Name, [Name])
-> [GenLocated SrcSpan RdrName]
-> TyFamInstEqn GhcPs
-> (HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet))
-> RnM (TyFamInstEqn GhcRn, NameSet)
forall rhs rhs'.
HsDocContext
-> Maybe (Name, [Name])
-> [GenLocated SrcSpan RdrName]
-> FamInstEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet)
rnFamInstEqn (GenLocated SrcSpan RdrName -> HsDocContext
TySynCtx GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon) Maybe (Name, [Name])
mb_cls [GenLocated SrcSpan RdrName]
rhs_kvs TyFamInstEqn GhcPs
eqn HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnTySyn
       ; case ClosedTyFamInfo
ctf_info of
           NotClosedTyFam -> () -> TcRn ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
           ClosedTyFam fam_rdr_name :: GenLocated SrcSpan RdrName
fam_rdr_name fam_name :: Name
fam_name ->
             Bool -> SDoc -> TcRn ()
checkTc (Name
fam_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
SrcSpanLess (Located Name)
tycon') (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
             HsDocContext -> SDoc -> SDoc
withHsDocContext (GenLocated SrcSpan RdrName -> HsDocContext
TyFamilyCtx GenLocated SrcSpan RdrName
fam_rdr_name) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
             Name -> Name -> SDoc
wrongTyFamName Name
fam_name Name
SrcSpanLess (Located Name)
tycon'
       ; (TyFamInstEqn GhcRn, NameSet) -> RnM (TyFamInstEqn GhcRn, NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyFamInstEqn GhcRn
eqn', NameSet
fvs) }
rnTyFamInstEqn _ _ (HsIB _ (XFamEqn _)) = String -> RnM (TyFamInstEqn GhcRn, NameSet)
forall a. String -> a
panic "rnTyFamInstEqn"
rnTyFamInstEqn _ _ (XHsImplicitBndrs _) = String -> RnM (TyFamInstEqn GhcRn, NameSet)
forall a. String -> a
panic "rnTyFamInstEqn"

rnTyFamDefltEqn :: Name
                -> TyFamDefltEqn GhcPs
                -> RnM (TyFamDefltEqn GhcRn, FreeVars)
rnTyFamDefltEqn :: Name -> TyFamDefltEqn GhcPs -> RnM (TyFamDefltEqn GhcRn, NameSet)
rnTyFamDefltEqn cls :: Name
cls (FamEqn { feqn_tycon :: forall pass pats rhs. FamEqn pass pats rhs -> Located (IdP pass)
feqn_tycon  = Located (IdP GhcPs)
tycon
                            , feqn_bndrs :: forall pass pats rhs.
FamEqn pass pats rhs -> Maybe [LHsTyVarBndr pass]
feqn_bndrs  = Maybe [LHsTyVarBndr GhcPs]
bndrs
                            , feqn_pats :: forall pass pats rhs. FamEqn pass pats rhs -> pats
feqn_pats   = LHsQTyVars GhcPs
tyvars
                            , feqn_fixity :: forall pass pats rhs. FamEqn pass pats rhs -> LexicalFixity
feqn_fixity = LexicalFixity
fixity
                            , feqn_rhs :: forall pass pats rhs. FamEqn pass pats rhs -> rhs
feqn_rhs    = LHsType GhcPs
rhs })
  = do { let kvs :: [GenLocated SrcSpan RdrName]
kvs = LHsType GhcPs -> [GenLocated SrcSpan RdrName]
extractHsTyRdrTyVarsKindVars LHsType GhcPs
rhs
       ; HsDocContext
-> Maybe SDoc
-> Maybe Name
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (TyFamDefltEqn GhcRn, NameSet))
-> RnM (TyFamDefltEqn GhcRn, NameSet)
forall a b.
HsDocContext
-> Maybe SDoc
-> Maybe a
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindHsQTyVars HsDocContext
ctx Maybe SDoc
forall a. Maybe a
Nothing (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
cls) [GenLocated SrcSpan RdrName]
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn -> Bool -> RnM (TyFamDefltEqn GhcRn, NameSet))
 -> RnM (TyFamDefltEqn GhcRn, NameSet))
-> (LHsQTyVars GhcRn -> Bool -> RnM (TyFamDefltEqn GhcRn, NameSet))
-> RnM (TyFamDefltEqn GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ tyvars' :: LHsQTyVars GhcRn
tyvars' _ ->
    do { Located Name
tycon'      <- Maybe Name -> GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupFamInstName (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
cls) GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon
       ; (rhs' :: LHsType GhcRn
rhs', fvs :: NameSet
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsType HsDocContext
ctx LHsType GhcPs
rhs
       ; (TyFamDefltEqn GhcRn, NameSet)
-> RnM (TyFamDefltEqn GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcRn (LHsQTyVars GhcRn) (LHsType GhcRn)
feqn_ext    = XCFamEqn GhcRn (LHsQTyVars GhcRn) (LHsType GhcRn)
NoExt
noExt
                        , feqn_tycon :: Located (IdP GhcRn)
feqn_tycon  = Located Name
Located (IdP GhcRn)
tycon'
                        , feqn_bndrs :: Maybe [LHsTyVarBndr GhcRn]
feqn_bndrs  = ASSERT( isNothing bndrs )
                                        Maybe [LHsTyVarBndr GhcRn]
forall a. Maybe a
Nothing
                        , feqn_pats :: LHsQTyVars GhcRn
feqn_pats   = LHsQTyVars GhcRn
tyvars'
                        , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
                        , feqn_rhs :: LHsType GhcRn
feqn_rhs    = LHsType GhcRn
rhs' }, NameSet
fvs) } }
  where
    ctx :: HsDocContext
ctx = GenLocated SrcSpan RdrName -> HsDocContext
TyFamilyCtx GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon
rnTyFamDefltEqn _ (XFamEqn _) = String -> RnM (TyFamDefltEqn GhcRn, NameSet)
forall a. String -> a
panic "rnTyFamDefltEqn"

rnDataFamInstDecl :: Maybe (Name, [Name])
                  -> DataFamInstDecl GhcPs
                  -> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl :: Maybe (Name, [Name])
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, NameSet)
rnDataFamInstDecl mb_cls :: Maybe (Name, [Name])
mb_cls (DataFamInstDecl { dfid_eqn :: forall pass.
DataFamInstDecl pass -> FamInstEqn pass (HsDataDefn pass)
dfid_eqn = eqn :: FamInstEqn GhcPs (HsDataDefn GhcPs)
eqn@(HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body =
                           FamEqn { feqn_tycon :: forall pass pats rhs. FamEqn pass pats rhs -> Located (IdP pass)
feqn_tycon = Located (IdP GhcPs)
tycon
                                  , feqn_rhs :: forall pass pats rhs. FamEqn pass pats rhs -> rhs
feqn_rhs   = HsDataDefn GhcPs
rhs }})})
  = do { let rhs_kvs :: [GenLocated SrcSpan RdrName]
rhs_kvs = HsDataDefn GhcPs -> [GenLocated SrcSpan RdrName]
extractDataDefnKindVars HsDataDefn GhcPs
rhs
       ; (eqn' :: FamInstEqn GhcRn (HsDataDefn GhcRn)
eqn', fvs :: NameSet
fvs) <-
           HsDocContext
-> Maybe (Name, [Name])
-> [GenLocated SrcSpan RdrName]
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
-> (HsDocContext
    -> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, NameSet))
-> RnM (FamInstEqn GhcRn (HsDataDefn GhcRn), NameSet)
forall rhs rhs'.
HsDocContext
-> Maybe (Name, [Name])
-> [GenLocated SrcSpan RdrName]
-> FamInstEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet)
rnFamInstEqn (GenLocated SrcSpan RdrName -> HsDocContext
TyDataCtx GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon) Maybe (Name, [Name])
mb_cls [GenLocated SrcSpan RdrName]
rhs_kvs FamInstEqn GhcPs (HsDataDefn GhcPs)
eqn HsDocContext -> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, NameSet)
rnDataDefn
       ; (DataFamInstDecl GhcRn, NameSet)
-> RnM (DataFamInstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataFamInstDecl :: forall pass.
FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass
DataFamInstDecl { dfid_eqn :: FamInstEqn GhcRn (HsDataDefn GhcRn)
dfid_eqn = FamInstEqn GhcRn (HsDataDefn GhcRn)
eqn' }, NameSet
fvs) }
rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _)))
  = String -> RnM (DataFamInstDecl GhcRn, NameSet)
forall a. String -> a
panic "rnDataFamInstDecl"
rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs _))
  = String -> RnM (DataFamInstDecl GhcRn, NameSet)
forall a. String -> a
panic "rnDataFamInstDecl"

-- Renaming of the associated types in instances.

-- Rename associated type family decl in class
rnATDecls :: Name      -- Class
          -> [LFamilyDecl GhcPs]
          -> RnM ([LFamilyDecl GhcRn], FreeVars)
rnATDecls :: Name -> [LFamilyDecl GhcPs] -> RnM ([LFamilyDecl GhcRn], NameSet)
rnATDecls cls :: Name
cls at_decls :: [LFamilyDecl GhcPs]
at_decls
  = (FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, NameSet))
-> [LFamilyDecl GhcPs] -> RnM ([LFamilyDecl GhcRn], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList (Maybe Name -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, NameSet)
rnFamDecl (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
cls)) [LFamilyDecl GhcPs]
at_decls

rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
                  decl GhcPs ->            -- an instance. rnTyFamInstDecl
                  RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl
              -> Name      -- Class
              -> [Name]
              -> [Located (decl GhcPs)]
              -> RnM ([Located (decl GhcRn)], FreeVars)
-- Used for data and type family defaults in a class decl
-- and the family instance declarations in an instance
--
-- NB: We allow duplicate associated-type decls;
--     See Note [Associated type instances] in TcInstDcls
rnATInstDecls :: (Maybe (Name, [Name]) -> decl GhcPs -> RnM (decl GhcRn, NameSet))
-> Name
-> [Name]
-> [Located (decl GhcPs)]
-> RnM ([Located (decl GhcRn)], NameSet)
rnATInstDecls rnFun :: Maybe (Name, [Name]) -> decl GhcPs -> RnM (decl GhcRn, NameSet)
rnFun cls :: Name
cls tv_ns :: [Name]
tv_ns at_insts :: [Located (decl GhcPs)]
at_insts
  = (decl GhcPs -> RnM (decl GhcRn, NameSet))
-> [Located (decl GhcPs)] -> RnM ([Located (decl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList (Maybe (Name, [Name]) -> decl GhcPs -> RnM (decl GhcRn, NameSet)
rnFun ((Name, [Name]) -> Maybe (Name, [Name])
forall a. a -> Maybe a
Just (Name
cls, [Name]
tv_ns))) [Located (decl GhcPs)]
at_insts
    -- See Note [Renaming associated types]

{- Note [Wildcards in family instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Wild cards can be used in type/data family instance declarations to indicate
that the name of a type variable doesn't matter. Each wild card will be
replaced with a new unique type variable. For instance:

    type family F a b :: *
    type instance F Int _ = Int

is the same as

    type family F a b :: *
    type instance F Int b = Int

This is implemented as follows: Unnamed wildcards remain unchanged after
the renamer, and then given fresh meta-variables during typechecking, and
it is handled pretty much the same way as the ones in partial type signatures.
We however don't want to emit hole constraints on wildcards in family
instances, so we turn on PartialTypeSignatures and turn off warning flag to
let typechecker know this.
See related Note [Wildcards in visible kind application] in TcHsType.hs

Note [Unused type variables in family instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When the flag -fwarn-unused-type-patterns is on, the compiler reports
warnings about unused type variables in type-family instances. A
tpye variable is considered used (i.e. cannot be turned into a wildcard)
when

 * it occurs on the RHS of the family instance
   e.g.   type instance F a b = a    -- a is used on the RHS

 * it occurs multiple times in the patterns on the LHS
   e.g.   type instance F a a = Int  -- a appears more than once on LHS

 * it is one of the instance-decl variables, for associated types
   e.g.   instance C (a,b) where
            type T (a,b) = a
   Here the type pattern in the type instance must be the same as that
   for the class instance, so
            type T (a,_) = a
   would be rejected.  So we should not complain about an unused variable b

As usual, the warnings are not reported for type variables with names
beginning with an underscore.

Extra-constraints wild cards are not supported in type/data family
instance declarations.

Relevant tickets: #3699, #10586, #10982 and #11451.

Note [Renaming associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Check that the RHS of the decl mentions only type variables that are explicitly
bound on the LHS.  For example, this is not ok
   class C a b where
      type F a x :: *
   instance C (p,q) r where
      type F (p,q) x = (x, r)   -- BAD: mentions 'r'
c.f. Trac #5515

Kind variables, on the other hand, are allowed to be implicitly or explicitly
bound. As examples, this (#9574) is acceptable:
   class Funct f where
      type Codomain f :: *
   instance Funct ('KProxy :: KProxy o) where
      -- o is implicitly bound by the kind signature
      -- of the LHS type pattern ('KProxy)
      type Codomain 'KProxy = NatTr (Proxy :: o -> *)
And this (#14131) is also acceptable:
    data family Nat :: k -> k -> *
    -- k is implicitly bound by an invisible kind pattern
    newtype instance Nat :: (k -> *) -> (k -> *) -> * where
      Nat :: (forall xx. f xx -> g xx) -> Nat f g
We could choose to disallow this, but then associated type families would not
be able to be as expressive as top-level type synonyms. For example, this type
synonym definition is allowed:
    type T = (Nothing :: Maybe a)
So for parity with type synonyms, we also allow:
    type family   T :: Maybe a
    type instance T = (Nothing :: Maybe a)

All this applies only for *instance* declarations.  In *class*
declarations there is no RHS to worry about, and the class variables
can all be in scope (Trac #5862):
    class Category (x :: k -> k -> *) where
      type Ob x :: k -> Constraint
      id :: Ob x a => x a a
      (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
Here 'k' is in scope in the kind signature, just like 'x'.

Although type family equations can bind type variables with explicit foralls,
it need not be the case that all variables that appear on the RHS must be bound
by a forall. For instance, the following is acceptable:

   class C a where
     type T a b
   instance C (Maybe a) where
     type forall b. T (Maybe a) b = Either a b

Even though `a` is not bound by the forall, this is still accepted because `a`
was previously bound by the `instance C (Maybe a)` part. (see Trac #16116).

In each case, the function which detects improperly bound variables on the RHS
is TcValidity.checkValidFamPats.
-}


{-
*********************************************************
*                                                      *
\subsection{Stand-alone deriving declarations}
*                                                      *
*********************************************************
-}

rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, NameSet)
rnSrcDerivDecl (DerivDecl _ ty :: LHsSigWcType GhcPs
ty mds :: Maybe (LDerivStrategy GhcPs)
mds overlap :: Maybe (Located OverlapMode)
overlap)
  = do { Bool
standalone_deriv_ok <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.StandaloneDeriving
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
standalone_deriv_ok (SDoc -> TcRn ()
addErr SDoc
standaloneDerivErr)
       ; (mds' :: Maybe (LDerivStrategy GhcRn)
mds', ty' :: LHsSigWcType GhcRn
ty', fvs :: NameSet
fvs)
           <- HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> ([Name] -> SDoc -> RnM (LHsSigWcType GhcRn, NameSet))
-> RnM (Maybe (LDerivStrategy GhcRn), LHsSigWcType GhcRn, NameSet)
forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> ([Name] -> SDoc -> RnM (a, NameSet))
-> RnM (Maybe (LDerivStrategy GhcRn), a, NameSet)
rnLDerivStrategy HsDocContext
DerivDeclCtx Maybe (LDerivStrategy GhcPs)
mds (([Name] -> SDoc -> RnM (LHsSigWcType GhcRn, NameSet))
 -> RnM (Maybe (LDerivStrategy GhcRn), LHsSigWcType GhcRn, NameSet))
-> ([Name] -> SDoc -> RnM (LHsSigWcType GhcRn, NameSet))
-> RnM (Maybe (LDerivStrategy GhcRn), LHsSigWcType GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \strat_tvs :: [Name]
strat_tvs ppr_via_ty :: SDoc
ppr_via_ty ->
              [Name]
-> SrcSpan
-> SDoc
-> String
-> RnM (LHsSigWcType GhcRn, NameSet)
-> RnM (LHsSigWcType GhcRn, NameSet)
forall a.
Outputable a =>
[Name]
-> SrcSpan
-> SDoc
-> String
-> RnM (a, NameSet)
-> RnM (a, NameSet)
rnAndReportFloatingViaTvs [Name]
strat_tvs SrcSpan
loc SDoc
ppr_via_ty "instance" (RnM (LHsSigWcType GhcRn, NameSet)
 -> RnM (LHsSigWcType GhcRn, NameSet))
-> RnM (LHsSigWcType GhcRn, NameSet)
-> RnM (LHsSigWcType GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$
              HsSigWcTypeScoping
-> HsDocContext
-> LHsSigWcType GhcPs
-> RnM (LHsSigWcType GhcRn, NameSet)
rnHsSigWcType HsSigWcTypeScoping
BindUnlessForall HsDocContext
DerivDeclCtx LHsSigWcType GhcPs
ty
       ; Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (LDerivStrategy GhcRn)
mds' SrcSpan
loc
       ; (DerivDecl GhcRn, NameSet) -> RnM (DerivDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCDerivDecl GhcRn
-> LHsSigWcType GhcRn
-> Maybe (LDerivStrategy GhcRn)
-> Maybe (Located OverlapMode)
-> DerivDecl GhcRn
forall pass.
XCDerivDecl pass
-> LHsSigWcType pass
-> Maybe (LDerivStrategy pass)
-> Maybe (Located OverlapMode)
-> DerivDecl pass
DerivDecl XCDerivDecl GhcRn
NoExt
noExt LHsSigWcType GhcRn
ty' Maybe (LDerivStrategy GhcRn)
mds' Maybe (Located OverlapMode)
overlap, NameSet
fvs) }
  where
    loc :: SrcSpan
loc = LHsType GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsType GhcPs -> SrcSpan) -> LHsType GhcPs -> SrcSpan
forall a b. (a -> b) -> a -> b
$ LHsSigType GhcPs -> LHsType GhcPs
forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body (LHsSigType GhcPs -> LHsType GhcPs)
-> LHsSigType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ LHsSigWcType GhcPs -> LHsSigType GhcPs
forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsSigWcType GhcPs
ty
rnSrcDerivDecl (XDerivDecl _) = String -> RnM (DerivDecl GhcRn, NameSet)
forall a. String -> a
panic "rnSrcDerivDecl"

standaloneDerivErr :: SDoc
standaloneDerivErr :: SDoc
standaloneDerivErr
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Illegal standalone deriving declaration")
       2 (String -> SDoc
text "Use StandaloneDeriving to enable this extension")

{-
*********************************************************
*                                                      *
\subsection{Rules}
*                                                      *
*********************************************************
-}

rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, NameSet)
rnHsRuleDecls (HsRules { rds_src :: forall pass. RuleDecls pass -> SourceText
rds_src = SourceText
src
                       , rds_rules :: forall pass. RuleDecls pass -> [LRuleDecl pass]
rds_rules = [LRuleDecl GhcPs]
rules })
  = do { (rn_rules :: [Located (RuleDecl GhcRn)]
rn_rules,fvs :: NameSet
fvs) <- (RuleDecl GhcPs -> RnM (RuleDecl GhcRn, NameSet))
-> [LRuleDecl GhcPs] -> RnM ([Located (RuleDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList RuleDecl GhcPs -> RnM (RuleDecl GhcRn, NameSet)
rnHsRuleDecl [LRuleDecl GhcPs]
rules
       ; (RuleDecls GhcRn, NameSet) -> RnM (RuleDecls GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsRules :: forall pass.
XCRuleDecls pass
-> SourceText -> [LRuleDecl pass] -> RuleDecls pass
HsRules { rds_ext :: XCRuleDecls GhcRn
rds_ext = XCRuleDecls GhcRn
NoExt
noExt
                         , rds_src :: SourceText
rds_src = SourceText
src
                         , rds_rules :: [Located (RuleDecl GhcRn)]
rds_rules = [Located (RuleDecl GhcRn)]
rn_rules }, NameSet
fvs) }
rnHsRuleDecls (XRuleDecls _) = String -> RnM (RuleDecls GhcRn, NameSet)
forall a. String -> a
panic "rnHsRuleDecls"

rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, NameSet)
rnHsRuleDecl (HsRule { rd_name :: forall pass. RuleDecl pass -> Located (SourceText, CLabelString)
rd_name = Located (SourceText, CLabelString)
rule_name
                     , rd_act :: forall pass. RuleDecl pass -> Activation
rd_act  = Activation
act
                     , rd_tyvs :: forall pass. RuleDecl pass -> Maybe [LHsTyVarBndr (NoGhcTc pass)]
rd_tyvs = Maybe [LHsTyVarBndr (NoGhcTc GhcPs)]
tyvs
                     , rd_tmvs :: forall pass. RuleDecl pass -> [LRuleBndr pass]
rd_tmvs = [LRuleBndr GhcPs]
tmvs
                     , rd_lhs :: forall pass. RuleDecl pass -> Located (HsExpr pass)
rd_lhs  = Located (HsExpr GhcPs)
lhs
                     , rd_rhs :: forall pass. RuleDecl pass -> Located (HsExpr pass)
rd_rhs  = Located (HsExpr GhcPs)
rhs })
  = do { let rdr_names_w_loc :: [GenLocated SrcSpan RdrName]
rdr_names_w_loc = (LRuleBndr GhcPs -> GenLocated SrcSpan RdrName)
-> [LRuleBndr GhcPs] -> [GenLocated SrcSpan RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (RuleBndr GhcPs -> GenLocated SrcSpan RdrName
forall pass. RuleBndr pass -> Located (IdP pass)
get_var (RuleBndr GhcPs -> GenLocated SrcSpan RdrName)
-> (LRuleBndr GhcPs -> RuleBndr GhcPs)
-> LRuleBndr GhcPs
-> GenLocated SrcSpan RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LRuleBndr GhcPs -> RuleBndr GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LRuleBndr GhcPs]
tmvs
       ; [GenLocated SrcSpan RdrName] -> TcRn ()
checkDupRdrNames [GenLocated SrcSpan RdrName]
rdr_names_w_loc
       ; [GenLocated SrcSpan RdrName] -> TcRn ()
checkShadowedRdrNames [GenLocated SrcSpan RdrName]
rdr_names_w_loc
       ; [Name]
names <- [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Name]
newLocalBndrsRn [GenLocated SrcSpan RdrName]
rdr_names_w_loc
       ; let doc :: HsDocContext
doc = CLabelString -> HsDocContext
RuleCtx ((SourceText, CLabelString) -> CLabelString
forall a b. (a, b) -> b
snd ((SourceText, CLabelString) -> CLabelString)
-> (SourceText, CLabelString) -> CLabelString
forall a b. (a -> b) -> a -> b
$ Located (SourceText, CLabelString)
-> SrcSpanLess (Located (SourceText, CLabelString))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (SourceText, CLabelString)
rule_name)
       ; HsDocContext
-> SDoc
-> Maybe [LHsTyVarBndr GhcPs]
-> (Maybe [LHsTyVarBndr GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
-> RnM (RuleDecl GhcRn, NameSet)
forall b.
HsDocContext
-> SDoc
-> Maybe [LHsTyVarBndr GhcPs]
-> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindRuleTyVars HsDocContext
doc SDoc
in_rule Maybe [LHsTyVarBndr (NoGhcTc GhcPs)]
Maybe [LHsTyVarBndr GhcPs]
tyvs ((Maybe [LHsTyVarBndr GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
 -> RnM (RuleDecl GhcRn, NameSet))
-> (Maybe [LHsTyVarBndr GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
-> RnM (RuleDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ tyvs' :: Maybe [LHsTyVarBndr GhcRn]
tyvs' ->
         HsDocContext
-> Maybe [LHsTyVarBndr GhcRn]
-> [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
-> RnM (RuleDecl GhcRn, NameSet)
forall ty_bndrs a.
HsDocContext
-> Maybe ty_bndrs
-> [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, NameSet))
-> RnM (a, NameSet)
bindRuleTmVars HsDocContext
doc Maybe [LHsTyVarBndr GhcRn]
tyvs' [LRuleBndr GhcPs]
tmvs [Name]
names (([LRuleBndr GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
 -> RnM (RuleDecl GhcRn, NameSet))
-> ([LRuleBndr GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
-> RnM (RuleDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ tmvs' :: [LRuleBndr GhcRn]
tmvs' ->
    do { (lhs' :: LHsExpr GhcRn
lhs', fv_lhs' :: NameSet
fv_lhs') <- Located (HsExpr GhcPs) -> TcM (LHsExpr GhcRn, NameSet)
rnLExpr Located (HsExpr GhcPs)
lhs
       ; (rhs' :: LHsExpr GhcRn
rhs', fv_rhs' :: NameSet
fv_rhs') <- Located (HsExpr GhcPs) -> TcM (LHsExpr GhcRn, NameSet)
rnLExpr Located (HsExpr GhcPs)
rhs
       ; CLabelString -> [Name] -> LHsExpr GhcRn -> NameSet -> TcRn ()
checkValidRule ((SourceText, CLabelString) -> CLabelString
forall a b. (a, b) -> b
snd ((SourceText, CLabelString) -> CLabelString)
-> (SourceText, CLabelString) -> CLabelString
forall a b. (a -> b) -> a -> b
$ Located (SourceText, CLabelString)
-> SrcSpanLess (Located (SourceText, CLabelString))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (SourceText, CLabelString)
rule_name) [Name]
names LHsExpr GhcRn
lhs' NameSet
fv_lhs'
       ; (RuleDecl GhcRn, NameSet) -> RnM (RuleDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsRule :: forall pass.
XHsRule pass
-> Located (SourceText, CLabelString)
-> Activation
-> Maybe [LHsTyVarBndr (NoGhcTc pass)]
-> [LRuleBndr pass]
-> Located (HsExpr pass)
-> Located (HsExpr pass)
-> RuleDecl pass
HsRule { rd_ext :: XHsRule GhcRn
rd_ext  = NameSet -> NameSet -> HsRuleRn
HsRuleRn NameSet
fv_lhs' NameSet
fv_rhs'
                        , rd_name :: Located (SourceText, CLabelString)
rd_name = Located (SourceText, CLabelString)
rule_name
                        , rd_act :: Activation
rd_act  = Activation
act
                        , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc GhcRn)]
rd_tyvs = Maybe [LHsTyVarBndr (NoGhcTc GhcRn)]
Maybe [LHsTyVarBndr GhcRn]
tyvs'
                        , rd_tmvs :: [LRuleBndr GhcRn]
rd_tmvs = [LRuleBndr GhcRn]
tmvs'
                        , rd_lhs :: LHsExpr GhcRn
rd_lhs  = LHsExpr GhcRn
lhs'
                        , rd_rhs :: LHsExpr GhcRn
rd_rhs  = LHsExpr GhcRn
rhs' }, NameSet
fv_lhs' NameSet -> NameSet -> NameSet
`plusFV` NameSet
fv_rhs') } }
  where
    get_var :: RuleBndr pass -> Located (IdP pass)
get_var (RuleBndrSig _ v :: Located (IdP pass)
v _) = Located (IdP pass)
v
    get_var (RuleBndr _ v :: Located (IdP pass)
v)      = Located (IdP pass)
v
    get_var (XRuleBndr _)       = String -> Located (IdP pass)
forall a. String -> a
panic "rnHsRuleDecl"
    in_rule :: SDoc
in_rule = String -> SDoc
text "in the rule" SDoc -> SDoc -> SDoc
<+> Located (SourceText, CLabelString) -> SDoc
pprFullRuleName Located (SourceText, CLabelString)
rule_name
rnHsRuleDecl (XRuleDecl _) = String -> RnM (RuleDecl GhcRn, NameSet)
forall a. String -> a
panic "rnHsRuleDecl"

bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
               -> [LRuleBndr GhcPs] -> [Name]
               -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
               -> RnM (a, FreeVars)
bindRuleTmVars :: HsDocContext
-> Maybe ty_bndrs
-> [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, NameSet))
-> RnM (a, NameSet)
bindRuleTmVars doc :: HsDocContext
doc tyvs :: Maybe ty_bndrs
tyvs vars :: [LRuleBndr GhcPs]
vars names :: [Name]
names thing_inside :: [LRuleBndr GhcRn] -> RnM (a, NameSet)
thing_inside
  = [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, NameSet))
-> RnM (a, NameSet)
go [LRuleBndr GhcPs]
vars [Name]
names (([LRuleBndr GhcRn] -> RnM (a, NameSet)) -> RnM (a, NameSet))
-> ([LRuleBndr GhcRn] -> RnM (a, NameSet)) -> RnM (a, NameSet)
forall a b. (a -> b) -> a -> b
$ \ vars' :: [LRuleBndr GhcRn]
vars' ->
    [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
bindLocalNamesFV [Name]
names ([LRuleBndr GhcRn] -> RnM (a, NameSet)
thing_inside [LRuleBndr GhcRn]
vars')
  where
    go :: [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, NameSet))
-> RnM (a, NameSet)
go ((LRuleBndr GhcPs -> Located (SrcSpanLess (LRuleBndr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (RuleBndr _ (dL->L loc _))) : vars :: [LRuleBndr GhcPs]
vars) (n :: Name
n : ns :: [Name]
ns) thing_inside :: [LRuleBndr GhcRn] -> RnM (a, NameSet)
thing_inside
      = [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, NameSet))
-> RnM (a, NameSet)
go [LRuleBndr GhcPs]
vars [Name]
ns (([LRuleBndr GhcRn] -> RnM (a, NameSet)) -> RnM (a, NameSet))
-> ([LRuleBndr GhcRn] -> RnM (a, NameSet)) -> RnM (a, NameSet)
forall a b. (a -> b) -> a -> b
$ \ vars' :: [LRuleBndr GhcRn]
vars' ->
        [LRuleBndr GhcRn] -> RnM (a, NameSet)
thing_inside (SrcSpan -> SrcSpanLess (LRuleBndr GhcRn) -> LRuleBndr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XCRuleBndr GhcRn -> Located (IdP GhcRn) -> RuleBndr GhcRn
forall pass. XCRuleBndr pass -> Located (IdP pass) -> RuleBndr pass
RuleBndr XCRuleBndr GhcRn
NoExt
noExt (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc Name
SrcSpanLess (Located Name)
n)) LRuleBndr GhcRn -> [LRuleBndr GhcRn] -> [LRuleBndr GhcRn]
forall a. a -> [a] -> [a]
: [LRuleBndr GhcRn]
vars')

    go ((LRuleBndr GhcPs -> Located (SrcSpanLess (LRuleBndr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (RuleBndrSig _ (dL->L loc _) bsig)) : vars :: [LRuleBndr GhcPs]
vars)
       (n :: Name
n : ns :: [Name]
ns) thing_inside :: [LRuleBndr GhcRn] -> RnM (a, NameSet)
thing_inside
      = HsSigWcTypeScoping
-> HsDocContext
-> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, NameSet))
-> RnM (a, NameSet)
forall a.
HsSigWcTypeScoping
-> HsDocContext
-> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, NameSet))
-> RnM (a, NameSet)
rnHsSigWcTypeScoped HsSigWcTypeScoping
bind_free_tvs HsDocContext
doc LHsSigWcType GhcPs
bsig ((LHsSigWcType GhcRn -> RnM (a, NameSet)) -> RnM (a, NameSet))
-> (LHsSigWcType GhcRn -> RnM (a, NameSet)) -> RnM (a, NameSet)
forall a b. (a -> b) -> a -> b
$ \ bsig' :: LHsSigWcType GhcRn
bsig' ->
        [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, NameSet))
-> RnM (a, NameSet)
go [LRuleBndr GhcPs]
vars [Name]
ns (([LRuleBndr GhcRn] -> RnM (a, NameSet)) -> RnM (a, NameSet))
-> ([LRuleBndr GhcRn] -> RnM (a, NameSet)) -> RnM (a, NameSet)
forall a b. (a -> b) -> a -> b
$ \ vars' :: [LRuleBndr GhcRn]
vars' ->
        [LRuleBndr GhcRn] -> RnM (a, NameSet)
thing_inside (SrcSpan -> SrcSpanLess (LRuleBndr GhcRn) -> LRuleBndr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XRuleBndrSig GhcRn
-> Located (IdP GhcRn) -> LHsSigWcType GhcRn -> RuleBndr GhcRn
forall pass.
XRuleBndrSig pass
-> Located (IdP pass) -> LHsSigWcType pass -> RuleBndr pass
RuleBndrSig XRuleBndrSig GhcRn
NoExt
noExt (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc Name
SrcSpanLess (Located Name)
n) LHsSigWcType GhcRn
bsig') LRuleBndr GhcRn -> [LRuleBndr GhcRn] -> [LRuleBndr GhcRn]
forall a. a -> [a] -> [a]
: [LRuleBndr GhcRn]
vars')

    go [] [] thing_inside :: [LRuleBndr GhcRn] -> RnM (a, NameSet)
thing_inside = [LRuleBndr GhcRn] -> RnM (a, NameSet)
thing_inside []
    go vars :: [LRuleBndr GhcPs]
vars names :: [Name]
names _ = String -> SDoc -> RnM (a, NameSet)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "bindRuleVars" ([LRuleBndr GhcPs] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LRuleBndr GhcPs]
vars SDoc -> SDoc -> SDoc
$$ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
names)

    bind_free_tvs :: HsSigWcTypeScoping
bind_free_tvs = case Maybe ty_bndrs
tyvs of Nothing -> HsSigWcTypeScoping
AlwaysBind
                                 Just _  -> HsSigWcTypeScoping
NeverBind

bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs]
               -> (Maybe [LHsTyVarBndr GhcRn]  -> RnM (b, FreeVars))
               -> RnM (b, FreeVars)
bindRuleTyVars :: HsDocContext
-> SDoc
-> Maybe [LHsTyVarBndr GhcPs]
-> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindRuleTyVars doc :: HsDocContext
doc in_doc :: SDoc
in_doc (Just bndrs :: [LHsTyVarBndr GhcPs]
bndrs) thing_inside :: Maybe [LHsTyVarBndr GhcRn] -> RnM (b, NameSet)
thing_inside
  = HsDocContext
-> Maybe SDoc
-> Maybe Any
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
forall a b.
HsDocContext
-> Maybe SDoc
-> Maybe a
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindLHsTyVarBndrs HsDocContext
doc (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
in_doc) Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr GhcPs]
bndrs (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, NameSet)
thing_inside (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, NameSet))
-> ([LHsTyVarBndr GhcRn] -> Maybe [LHsTyVarBndr GhcRn])
-> [LHsTyVarBndr GhcRn]
-> RnM (b, NameSet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LHsTyVarBndr GhcRn] -> Maybe [LHsTyVarBndr GhcRn]
forall a. a -> Maybe a
Just)
bindRuleTyVars _ _ _ thing_inside :: Maybe [LHsTyVarBndr GhcRn] -> RnM (b, NameSet)
thing_inside = Maybe [LHsTyVarBndr GhcRn] -> RnM (b, NameSet)
thing_inside Maybe [LHsTyVarBndr GhcRn]
forall a. Maybe a
Nothing

{-
Note [Rule LHS validity checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Check the shape of a transformation rule LHS.  Currently we only allow
LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
@forall@'d variables.

We used restrict the form of the 'ei' to prevent you writing rules
with LHSs with a complicated desugaring (and hence unlikely to match);
(e.g. a case expression is not allowed: too elaborate.)

But there are legitimate non-trivial args ei, like sections and
lambdas.  So it seems simmpler not to check at all, and that is why
check_e is commented out.
-}

checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
checkValidRule :: CLabelString -> [Name] -> LHsExpr GhcRn -> NameSet -> TcRn ()
checkValidRule rule_name :: CLabelString
rule_name ids :: [Name]
ids lhs' :: LHsExpr GhcRn
lhs' fv_lhs' :: NameSet
fv_lhs'
  = do  {       -- Check for the form of the LHS
          case ([Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
validRuleLhs [Name]
ids LHsExpr GhcRn
lhs') of
                Nothing  -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just bad :: HsExpr GhcRn
bad -> SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc (CLabelString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
badRuleLhsErr CLabelString
rule_name LHsExpr GhcRn
lhs' HsExpr GhcRn
bad)

                -- Check that LHS vars are all bound
        ; let bad_vars :: [Name]
bad_vars = [Name
var | Name
var <- [Name]
ids, Bool -> Bool
not (Name
var Name -> NameSet -> Bool
`elemNameSet` NameSet
fv_lhs')]
        ; (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> TcRn ()
addErr (SDoc -> TcRn ()) -> (Name -> SDoc) -> Name -> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLabelString -> Name -> SDoc
badRuleVar CLabelString
rule_name) [Name]
bad_vars }

validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
-- Nothing => OK
-- Just e  => Not ok, and e is the offending sub-expression
validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
validRuleLhs foralls :: [Name]
foralls lhs :: LHsExpr GhcRn
lhs
  = LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
lhs
  where
    checkl :: LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
checkl = HsExpr GhcRn -> Maybe (HsExpr GhcRn)
check (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> (LHsExpr GhcRn -> HsExpr GhcRn)
-> LHsExpr GhcRn
-> Maybe (HsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcRn -> HsExpr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc

    check :: HsExpr GhcRn -> Maybe (HsExpr GhcRn)
check (OpApp _ e1 :: LHsExpr GhcRn
e1 op :: LHsExpr GhcRn
op e2 :: LHsExpr GhcRn
e2)              = LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
op Maybe (HsExpr GhcRn)
-> Maybe (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall p a. p -> Maybe a
checkl_e LHsExpr GhcRn
e1
                                                      Maybe (HsExpr GhcRn)
-> Maybe (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall p a. p -> Maybe a
checkl_e LHsExpr GhcRn
e2
    check (HsApp _ e1 :: LHsExpr GhcRn
e1 e2 :: LHsExpr GhcRn
e2)                 = LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
e1 Maybe (HsExpr GhcRn)
-> Maybe (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall p a. p -> Maybe a
checkl_e LHsExpr GhcRn
e2
    check (HsAppType _ e :: LHsExpr GhcRn
e _)               = LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
e
    check (HsVar _ lv :: Located (IdP GhcRn)
lv)
      | (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
Located (IdP GhcRn)
lv) Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
foralls      = Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing
    check other :: HsExpr GhcRn
other                           = HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
other  -- Failure

        -- Check an argument
    checkl_e :: p -> Maybe a
checkl_e _ = Maybe a
forall a. Maybe a
Nothing
    -- Was (check_e e); see Note [Rule LHS validity checking]

{-      Commented out; see Note [Rule LHS validity checking] above
    check_e (HsVar v)     = Nothing
    check_e (HsPar e)     = checkl_e e
    check_e (HsLit e)     = Nothing
    check_e (HsOverLit e) = Nothing

    check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
    check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
    check_e (NegApp e _)         = checkl_e e
    check_e (ExplicitList _ es)  = checkl_es es
    check_e other                = Just other   -- Fails

    checkl_es es = foldr (mplus . checkl_e) Nothing es
-}

badRuleVar :: FastString -> Name -> SDoc
badRuleVar :: CLabelString -> Name -> SDoc
badRuleVar name :: CLabelString
name var :: Name
var
  = [SDoc] -> SDoc
sep [String -> SDoc
text "Rule" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (CLabelString -> SDoc
ftext CLabelString
name) SDoc -> SDoc -> SDoc
<> SDoc
colon,
         String -> SDoc
text "Forall'd variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
var) SDoc -> SDoc -> SDoc
<+>
                String -> SDoc
text "does not appear on left hand side"]

badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
badRuleLhsErr :: CLabelString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
badRuleLhsErr name :: CLabelString
name lhs :: LHsExpr GhcRn
lhs bad_e :: HsExpr GhcRn
bad_e
  = [SDoc] -> SDoc
sep [String -> SDoc
text "Rule" SDoc -> SDoc -> SDoc
<+> CLabelString -> SDoc
pprRuleName CLabelString
name SDoc -> SDoc -> SDoc
<> SDoc
colon,
         Int -> SDoc -> SDoc
nest 2 ([SDoc] -> SDoc
vcat [SDoc
err,
                       String -> SDoc
text "in left-hand side:" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
lhs])]
    SDoc -> SDoc -> SDoc
$$
    String -> SDoc
text "LHS must be of form (f e1 .. en) where f is not forall'd"
  where
    err :: SDoc
err = case HsExpr GhcRn
bad_e of
            HsUnboundVar _ uv :: UnboundVar
uv -> RdrName -> SDoc
notInScopeErr (OccName -> RdrName
mkRdrUnqual (UnboundVar -> OccName
unboundVarOcc UnboundVar
uv))
            _                 -> String -> SDoc
text "Illegal expression:" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
bad_e

{- **************************************************************
         *                                                      *
      Renaming type, class, instance and role declarations
*                                                               *
*****************************************************************

@rnTyDecl@ uses the `global name function' to create a new type
declaration in which local names have been replaced by their original
names, reporting any unknown names.

Renaming type variables is a pain. Because they now contain uniques,
it is necessary to pass in an association list which maps a parsed
tyvar to its @Name@ representation.
In some cases (type signatures of values),
it is even necessary to go over the type first
in order to get the set of tyvars used by it, make an assoc list,
and then go over it again to rename the tyvars!
However, we can also do some scoping checks at the same time.

Note [Dependency analysis of type, class, and instance decls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A TyClGroup represents a strongly connected components of
type/class/instance decls, together with the role annotations for the
type/class declarations.  The renamer uses strongly connected
comoponent analysis to build these groups.  We do this for a number of
reasons:

* Improve kind error messages. Consider

     data T f a = MkT f a
     data S f a = MkS f (T f a)

  This has a kind error, but the error message is better if you
  check T first, (fixing its kind) and *then* S.  If you do kind
  inference together, you might get an error reported in S, which
  is jolly confusing.  See Trac #4875


* Increase kind polymorphism.  See TcTyClsDecls
  Note [Grouping of type and class declarations]

Why do the instance declarations participate?  At least two reasons

* Consider (Trac #11348)

     type family F a
     type instance F Int = Bool

     data R = MkR (F Int)

     type Foo = 'MkR 'True

  For Foo to kind-check we need to know that (F Int) ~ Bool.  But we won't
  know that unless we've looked at the type instance declaration for F
  before kind-checking Foo.

* Another example is this (Trac #3990).

     data family Complex a
     data instance Complex Double = CD {-# UNPACK #-} !Double
                                       {-# UNPACK #-} !Double

     data T = T {-# UNPACK #-} !(Complex Double)

  Here, to generate the right kind of unpacked implementation for T,
  we must have access to the 'data instance' declaration.

* Things become more complicated when we introduce transitive
  dependencies through imported definitions, like in this scenario:

      A.hs
        type family Closed (t :: Type) :: Type where
          Closed t = Open t

        type family Open (t :: Type) :: Type

      B.hs
        data Q where
          Q :: Closed Bool -> Q

        type instance Open Int = Bool

        type S = 'Q 'True

  Somehow, we must ensure that the instance Open Int = Bool is checked before
  the type synonym S. While we know that S depends upon 'Q depends upon Closed,
  we have no idea that Closed depends upon Open!

  To accomodate for these situations, we ensure that an instance is checked
  before every @TyClDecl@ on which it does not depend. That's to say, instances
  are checked as early as possible in @tcTyAndClassDecls@.

------------------------------------
So much for WHY.  What about HOW?  It's pretty easy:

(1) Rename the type/class, instance, and role declarations
    individually

(2) Do strongly-connected component analysis of the type/class decls,
    We'll make a TyClGroup for each SCC

    In this step we treat a reference to a (promoted) data constructor
    K as a dependency on its parent type.  Thus
        data T = K1 | K2
        data S = MkS (Proxy 'K1)
    Here S depends on 'K1 and hence on its parent T.

    In this step we ignore instances; see
    Note [No dependencies on data instances]

(3) Attach roles to the appropriate SCC

(4) Attach instances to the appropriate SCC.
    We add an instance decl to SCC when:
      all its free types/classes are bound in this SCC or earlier ones

(5) We make an initial TyClGroup, with empty group_tyclds, for any
    (orphan) instances that affect only imported types/classes

Steps (3) and (4) are done by the (mapAccumL mk_group) call.

Note [No dependencies on data instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
   data family D a
   data instance D Int = D1
   data S = MkS (Proxy 'D1)

Here the declaration of S depends on the /data instance/ declaration
for 'D Int'.  That makes things a lot more complicated, especially
if the data instance is an associated type of an enclosing class instance.
(And the class instance might have several associated type instances
with different dependency structure!)

Ugh.  For now we simply don't allow promotion of data constructors for
data instances.  See Note [AFamDataCon: not promoting data family
constructors] in TcEnv
-}


rnTyClDecls :: [TyClGroup GhcPs]
            -> RnM ([TyClGroup GhcRn], FreeVars)
-- Rename the declarations and do dependency analysis on them
rnTyClDecls :: [TyClGroup GhcPs] -> RnM ([TyClGroup GhcRn], NameSet)
rnTyClDecls tycl_ds :: [TyClGroup GhcPs]
tycl_ds
  = do { -- Rename the type/class, instance, and role declaraations
         [(LTyClDecl GhcRn, NameSet)]
tycls_w_fvs <- (LTyClDecl GhcPs
 -> IOEnv (Env TcGblEnv TcLclEnv) (LTyClDecl GhcRn, NameSet))
-> [LTyClDecl GhcPs]
-> IOEnv (Env TcGblEnv TcLclEnv) [(LTyClDecl GhcRn, NameSet)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LTyClDecl GhcPs)
 -> TcM (SrcSpanLess (LTyClDecl GhcRn), NameSet))
-> LTyClDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (LTyClDecl GhcRn, NameSet)
forall a b c.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b, c)) -> a -> TcM (b, c)
wrapLocFstM SrcSpanLess (LTyClDecl GhcPs)
-> TcM (SrcSpanLess (LTyClDecl GhcRn), NameSet)
TyClDecl GhcPs -> RnM (TyClDecl GhcRn, NameSet)
rnTyClDecl)
                             ([TyClGroup GhcPs] -> [LTyClDecl GhcPs]
forall pass. [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls [TyClGroup GhcPs]
tycl_ds)
       ; let tc_names :: NameSet
tc_names = [Name] -> NameSet
mkNameSet (((LTyClDecl GhcRn, NameSet) -> Name)
-> [(LTyClDecl GhcRn, NameSet)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyClDecl GhcRn -> Name
forall pass. TyClDecl pass -> IdP pass
tcdName (TyClDecl GhcRn -> Name)
-> ((LTyClDecl GhcRn, NameSet) -> TyClDecl GhcRn)
-> (LTyClDecl GhcRn, NameSet)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTyClDecl GhcRn -> TyClDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LTyClDecl GhcRn -> TyClDecl GhcRn)
-> ((LTyClDecl GhcRn, NameSet) -> LTyClDecl GhcRn)
-> (LTyClDecl GhcRn, NameSet)
-> TyClDecl GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LTyClDecl GhcRn, NameSet) -> LTyClDecl GhcRn
forall a b. (a, b) -> a
fst) [(LTyClDecl GhcRn, NameSet)]
tycls_w_fvs)

       ; [(LInstDecl GhcRn, NameSet)]
instds_w_fvs <- (LInstDecl GhcPs
 -> IOEnv (Env TcGblEnv TcLclEnv) (LInstDecl GhcRn, NameSet))
-> [LInstDecl GhcPs]
-> IOEnv (Env TcGblEnv TcLclEnv) [(LInstDecl GhcRn, NameSet)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LInstDecl GhcPs)
 -> TcM (SrcSpanLess (LInstDecl GhcRn), NameSet))
-> LInstDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (LInstDecl GhcRn, NameSet)
forall a b c.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b, c)) -> a -> TcM (b, c)
wrapLocFstM SrcSpanLess (LInstDecl GhcPs)
-> TcM (SrcSpanLess (LInstDecl GhcRn), NameSet)
InstDecl GhcPs -> RnM (InstDecl GhcRn, NameSet)
rnSrcInstDecl) ([TyClGroup GhcPs] -> [LInstDecl GhcPs]
forall pass. [TyClGroup pass] -> [LInstDecl pass]
tyClGroupInstDecls [TyClGroup GhcPs]
tycl_ds)
       ; [LRoleAnnotDecl GhcRn]
role_annots  <- NameSet -> [LRoleAnnotDecl GhcPs] -> RnM [LRoleAnnotDecl GhcRn]
rnRoleAnnots NameSet
tc_names ([TyClGroup GhcPs] -> [LRoleAnnotDecl GhcPs]
forall pass. [TyClGroup pass] -> [LRoleAnnotDecl pass]
tyClGroupRoleDecls [TyClGroup GhcPs]
tycl_ds)

       -- Do SCC analysis on the type/class decls
       ; GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; let tycl_sccs :: [SCC (LTyClDecl GhcRn)]
tycl_sccs = GlobalRdrEnv
-> [(LTyClDecl GhcRn, NameSet)] -> [SCC (LTyClDecl GhcRn)]
depAnalTyClDecls GlobalRdrEnv
rdr_env [(LTyClDecl GhcRn, NameSet)]
tycls_w_fvs
             role_annot_env :: RoleAnnotEnv
role_annot_env = [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv
mkRoleAnnotEnv [LRoleAnnotDecl GhcRn]
role_annots

             inst_ds_map :: [(LInstDecl GhcRn, NameSet)]
inst_ds_map = GlobalRdrEnv
-> NameSet
-> [(LInstDecl GhcRn, NameSet)]
-> [(LInstDecl GhcRn, NameSet)]
mkInstDeclFreeVarsMap GlobalRdrEnv
rdr_env NameSet
tc_names [(LInstDecl GhcRn, NameSet)]
instds_w_fvs
             (init_inst_ds :: [LInstDecl GhcRn]
init_inst_ds, rest_inst_ds :: [(LInstDecl GhcRn, NameSet)]
rest_inst_ds) = [Name]
-> [(LInstDecl GhcRn, NameSet)]
-> ([LInstDecl GhcRn], [(LInstDecl GhcRn, NameSet)])
getInsts [] [(LInstDecl GhcRn, NameSet)]
inst_ds_map

             first_group :: [TyClGroup GhcRn]
first_group
               | [LInstDecl GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LInstDecl GhcRn]
init_inst_ds = []
               | Bool
otherwise = [TyClGroup :: forall pass.
XCTyClGroup pass
-> [LTyClDecl pass]
-> [LRoleAnnotDecl pass]
-> [LInstDecl pass]
-> TyClGroup pass
TyClGroup { group_ext :: XCTyClGroup GhcRn
group_ext    = XCTyClGroup GhcRn
NoExt
noExt
                                        , group_tyclds :: [LTyClDecl GhcRn]
group_tyclds = []
                                        , group_roles :: [LRoleAnnotDecl GhcRn]
group_roles  = []
                                        , group_instds :: [LInstDecl GhcRn]
group_instds = [LInstDecl GhcRn]
init_inst_ds }]

             ((final_inst_ds :: [(LInstDecl GhcRn, NameSet)]
final_inst_ds, orphan_roles :: RoleAnnotEnv
orphan_roles), groups :: [TyClGroup GhcRn]
groups)
                = (([(LInstDecl GhcRn, NameSet)], RoleAnnotEnv)
 -> SCC (LTyClDecl GhcRn)
 -> (([(LInstDecl GhcRn, NameSet)], RoleAnnotEnv), TyClGroup GhcRn))
-> ([(LInstDecl GhcRn, NameSet)], RoleAnnotEnv)
-> [SCC (LTyClDecl GhcRn)]
-> (([(LInstDecl GhcRn, NameSet)], RoleAnnotEnv),
    [TyClGroup GhcRn])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL ([(LInstDecl GhcRn, NameSet)], RoleAnnotEnv)
-> SCC (LTyClDecl GhcRn)
-> (([(LInstDecl GhcRn, NameSet)], RoleAnnotEnv), TyClGroup GhcRn)
mk_group ([(LInstDecl GhcRn, NameSet)]
rest_inst_ds, RoleAnnotEnv
role_annot_env) [SCC (LTyClDecl GhcRn)]
tycl_sccs


             all_fvs :: NameSet
all_fvs = NameSet -> NameSet -> NameSet
plusFV (((LTyClDecl GhcRn, NameSet) -> NameSet -> NameSet)
-> NameSet -> [(LTyClDecl GhcRn, NameSet)] -> NameSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameSet -> NameSet -> NameSet
plusFV (NameSet -> NameSet -> NameSet)
-> ((LTyClDecl GhcRn, NameSet) -> NameSet)
-> (LTyClDecl GhcRn, NameSet)
-> NameSet
-> NameSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LTyClDecl GhcRn, NameSet) -> NameSet
forall a b. (a, b) -> b
snd) NameSet
emptyFVs [(LTyClDecl GhcRn, NameSet)]
tycls_w_fvs)
                              (((LInstDecl GhcRn, NameSet) -> NameSet -> NameSet)
-> NameSet -> [(LInstDecl GhcRn, NameSet)] -> NameSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameSet -> NameSet -> NameSet
plusFV (NameSet -> NameSet -> NameSet)
-> ((LInstDecl GhcRn, NameSet) -> NameSet)
-> (LInstDecl GhcRn, NameSet)
-> NameSet
-> NameSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LInstDecl GhcRn, NameSet) -> NameSet
forall a b. (a, b) -> b
snd) NameSet
emptyFVs [(LInstDecl GhcRn, NameSet)]
instds_w_fvs)

             all_groups :: [TyClGroup GhcRn]
all_groups = [TyClGroup GhcRn]
first_group [TyClGroup GhcRn] -> [TyClGroup GhcRn] -> [TyClGroup GhcRn]
forall a. [a] -> [a] -> [a]
++ [TyClGroup GhcRn]
groups

       ; ASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map
                                       $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )
         (LRoleAnnotDecl GhcRn -> TcRn ())
-> [LRoleAnnotDecl GhcRn] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LRoleAnnotDecl GhcRn -> TcRn ()
orphanRoleAnnotErr (RoleAnnotEnv -> [LRoleAnnotDecl GhcRn]
forall a. NameEnv a -> [a]
nameEnvElts RoleAnnotEnv
orphan_roles)

       ; String -> SDoc -> TcRn ()
traceRn "rnTycl dependency analysis made groups" ([TyClGroup GhcRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyClGroup GhcRn]
all_groups)
       ; ([TyClGroup GhcRn], NameSet) -> RnM ([TyClGroup GhcRn], NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyClGroup GhcRn]
all_groups, NameSet
all_fvs) }
  where
    mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)
             -> SCC (LTyClDecl GhcRn)
             -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)
                , TyClGroup GhcRn )
    mk_group :: ([(LInstDecl GhcRn, NameSet)], RoleAnnotEnv)
-> SCC (LTyClDecl GhcRn)
-> (([(LInstDecl GhcRn, NameSet)], RoleAnnotEnv), TyClGroup GhcRn)
mk_group (inst_map :: [(LInstDecl GhcRn, NameSet)]
inst_map, role_env :: RoleAnnotEnv
role_env) scc :: SCC (LTyClDecl GhcRn)
scc
      = (([(LInstDecl GhcRn, NameSet)]
inst_map', RoleAnnotEnv
role_env'), TyClGroup GhcRn
group)
      where
        tycl_ds :: [LTyClDecl GhcRn]
tycl_ds              = SCC (LTyClDecl GhcRn) -> [LTyClDecl GhcRn]
forall vertex. SCC vertex -> [vertex]
flattenSCC SCC (LTyClDecl GhcRn)
scc
        bndrs :: [Name]
bndrs                = (LTyClDecl GhcRn -> Name) -> [LTyClDecl GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyClDecl GhcRn -> Name
forall pass. TyClDecl pass -> IdP pass
tcdName (TyClDecl GhcRn -> Name)
-> (LTyClDecl GhcRn -> TyClDecl GhcRn) -> LTyClDecl GhcRn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTyClDecl GhcRn -> TyClDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LTyClDecl GhcRn]
tycl_ds
        (inst_ds :: [LInstDecl GhcRn]
inst_ds, inst_map' :: [(LInstDecl GhcRn, NameSet)]
inst_map') = [Name]
-> [(LInstDecl GhcRn, NameSet)]
-> ([LInstDecl GhcRn], [(LInstDecl GhcRn, NameSet)])
getInsts      [Name]
bndrs [(LInstDecl GhcRn, NameSet)]
inst_map
        (roles :: [LRoleAnnotDecl GhcRn]
roles,   role_env' :: RoleAnnotEnv
role_env') = [Name] -> RoleAnnotEnv -> ([LRoleAnnotDecl GhcRn], RoleAnnotEnv)
getRoleAnnots [Name]
bndrs RoleAnnotEnv
role_env
        group :: TyClGroup GhcRn
group = TyClGroup :: forall pass.
XCTyClGroup pass
-> [LTyClDecl pass]
-> [LRoleAnnotDecl pass]
-> [LInstDecl pass]
-> TyClGroup pass
TyClGroup { group_ext :: XCTyClGroup GhcRn
group_ext    = XCTyClGroup GhcRn
NoExt
noExt
                          , group_tyclds :: [LTyClDecl GhcRn]
group_tyclds = [LTyClDecl GhcRn]
tycl_ds
                          , group_roles :: [LRoleAnnotDecl GhcRn]
group_roles  = [LRoleAnnotDecl GhcRn]
roles
                          , group_instds :: [LInstDecl GhcRn]
group_instds = [LInstDecl GhcRn]
inst_ds }


depAnalTyClDecls :: GlobalRdrEnv
                 -> [(LTyClDecl GhcRn, FreeVars)]
                 -> [SCC (LTyClDecl GhcRn)]
-- See Note [Dependency analysis of type, class, and instance decls]
depAnalTyClDecls :: GlobalRdrEnv
-> [(LTyClDecl GhcRn, NameSet)] -> [SCC (LTyClDecl GhcRn)]
depAnalTyClDecls rdr_env :: GlobalRdrEnv
rdr_env ds_w_fvs :: [(LTyClDecl GhcRn, NameSet)]
ds_w_fvs
  = [Node Name (LTyClDecl GhcRn)] -> [SCC (LTyClDecl GhcRn)]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Name (LTyClDecl GhcRn)]
edges
  where
    edges :: [ Node Name (LTyClDecl GhcRn) ]
    edges :: [Node Name (LTyClDecl GhcRn)]
edges = [ LTyClDecl GhcRn -> Name -> [Name] -> Node Name (LTyClDecl GhcRn)
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode LTyClDecl GhcRn
d (TyClDecl GhcRn -> IdP GhcRn
forall pass. TyClDecl pass -> IdP pass
tcdName (LTyClDecl GhcRn -> SrcSpanLess (LTyClDecl GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LTyClDecl GhcRn
d)) ((Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (GlobalRdrEnv -> Name -> Name
getParent GlobalRdrEnv
rdr_env) (NameSet -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet NameSet
fvs))
            | (d :: LTyClDecl GhcRn
d, fvs :: NameSet
fvs) <- [(LTyClDecl GhcRn, NameSet)]
ds_w_fvs ]
            -- It's OK to use nonDetEltsUFM here as
            -- stronglyConnCompFromEdgedVertices is still deterministic
            -- even if the edges are in nondeterministic order as explained
            -- in Note [Deterministic SCC] in Digraph.

toParents :: GlobalRdrEnv -> NameSet -> NameSet
toParents :: GlobalRdrEnv -> NameSet -> NameSet
toParents rdr_env :: GlobalRdrEnv
rdr_env ns :: NameSet
ns
  = (Name -> NameSet -> NameSet) -> NameSet -> NameSet -> NameSet
forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetFoldUniqSet Name -> NameSet -> NameSet
add NameSet
emptyNameSet NameSet
ns
  -- It's OK to use nonDetFoldUFM because we immediately forget the
  -- ordering by creating a set
  where
    add :: Name -> NameSet -> NameSet
add n :: Name
n s :: NameSet
s = NameSet -> Name -> NameSet
extendNameSet NameSet
s (GlobalRdrEnv -> Name -> Name
getParent GlobalRdrEnv
rdr_env Name
n)

getParent :: GlobalRdrEnv -> Name -> Name
getParent :: GlobalRdrEnv -> Name -> Name
getParent rdr_env :: GlobalRdrEnv
rdr_env n :: Name
n
  = case GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env Name
n of
      Just gre :: GlobalRdrElt
gre -> case GlobalRdrElt -> Parent
gre_par GlobalRdrElt
gre of
                    ParentIs  { par_is :: Parent -> Name
par_is = Name
p } -> Name
p
                    FldParent { par_is :: Parent -> Name
par_is = Name
p } -> Name
p
                    _                        -> Name
n
      Nothing -> Name
n


{- ******************************************************
*                                                       *
       Role annotations
*                                                       *
****************************************************** -}

-- | Renames role annotations, returning them as the values in a NameEnv
-- and checks for duplicate role annotations.
-- It is quite convenient to do both of these in the same place.
-- See also Note [Role annotations in the renamer]
rnRoleAnnots :: NameSet
             -> [LRoleAnnotDecl GhcPs]
             -> RnM [LRoleAnnotDecl GhcRn]
rnRoleAnnots :: NameSet -> [LRoleAnnotDecl GhcPs] -> RnM [LRoleAnnotDecl GhcRn]
rnRoleAnnots tc_names :: NameSet
tc_names role_annots :: [LRoleAnnotDecl GhcPs]
role_annots
  = do {  -- Check for duplicates *before* renaming, to avoid
          -- lumping together all the unboundNames
         let (no_dups :: [LRoleAnnotDecl GhcPs]
no_dups, dup_annots :: [NonEmpty (LRoleAnnotDecl GhcPs)]
dup_annots) = (LRoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs -> Ordering)
-> [LRoleAnnotDecl GhcPs]
-> ([LRoleAnnotDecl GhcPs], [NonEmpty (LRoleAnnotDecl GhcPs)])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups LRoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs -> Ordering
forall a a pass pass.
(HasSrcSpan a, HasSrcSpan a, Ord (IdP pass),
 SrcSpanLess a ~ RoleAnnotDecl pass,
 SrcSpanLess a ~ RoleAnnotDecl pass, IdP pass ~ IdP pass) =>
a -> a -> Ordering
role_annots_cmp [LRoleAnnotDecl GhcPs]
role_annots
             role_annots_cmp :: a -> a -> Ordering
role_annots_cmp (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ annot1 :: SrcSpanLess a
annot1) (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ annot2 :: SrcSpanLess a
annot2)
               = RoleAnnotDecl pass -> IdP pass
forall pass. RoleAnnotDecl pass -> IdP pass
roleAnnotDeclName SrcSpanLess a
RoleAnnotDecl pass
annot1 IdP pass -> IdP pass -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` RoleAnnotDecl pass -> IdP pass
forall pass. RoleAnnotDecl pass -> IdP pass
roleAnnotDeclName SrcSpanLess a
RoleAnnotDecl pass
annot2
       ; (NonEmpty (LRoleAnnotDecl GhcPs) -> TcRn ())
-> [NonEmpty (LRoleAnnotDecl GhcPs)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (LRoleAnnotDecl GhcPs) -> TcRn ()
dupRoleAnnotErr [NonEmpty (LRoleAnnotDecl GhcPs)]
dup_annots
       ; (LRoleAnnotDecl GhcPs
 -> IOEnv (Env TcGblEnv TcLclEnv) (LRoleAnnotDecl GhcRn))
-> [LRoleAnnotDecl GhcPs] -> RnM [LRoleAnnotDecl GhcRn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LRoleAnnotDecl GhcPs)
 -> TcM (SrcSpanLess (LRoleAnnotDecl GhcRn)))
-> LRoleAnnotDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (LRoleAnnotDecl GhcRn)
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
wrapLocM SrcSpanLess (LRoleAnnotDecl GhcPs)
-> TcM (SrcSpanLess (LRoleAnnotDecl GhcRn))
RoleAnnotDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (RoleAnnotDecl GhcRn)
rn_role_annot1) [LRoleAnnotDecl GhcPs]
no_dups }
  where
    rn_role_annot1 :: RoleAnnotDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (RoleAnnotDecl GhcRn)
rn_role_annot1 (RoleAnnotDecl _ tycon :: Located (IdP GhcPs)
tycon roles :: [Located (Maybe Role)]
roles)
      = do {  -- the name is an *occurrence*, but look it up only in the
              -- decls defined in this group (see #10263)
             Located Name
tycon' <- HsSigCtxt
-> SDoc -> GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupSigCtxtOccRn (NameSet -> HsSigCtxt
RoleAnnotCtxt NameSet
tc_names)
                                          (String -> SDoc
text "role annotation")
                                          GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon
           ; RoleAnnotDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (RoleAnnotDecl GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (RoleAnnotDecl GhcRn
 -> IOEnv (Env TcGblEnv TcLclEnv) (RoleAnnotDecl GhcRn))
-> RoleAnnotDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (RoleAnnotDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ XCRoleAnnotDecl GhcRn
-> Located (IdP GhcRn)
-> [Located (Maybe Role)]
-> RoleAnnotDecl GhcRn
forall pass.
XCRoleAnnotDecl pass
-> Located (IdP pass)
-> [Located (Maybe Role)]
-> RoleAnnotDecl pass
RoleAnnotDecl XCRoleAnnotDecl GhcRn
NoExt
noExt Located Name
Located (IdP GhcRn)
tycon' [Located (Maybe Role)]
roles }
    rn_role_annot1 (XRoleAnnotDecl _) = String -> IOEnv (Env TcGblEnv TcLclEnv) (RoleAnnotDecl GhcRn)
forall a. String -> a
panic "rnRoleAnnots"

dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> TcRn ()
dupRoleAnnotErr list :: NonEmpty (LRoleAnnotDecl GhcPs)
list
  = SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
loc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Duplicate role annotations for" SDoc -> SDoc -> SDoc
<+>
          SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RdrName -> SDoc) -> RdrName -> SDoc
forall a b. (a -> b) -> a -> b
$ RoleAnnotDecl GhcPs -> IdP GhcPs
forall pass. RoleAnnotDecl pass -> IdP pass
roleAnnotDeclName SrcSpanLess (LRoleAnnotDecl GhcPs)
RoleAnnotDecl GhcPs
first_decl) SDoc -> SDoc -> SDoc
<> SDoc
colon)
       2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LRoleAnnotDecl GhcPs -> SDoc) -> [LRoleAnnotDecl GhcPs] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LRoleAnnotDecl GhcPs -> SDoc
forall a. (HasSrcSpan a, Outputable (SrcSpanLess a)) => a -> SDoc
pp_role_annot ([LRoleAnnotDecl GhcPs] -> [SDoc])
-> [LRoleAnnotDecl GhcPs] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ NonEmpty (LRoleAnnotDecl GhcPs) -> [LRoleAnnotDecl GhcPs]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (LRoleAnnotDecl GhcPs)
sorted_list)
    where
      sorted_list :: NonEmpty (LRoleAnnotDecl GhcPs)
sorted_list = (LRoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs -> Ordering)
-> NonEmpty (LRoleAnnotDecl GhcPs)
-> NonEmpty (LRoleAnnotDecl GhcPs)
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy LRoleAnnotDecl GhcPs -> LRoleAnnotDecl GhcPs -> Ordering
forall a a. (HasSrcSpan a, HasSrcSpan a) => a -> a -> Ordering
cmp_annot NonEmpty (LRoleAnnotDecl GhcPs)
list
      ((LRoleAnnotDecl GhcPs
-> Located (SrcSpanLess (LRoleAnnotDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc first_decl :: SrcSpanLess (LRoleAnnotDecl GhcPs)
first_decl) :| _) = NonEmpty (LRoleAnnotDecl GhcPs)
sorted_list

      pp_role_annot :: a -> SDoc
pp_role_annot (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc decl :: SrcSpanLess a
decl) = SDoc -> Int -> SDoc -> SDoc
hang (SrcSpanLess a -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess a
decl)
                                      4 (String -> SDoc
text "-- written at" SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc)

      cmp_annot :: a -> a -> Ordering
cmp_annot (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc1 :: SrcSpan
loc1 _) (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc2 :: SrcSpan
loc2 _) = SrcSpan
loc1 SrcSpan -> SrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` SrcSpan
loc2

orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM ()
orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> TcRn ()
orphanRoleAnnotErr (LRoleAnnotDecl GhcRn
-> Located (SrcSpanLess (LRoleAnnotDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc decl :: SrcSpanLess (LRoleAnnotDecl GhcRn)
decl)
  = SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
loc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Role annotation for a type previously declared:")
       2 (RoleAnnotDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (LRoleAnnotDecl GhcRn)
RoleAnnotDecl GhcRn
decl) SDoc -> SDoc -> SDoc
$$
    SDoc -> SDoc
parens (String -> SDoc
text "The role annotation must be given where" SDoc -> SDoc -> SDoc
<+>
            SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SDoc) -> Name -> SDoc
forall a b. (a -> b) -> a -> b
$ RoleAnnotDecl GhcRn -> IdP GhcRn
forall pass. RoleAnnotDecl pass -> IdP pass
roleAnnotDeclName SrcSpanLess (LRoleAnnotDecl GhcRn)
RoleAnnotDecl GhcRn
decl) SDoc -> SDoc -> SDoc
<+>
            String -> SDoc
text "is declared.")


{- Note [Role annotations in the renamer]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must ensure that a type's role annotation is put in the same group as the
proper type declaration. This is because role annotations are needed during
type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
type, if any. Then, this map can be used to add the role annotations to the
groups after dependency analysis.

This process checks for duplicate role annotations, where we must be careful
to do the check *before* renaming to avoid calling all unbound names duplicates
of one another.

The renaming process, as usual, might identify and report errors for unbound
names. We exclude the annotations for unbound names in the annotation
environment to avoid spurious errors for orphaned annotations.

We then (in rnTyClDecls) do a check for orphan role annotations (role
annotations without an accompanying type decl). The check works by folding
over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting
out the relevant role declarations for each group, as well as diminishing the
annotation environment. After the fold is complete, anything left over in the
name environment must be an orphan, and errors are generated.

An earlier version of this algorithm short-cut the orphan check by renaming
only with names declared in this module. But, this check is insufficient in
the case of staged module compilation (Template Haskell, GHCi).
See #8485. With the new lookup process (which includes types declared in other
modules), we get better error messages, too.
-}


{- ******************************************************
*                                                       *
       Dependency info for instances
*                                                       *
****************************************************** -}

----------------------------------------------------------
-- | 'InstDeclFreeVarsMap is an association of an
--   @InstDecl@ with @FreeVars@. The @FreeVars@ are
--   the tycon names that are both
--     a) free in the instance declaration
--     b) bound by this group of type/class/instance decls
type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]

-- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the
--   @FreeVars@ which are *not* the binders of a @TyClDecl@.
mkInstDeclFreeVarsMap :: GlobalRdrEnv
                      -> NameSet
                      -> [(LInstDecl GhcRn, FreeVars)]
                      -> InstDeclFreeVarsMap
mkInstDeclFreeVarsMap :: GlobalRdrEnv
-> NameSet
-> [(LInstDecl GhcRn, NameSet)]
-> [(LInstDecl GhcRn, NameSet)]
mkInstDeclFreeVarsMap rdr_env :: GlobalRdrEnv
rdr_env tycl_bndrs :: NameSet
tycl_bndrs inst_ds_fvs :: [(LInstDecl GhcRn, NameSet)]
inst_ds_fvs
  = [ (LInstDecl GhcRn
inst_decl, GlobalRdrEnv -> NameSet -> NameSet
toParents GlobalRdrEnv
rdr_env NameSet
fvs NameSet -> NameSet -> NameSet
`intersectFVs` NameSet
tycl_bndrs)
    | (inst_decl :: LInstDecl GhcRn
inst_decl, fvs :: NameSet
fvs) <- [(LInstDecl GhcRn, NameSet)]
inst_ds_fvs ]

-- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the
--   @InstDeclFreeVarsMap@ with these entries removed.
-- We call (getInsts tcs instd_map) when we've completed the declarations
-- for 'tcs'.  The call returns (inst_decls, instd_map'), where
--   inst_decls are the instance declarations all of
--              whose free vars are now defined
--   instd_map' is the inst-decl map with 'tcs' removed from
--               the free-var set
getInsts :: [Name] -> InstDeclFreeVarsMap
         -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts :: [Name]
-> [(LInstDecl GhcRn, NameSet)]
-> ([LInstDecl GhcRn], [(LInstDecl GhcRn, NameSet)])
getInsts bndrs :: [Name]
bndrs inst_decl_map :: [(LInstDecl GhcRn, NameSet)]
inst_decl_map
  = ((LInstDecl GhcRn, NameSet)
 -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, NameSet))
-> [(LInstDecl GhcRn, NameSet)]
-> ([LInstDecl GhcRn], [(LInstDecl GhcRn, NameSet)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (LInstDecl GhcRn, NameSet)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, NameSet)
pick_me [(LInstDecl GhcRn, NameSet)]
inst_decl_map
  where
    pick_me :: (LInstDecl GhcRn, FreeVars)
            -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
    pick_me :: (LInstDecl GhcRn, NameSet)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, NameSet)
pick_me (decl :: LInstDecl GhcRn
decl, fvs :: NameSet
fvs)
      | NameSet -> Bool
isEmptyNameSet NameSet
depleted_fvs = LInstDecl GhcRn
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, NameSet)
forall a b. a -> Either a b
Left LInstDecl GhcRn
decl
      | Bool
otherwise                   = (LInstDecl GhcRn, NameSet)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, NameSet)
forall a b. b -> Either a b
Right (LInstDecl GhcRn
decl, NameSet
depleted_fvs)
      where
        depleted_fvs :: NameSet
depleted_fvs = [Name] -> NameSet -> NameSet
delFVs [Name]
bndrs NameSet
fvs

{- ******************************************************
*                                                       *
         Renaming a type or class declaration
*                                                       *
****************************************************** -}

rnTyClDecl :: TyClDecl GhcPs
           -> RnM (TyClDecl GhcRn, FreeVars)

-- All flavours of type family declarations ("type family", "newtype family",
-- and "data family"), both top level and (for an associated type)
-- in a class decl
rnTyClDecl :: TyClDecl GhcPs -> RnM (TyClDecl GhcRn, NameSet)
rnTyClDecl (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcPs
decl })
  = do { (decl' :: FamilyDecl GhcRn
decl', fvs :: NameSet
fvs) <- Maybe Name -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, NameSet)
rnFamDecl Maybe Name
forall a. Maybe a
Nothing FamilyDecl GhcPs
decl
       ; (TyClDecl GhcRn, NameSet) -> RnM (TyClDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XFamDecl GhcRn -> FamilyDecl GhcRn -> TyClDecl GhcRn
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl XFamDecl GhcRn
NoExt
noExt FamilyDecl GhcRn
decl', NameSet
fvs) }

rnTyClDecl (SynDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = Located (IdP GhcPs)
tycon, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcPs
tyvars,
                      tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdFixity = LexicalFixity
fixity, tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = LHsType GhcPs
rhs })
  = do { Located Name
tycon' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon
       ; let kvs :: [GenLocated SrcSpan RdrName]
kvs = LHsType GhcPs -> [GenLocated SrcSpan RdrName]
extractHsTyRdrTyVarsKindVars LHsType GhcPs
rhs
             doc :: HsDocContext
doc = GenLocated SrcSpan RdrName -> HsDocContext
TySynCtx GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon
       ; String -> SDoc -> TcRn ()
traceRn "rntycl-ty" (GenLocated SrcSpan RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon SDoc -> SDoc -> SDoc
<+> [GenLocated SrcSpan RdrName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan RdrName]
kvs)
       ; HsDocContext
-> Maybe SDoc
-> Maybe Any
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (TyClDecl GhcRn, NameSet))
-> RnM (TyClDecl GhcRn, NameSet)
forall a b.
HsDocContext
-> Maybe SDoc
-> Maybe a
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindHsQTyVars HsDocContext
doc Maybe SDoc
forall a. Maybe a
Nothing Maybe Any
forall a. Maybe a
Nothing [GenLocated SrcSpan RdrName]
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn -> Bool -> RnM (TyClDecl GhcRn, NameSet))
 -> RnM (TyClDecl GhcRn, NameSet))
-> (LHsQTyVars GhcRn -> Bool -> RnM (TyClDecl GhcRn, NameSet))
-> RnM (TyClDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ tyvars' :: LHsQTyVars GhcRn
tyvars' _ ->
    do { (rhs' :: LHsType GhcRn
rhs', fvs :: NameSet
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnTySyn HsDocContext
doc LHsType GhcPs
rhs
       ; (TyClDecl GhcRn, NameSet) -> RnM (TyClDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (SynDecl :: forall pass.
XSynDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LHsType pass
-> TyClDecl pass
SynDecl { tcdLName :: Located (IdP GhcRn)
tcdLName = Located Name
Located (IdP GhcRn)
tycon', tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars'
                         , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
                         , tcdRhs :: LHsType GhcRn
tcdRhs = LHsType GhcRn
rhs', tcdSExt :: XSynDecl GhcRn
tcdSExt = NameSet
XSynDecl GhcRn
fvs }, NameSet
fvs) } }

-- "data", "newtype" declarations
-- both top level and (for an associated type) in an instance decl
rnTyClDecl (DataDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = Located (IdP GhcPs)
tycon, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcPs
tyvars,
                       tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdFixity = LexicalFixity
fixity, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcPs
defn })
  = do { Located Name
tycon' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon
       ; let kvs :: [GenLocated SrcSpan RdrName]
kvs = HsDataDefn GhcPs -> [GenLocated SrcSpan RdrName]
extractDataDefnKindVars HsDataDefn GhcPs
defn
             doc :: HsDocContext
doc = GenLocated SrcSpan RdrName -> HsDocContext
TyDataCtx GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon
       ; String -> SDoc -> TcRn ()
traceRn "rntycl-data" (GenLocated SrcSpan RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon SDoc -> SDoc -> SDoc
<+> [GenLocated SrcSpan RdrName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan RdrName]
kvs)
       ; HsDocContext
-> Maybe SDoc
-> Maybe Any
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (TyClDecl GhcRn, NameSet))
-> RnM (TyClDecl GhcRn, NameSet)
forall a b.
HsDocContext
-> Maybe SDoc
-> Maybe a
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindHsQTyVars HsDocContext
doc Maybe SDoc
forall a. Maybe a
Nothing Maybe Any
forall a. Maybe a
Nothing [GenLocated SrcSpan RdrName]
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn -> Bool -> RnM (TyClDecl GhcRn, NameSet))
 -> RnM (TyClDecl GhcRn, NameSet))
-> (LHsQTyVars GhcRn -> Bool -> RnM (TyClDecl GhcRn, NameSet))
-> RnM (TyClDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ tyvars' :: LHsQTyVars GhcRn
tyvars' no_rhs_kvs :: Bool
no_rhs_kvs ->
    do { (defn' :: HsDataDefn GhcRn
defn', fvs :: NameSet
fvs) <- HsDocContext -> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, NameSet)
rnDataDefn HsDocContext
doc HsDataDefn GhcPs
defn
          -- See Note [Complete user-supplied kind signatures] in HsDecls
       ; let cusk :: Bool
cusk = LHsQTyVars GhcRn -> Bool
forall pass. LHsQTyVars pass -> Bool
hsTvbAllKinded LHsQTyVars GhcRn
tyvars' Bool -> Bool -> Bool
&& Bool
no_rhs_kvs
             rn_info :: DataDeclRn
rn_info = DataDeclRn :: Bool -> NameSet -> DataDeclRn
DataDeclRn { tcdDataCusk :: Bool
tcdDataCusk = Bool
cusk
                                  , tcdFVs :: NameSet
tcdFVs      = NameSet
fvs }
       ; String -> SDoc -> TcRn ()
traceRn "rndata" (GenLocated SrcSpan RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
cusk SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
no_rhs_kvs)
       ; (TyClDecl GhcRn, NameSet) -> RnM (TyClDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataDecl :: forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl { tcdLName :: Located (IdP GhcRn)
tcdLName    = Located Name
Located (IdP GhcRn)
tycon'
                          , tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars   = LHsQTyVars GhcRn
tyvars'
                          , tcdFixity :: LexicalFixity
tcdFixity   = LexicalFixity
fixity
                          , tcdDataDefn :: HsDataDefn GhcRn
tcdDataDefn = HsDataDefn GhcRn
defn'
                          , tcdDExt :: XDataDecl GhcRn
tcdDExt     = XDataDecl GhcRn
DataDeclRn
rn_info }, NameSet
fvs) } }

rnTyClDecl (ClassDecl { tcdCtxt :: forall pass. TyClDecl pass -> LHsContext pass
tcdCtxt = LHsContext GhcPs
context, tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = Located (IdP GhcPs)
lcls,
                        tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcPs
tyvars, tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdFixity = LexicalFixity
fixity,
                        tcdFDs :: forall pass. TyClDecl pass -> [LHsFunDep pass]
tcdFDs = [LHsFunDep GhcPs]
fds, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcPs]
sigs,
                        tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths = LHsBinds GhcPs
mbinds, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcPs]
ats, tcdATDefs :: forall pass. TyClDecl pass -> [LTyFamDefltEqn pass]
tcdATDefs = [LTyFamDefltEqn GhcPs]
at_defs,
                        tcdDocs :: forall pass. TyClDecl pass -> [LDocDecl]
tcdDocs = [LDocDecl]
docs})
  = do  { Located Name
lcls' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
Located (IdP GhcPs)
lcls
        ; let cls' :: SrcSpanLess (Located Name)
cls' = Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
lcls'
              kvs :: [a]
kvs = []  -- No scoped kind vars except those in
                        -- kind signatures on the tyvars

        -- Tyvars scope over superclass context and method signatures
        ; ((tyvars' :: LHsQTyVars GhcRn
tyvars', context' :: LHsContext GhcRn
context', fds' :: [Located (FunDep (Located Name))]
fds', ats' :: [LFamilyDecl GhcRn]
ats'), stuff_fvs :: NameSet
stuff_fvs)
            <- HsDocContext
-> Maybe SDoc
-> Maybe Any
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn
    -> Bool
    -> RnM
         ((LHsQTyVars GhcRn, LHsContext GhcRn,
           [Located (FunDep (Located Name))], [LFamilyDecl GhcRn]),
          NameSet))
-> RnM
     ((LHsQTyVars GhcRn, LHsContext GhcRn,
       [Located (FunDep (Located Name))], [LFamilyDecl GhcRn]),
      NameSet)
forall a b.
HsDocContext
-> Maybe SDoc
-> Maybe a
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindHsQTyVars HsDocContext
cls_doc Maybe SDoc
forall a. Maybe a
Nothing Maybe Any
forall a. Maybe a
Nothing [GenLocated SrcSpan RdrName]
forall a. [a]
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn
  -> Bool
  -> RnM
       ((LHsQTyVars GhcRn, LHsContext GhcRn,
         [Located (FunDep (Located Name))], [LFamilyDecl GhcRn]),
        NameSet))
 -> RnM
      ((LHsQTyVars GhcRn, LHsContext GhcRn,
        [Located (FunDep (Located Name))], [LFamilyDecl GhcRn]),
       NameSet))
-> (LHsQTyVars GhcRn
    -> Bool
    -> RnM
         ((LHsQTyVars GhcRn, LHsContext GhcRn,
           [Located (FunDep (Located Name))], [LFamilyDecl GhcRn]),
          NameSet))
-> RnM
     ((LHsQTyVars GhcRn, LHsContext GhcRn,
       [Located (FunDep (Located Name))], [LFamilyDecl GhcRn]),
      NameSet)
forall a b. (a -> b) -> a -> b
$ \ tyvars' :: LHsQTyVars GhcRn
tyvars' _ -> do
                  -- Checks for distinct tyvars
             { (context' :: LHsContext GhcRn
context', cxt_fvs :: NameSet
cxt_fvs) <- HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, NameSet)
rnContext HsDocContext
cls_doc LHsContext GhcPs
context
             ; [Located (FunDep (Located Name))]
fds'  <- [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds [LHsFunDep GhcPs]
fds
                         -- The fundeps have no free variables
             ; (ats' :: [LFamilyDecl GhcRn]
ats', fv_ats :: NameSet
fv_ats) <- Name -> [LFamilyDecl GhcPs] -> RnM ([LFamilyDecl GhcRn], NameSet)
rnATDecls Name
SrcSpanLess (Located Name)
cls' [LFamilyDecl GhcPs]
ats
             ; let fvs :: NameSet
fvs = NameSet
cxt_fvs     NameSet -> NameSet -> NameSet
`plusFV`
                         NameSet
fv_ats
             ; ((LHsQTyVars GhcRn, LHsContext GhcRn,
  [Located (FunDep (Located Name))], [LFamilyDecl GhcRn]),
 NameSet)
-> RnM
     ((LHsQTyVars GhcRn, LHsContext GhcRn,
       [Located (FunDep (Located Name))], [LFamilyDecl GhcRn]),
      NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((LHsQTyVars GhcRn
tyvars', LHsContext GhcRn
context', [Located (FunDep (Located Name))]
fds', [LFamilyDecl GhcRn]
ats'), NameSet
fvs) }

        ; (at_defs' :: [Located (TyFamDefltEqn GhcRn)]
at_defs', fv_at_defs :: NameSet
fv_at_defs) <- (TyFamDefltEqn GhcPs -> RnM (TyFamDefltEqn GhcRn, NameSet))
-> [LTyFamDefltEqn GhcPs]
-> RnM ([Located (TyFamDefltEqn GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList (Name -> TyFamDefltEqn GhcPs -> RnM (TyFamDefltEqn GhcRn, NameSet)
rnTyFamDefltEqn Name
SrcSpanLess (Located Name)
cls') [LTyFamDefltEqn GhcPs]
at_defs

        -- No need to check for duplicate associated type decls
        -- since that is done by RnNames.extendGlobalRdrEnvRn

        -- Check the signatures
        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
        ; let sig_rdr_names_w_locs :: [GenLocated SrcSpan RdrName]
sig_rdr_names_w_locs =
                [GenLocated SrcSpan RdrName
op | (LSig GhcPs -> Located (SrcSpanLess (LSig GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (ClassOpSig _ False ops _)) <- [LSig GhcPs]
sigs
                    , GenLocated SrcSpan RdrName
op <- [GenLocated SrcSpan RdrName]
[Located (IdP GhcPs)]
ops]
        ; [GenLocated SrcSpan RdrName] -> TcRn ()
checkDupRdrNames [GenLocated SrcSpan RdrName]
sig_rdr_names_w_locs
                -- Typechecker is responsible for checking that we only
                -- give default-method bindings for things in this class.
                -- The renamer *could* check this for class decls, but can't
                -- for instance decls.

        -- The newLocals call is tiresome: given a generic class decl
        --      class C a where
        --        op :: a -> a
        --        op {| x+y |} (Inl a) = ...
        --        op {| x+y |} (Inr b) = ...
        --        op {| a*b |} (a*b)   = ...
        -- we want to name both "x" tyvars with the same unique, so that they are
        -- easy to group together in the typechecker.
        ; (mbinds' :: LHsBinds GhcRn
mbinds', sigs' :: [LSig GhcRn]
sigs', meth_fvs :: NameSet
meth_fvs)
            <- Bool
-> Name
-> [Name]
-> LHsBinds GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], NameSet)
rnMethodBinds Bool
True Name
SrcSpanLess (Located Name)
cls' (LHsQTyVars GhcRn -> [Name]
hsAllLTyVarNames LHsQTyVars GhcRn
tyvars') LHsBinds GhcPs
mbinds [LSig GhcPs]
sigs
                -- No need to check for duplicate method signatures
                -- since that is done by RnNames.extendGlobalRdrEnvRn
                -- and the methods are already in scope

  -- Haddock docs
        ; [LDocDecl]
docs' <- (LDocDecl -> IOEnv (Env TcGblEnv TcLclEnv) LDocDecl)
-> [LDocDecl] -> IOEnv (Env TcGblEnv TcLclEnv) [LDocDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess LDocDecl -> TcM (SrcSpanLess LDocDecl))
-> LDocDecl -> IOEnv (Env TcGblEnv TcLclEnv) LDocDecl
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
wrapLocM SrcSpanLess LDocDecl -> TcM (SrcSpanLess LDocDecl)
DocDecl -> RnM DocDecl
rnDocDecl) [LDocDecl]
docs

        ; let all_fvs :: NameSet
all_fvs = NameSet
meth_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
stuff_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
fv_at_defs
        ; (TyClDecl GhcRn, NameSet) -> RnM (TyClDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassDecl :: forall pass.
XClassDecl pass
-> LHsContext pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> [LHsFunDep pass]
-> [LSig pass]
-> LHsBinds pass
-> [LFamilyDecl pass]
-> [LTyFamDefltEqn pass]
-> [LDocDecl]
-> TyClDecl pass
ClassDecl { tcdCtxt :: LHsContext GhcRn
tcdCtxt = LHsContext GhcRn
context', tcdLName :: Located (IdP GhcRn)
tcdLName = Located Name
Located (IdP GhcRn)
lcls',
                              tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars', tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity,
                              tcdFDs :: [LHsFunDep GhcRn]
tcdFDs = [Located (FunDep (Located Name))]
[LHsFunDep GhcRn]
fds', tcdSigs :: [LSig GhcRn]
tcdSigs = [LSig GhcRn]
sigs',
                              tcdMeths :: LHsBinds GhcRn
tcdMeths = LHsBinds GhcRn
mbinds', tcdATs :: [LFamilyDecl GhcRn]
tcdATs = [LFamilyDecl GhcRn]
ats', tcdATDefs :: [Located (TyFamDefltEqn GhcRn)]
tcdATDefs = [Located (TyFamDefltEqn GhcRn)]
at_defs',
                              tcdDocs :: [LDocDecl]
tcdDocs = [LDocDecl]
docs', tcdCExt :: XClassDecl GhcRn
tcdCExt = NameSet
XClassDecl GhcRn
all_fvs },
                  NameSet
all_fvs ) }
  where
    cls_doc :: HsDocContext
cls_doc  = GenLocated SrcSpan RdrName -> HsDocContext
ClassDeclCtx GenLocated SrcSpan RdrName
Located (IdP GhcPs)
lcls

rnTyClDecl (XTyClDecl _) = String -> RnM (TyClDecl GhcRn, NameSet)
forall a. String -> a
panic "rnTyClDecl"

-- "type" and "type instance" declarations
rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnTySyn doc :: HsDocContext
doc rhs :: LHsType GhcPs
rhs = HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsType HsDocContext
doc LHsType GhcPs
rhs

rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
           -> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn :: HsDocContext -> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, NameSet)
rnDataDefn doc :: HsDocContext
doc (HsDataDefn { dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: forall pass. HsDataDefn pass -> Maybe (Located CType)
dd_cType = Maybe (Located CType)
cType
                           , dd_ctxt :: forall pass. HsDataDefn pass -> LHsContext pass
dd_ctxt = LHsContext GhcPs
context, dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcPs]
condecls
                           , dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsType GhcPs)
m_sig, dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcPs
derivs })
  = do  { Bool -> SDoc -> TcRn ()
checkTc (Bool
h98_style Bool -> Bool -> Bool
|| [LHsType GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (LHsContext GhcPs -> SrcSpanLess (LHsContext GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsContext GhcPs
context))
                  (HsDocContext -> SDoc
badGadtStupidTheta HsDocContext
doc)

        ; (m_sig' :: Maybe (LHsType GhcRn)
m_sig', sig_fvs :: NameSet
sig_fvs) <- case Maybe (LHsType GhcPs)
m_sig of
             Just sig :: LHsType GhcPs
sig -> (LHsType GhcRn -> Maybe (LHsType GhcRn))
-> (LHsType GhcRn, NameSet) -> (Maybe (LHsType GhcRn), NameSet)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first LHsType GhcRn -> Maybe (LHsType GhcRn)
forall a. a -> Maybe a
Just ((LHsType GhcRn, NameSet) -> (Maybe (LHsType GhcRn), NameSet))
-> RnM (LHsType GhcRn, NameSet)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsType GhcRn), NameSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsKind HsDocContext
doc LHsType GhcPs
sig
             Nothing  -> (Maybe (LHsType GhcRn), NameSet)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsType GhcRn), NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (LHsType GhcRn)
forall a. Maybe a
Nothing, NameSet
emptyFVs)
        ; (context' :: LHsContext GhcRn
context', fvs1 :: NameSet
fvs1) <- HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, NameSet)
rnContext HsDocContext
doc LHsContext GhcPs
context
        ; (derivs' :: HsDeriving GhcRn
derivs',  fvs3 :: NameSet
fvs3) <- HsDeriving GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (HsDeriving GhcRn, NameSet)
rn_derivs HsDeriving GhcPs
derivs

        -- For the constructor declarations, drop the LocalRdrEnv
        -- in the GADT case, where the type variables in the declaration
        -- do not scope over the constructor signatures
        -- data T a where { T1 :: forall b. b-> b }
        ; let { zap_lcl_env :: RnM ([LConDecl GhcRn], NameSet) -> RnM ([LConDecl GhcRn], NameSet)
zap_lcl_env | Bool
h98_style = \ thing :: RnM ([LConDecl GhcRn], NameSet)
thing -> RnM ([LConDecl GhcRn], NameSet)
thing
                            | Bool
otherwise = LocalRdrEnv
-> RnM ([LConDecl GhcRn], NameSet)
-> RnM ([LConDecl GhcRn], NameSet)
forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
emptyLocalRdrEnv }
        ; (condecls' :: [LConDecl GhcRn]
condecls', con_fvs :: NameSet
con_fvs) <- RnM ([LConDecl GhcRn], NameSet) -> RnM ([LConDecl GhcRn], NameSet)
zap_lcl_env (RnM ([LConDecl GhcRn], NameSet)
 -> RnM ([LConDecl GhcRn], NameSet))
-> RnM ([LConDecl GhcRn], NameSet)
-> RnM ([LConDecl GhcRn], NameSet)
forall a b. (a -> b) -> a -> b
$ [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], NameSet)
rnConDecls [LConDecl GhcPs]
condecls
           -- No need to check for duplicate constructor decls
           -- since that is done by RnNames.extendGlobalRdrEnvRn

        ; let all_fvs :: NameSet
all_fvs = NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs3 NameSet -> NameSet -> NameSet
`plusFV`
                        NameSet
con_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
sig_fvs
        ; (HsDataDefn GhcRn, NameSet) -> RnM (HsDataDefn GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcRn
dd_ext = XCHsDataDefn GhcRn
NoExt
noExt
                              , dd_ND :: NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: Maybe (Located CType)
dd_cType = Maybe (Located CType)
cType
                              , dd_ctxt :: LHsContext GhcRn
dd_ctxt = LHsContext GhcRn
context', dd_kindSig :: Maybe (LHsType GhcRn)
dd_kindSig = Maybe (LHsType GhcRn)
m_sig'
                              , dd_cons :: [LConDecl GhcRn]
dd_cons = [LConDecl GhcRn]
condecls'
                              , dd_derivs :: HsDeriving GhcRn
dd_derivs = HsDeriving GhcRn
derivs' }
                 , NameSet
all_fvs )
        }
  where
    h98_style :: Bool
h98_style = case [LConDecl GhcPs]
condecls of  -- Note [Stupid theta]
                     (LConDecl GhcPs -> Located (SrcSpanLess (LConDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (ConDeclGADT {})) : _  -> Bool
False
                     _                               -> Bool
True

    rn_derivs :: HsDeriving GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (HsDeriving GhcRn, NameSet)
rn_derivs (HsDeriving GhcPs -> Located (SrcSpanLess (HsDeriving GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc ds :: SrcSpanLess (HsDeriving GhcPs)
ds)
      = do { Bool
deriv_strats_ok <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DerivingStrategies
           ; Bool -> SDoc -> TcRn ()
failIfTc ([LHsDerivingClause GhcPs] -> Int -> Bool
forall a. [a] -> Int -> Bool
lengthExceeds [LHsDerivingClause GhcPs]
SrcSpanLess (HsDeriving GhcPs)
ds 1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
deriv_strats_ok)
               SDoc
multipleDerivClausesErr
           ; (ds' :: [LHsDerivingClause GhcRn]
ds', fvs :: NameSet
fvs) <- (LHsDerivingClause GhcPs -> RnM (LHsDerivingClause GhcRn, NameSet))
-> [LHsDerivingClause GhcPs]
-> RnM ([LHsDerivingClause GhcRn], NameSet)
forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn (HsDocContext
-> LHsDerivingClause GhcPs
-> RnM (LHsDerivingClause GhcRn, NameSet)
rnLHsDerivingClause HsDocContext
doc) [LHsDerivingClause GhcPs]
SrcSpanLess (HsDeriving GhcPs)
ds
           ; (HsDeriving GhcRn, NameSet)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsDeriving GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (HsDeriving GhcRn) -> HsDeriving GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc [LHsDerivingClause GhcRn]
SrcSpanLess (HsDeriving GhcRn)
ds', NameSet
fvs) }
rnDataDefn _ (XHsDataDefn _) = String -> RnM (HsDataDefn GhcRn, NameSet)
forall a. String -> a
panic "rnDataDefn"

warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
                 -> SrcSpan
                 -> RnM ()
warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat mds :: Maybe (LDerivStrategy GhcRn)
mds loc :: SrcSpan
loc
  = do { DynFlags
dyn_flags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingDerivingStrategies DynFlags
dyn_flags) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           case Maybe (LDerivStrategy GhcRn)
mds of
             Nothing -> WarnReason -> SrcSpan -> SDoc -> TcRn ()
addWarnAt
               (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingDerivingStrategies)
               SrcSpan
loc
               (if Extension -> DynFlags -> Bool
xopt Extension
LangExt.DerivingStrategies DynFlags
dyn_flags
                 then SDoc
no_strat_warning
                 else SDoc
no_strat_warning SDoc -> SDoc -> SDoc
$+$ SDoc
deriv_strat_nenabled
               )
             _ -> () -> TcRn ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
       }
  where
    no_strat_warning :: SDoc
    no_strat_warning :: SDoc
no_strat_warning = String -> SDoc
text "No deriving strategy specified. Did you want stock"
                       SDoc -> SDoc -> SDoc
<> String -> SDoc
text ", newtype, or anyclass?"
    deriv_strat_nenabled :: SDoc
    deriv_strat_nenabled :: SDoc
deriv_strat_nenabled = String -> SDoc
text "Use DerivingStrategies to specify a strategy."

rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs
                    -> RnM (LHsDerivingClause GhcRn, FreeVars)
rnLHsDerivingClause :: HsDocContext
-> LHsDerivingClause GhcPs
-> RnM (LHsDerivingClause GhcRn, NameSet)
rnLHsDerivingClause doc :: HsDocContext
doc
                (LHsDerivingClause GhcPs
-> Located (SrcSpanLess (LHsDerivingClause GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (HsDerivingClause
                              { deriv_clause_ext = noExt
                              , deriv_clause_strategy = dcs
                              , deriv_clause_tys = (dL->L loc' dct) }))
  = do { (dcs' :: Maybe (LDerivStrategy GhcRn)
dcs', dct' :: [LHsSigType GhcRn]
dct', fvs :: NameSet
fvs)
           <- HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> ([Name] -> SDoc -> RnM ([LHsSigType GhcRn], NameSet))
-> RnM (Maybe (LDerivStrategy GhcRn), [LHsSigType GhcRn], NameSet)
forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> ([Name] -> SDoc -> RnM (a, NameSet))
-> RnM (Maybe (LDerivStrategy GhcRn), a, NameSet)
rnLDerivStrategy HsDocContext
doc Maybe (LDerivStrategy GhcPs)
dcs (([Name] -> SDoc -> RnM ([LHsSigType GhcRn], NameSet))
 -> RnM (Maybe (LDerivStrategy GhcRn), [LHsSigType GhcRn], NameSet))
-> ([Name] -> SDoc -> RnM ([LHsSigType GhcRn], NameSet))
-> RnM (Maybe (LDerivStrategy GhcRn), [LHsSigType GhcRn], NameSet)
forall a b. (a -> b) -> a -> b
$ \strat_tvs :: [Name]
strat_tvs ppr_via_ty :: SDoc
ppr_via_ty ->
              (LHsSigType GhcPs -> RnM (LHsSigType GhcRn, NameSet))
-> [LHsSigType GhcPs] -> RnM ([LHsSigType GhcRn], NameSet)
forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn ([Name]
-> SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, NameSet)
rn_deriv_ty [Name]
strat_tvs SDoc
ppr_via_ty) [LHsSigType GhcPs]
SrcSpanLess (Located [LHsSigType GhcPs])
dct
       ; Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (LDerivStrategy GhcRn)
dcs' SrcSpan
loc
       ; (LHsDerivingClause GhcRn, NameSet)
-> RnM (LHsDerivingClause GhcRn, NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( SrcSpan
-> SrcSpanLess (LHsDerivingClause GhcRn) -> LHsDerivingClause GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (HsDerivingClause :: forall pass.
XCHsDerivingClause pass
-> Maybe (LDerivStrategy pass)
-> Located [LHsSigType pass]
-> HsDerivingClause pass
HsDerivingClause { deriv_clause_ext :: XCHsDerivingClause GhcRn
deriv_clause_ext = XCHsDerivingClause GhcPs
XCHsDerivingClause GhcRn
noExt
                                         , deriv_clause_strategy :: Maybe (LDerivStrategy GhcRn)
deriv_clause_strategy = Maybe (LDerivStrategy GhcRn)
dcs'
                                         , deriv_clause_tys :: Located [LHsSigType GhcRn]
deriv_clause_tys = SrcSpan
-> SrcSpanLess (Located [LHsSigType GhcRn])
-> Located [LHsSigType GhcRn]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' [LHsSigType GhcRn]
SrcSpanLess (Located [LHsSigType GhcRn])
dct' })
              , NameSet
fvs ) }
  where
    rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs
                -> RnM (LHsSigType GhcRn, FreeVars)
    rn_deriv_ty :: [Name]
-> SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, NameSet)
rn_deriv_ty strat_tvs :: [Name]
strat_tvs ppr_via_ty :: SDoc
ppr_via_ty deriv_ty :: LHsSigType GhcPs
deriv_ty@(HsIB {hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc _}) =
      [Name]
-> SrcSpan
-> SDoc
-> String
-> RnM (LHsSigType GhcRn, NameSet)
-> RnM (LHsSigType GhcRn, NameSet)
forall a.
Outputable a =>
[Name]
-> SrcSpan
-> SDoc
-> String
-> RnM (a, NameSet)
-> RnM (a, NameSet)
rnAndReportFloatingViaTvs [Name]
strat_tvs SrcSpan
loc SDoc
ppr_via_ty "class" (RnM (LHsSigType GhcRn, NameSet)
 -> RnM (LHsSigType GhcRn, NameSet))
-> RnM (LHsSigType GhcRn, NameSet)
-> RnM (LHsSigType GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$
      HsDocContext -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
doc LHsSigType GhcPs
deriv_ty
    rn_deriv_ty _ _ (XHsImplicitBndrs _) = String -> RnM (LHsSigType GhcRn, NameSet)
forall a. String -> a
panic "rn_deriv_ty"
rnLHsDerivingClause _ (LHsDerivingClause GhcPs
-> Located (SrcSpanLess (LHsDerivingClause GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (XHsDerivingClause _))
  = String -> RnM (LHsDerivingClause GhcRn, NameSet)
forall a. String -> a
panic "rnLHsDerivingClause"
rnLHsDerivingClause _ _ = String -> RnM (LHsDerivingClause GhcRn, NameSet)
forall a. String -> a
panic "rnLHsDerivingClause: Impossible Match"
                                -- due to #15884

rnLDerivStrategy :: forall a.
                    HsDocContext
                 -> Maybe (LDerivStrategy GhcPs)
                 -> ([Name]   -- The tyvars bound by the via type
                      -> SDoc -- The pretty-printed via type (used for
                              -- error message reporting)
                      -> RnM (a, FreeVars))
                 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy :: HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> ([Name] -> SDoc -> RnM (a, NameSet))
-> RnM (Maybe (LDerivStrategy GhcRn), a, NameSet)
rnLDerivStrategy doc :: HsDocContext
doc mds :: Maybe (LDerivStrategy GhcPs)
mds thing_inside :: [Name] -> SDoc -> RnM (a, NameSet)
thing_inside
  = case Maybe (LDerivStrategy GhcPs)
mds of
      Nothing -> Maybe (LDerivStrategy GhcRn)
-> RnM (Maybe (LDerivStrategy GhcRn), a, NameSet)
forall mds. mds -> RnM (mds, a, NameSet)
boring_case Maybe (LDerivStrategy GhcRn)
forall a. Maybe a
Nothing
      Just ds :: LDerivStrategy GhcPs
ds -> do (ds' :: LDerivStrategy GhcRn
ds', thing :: a
thing, fvs :: NameSet
fvs) <- LDerivStrategy GhcPs -> RnM (LDerivStrategy GhcRn, a, NameSet)
rn_deriv_strat LDerivStrategy GhcPs
ds
                    (Maybe (LDerivStrategy GhcRn), a, NameSet)
-> RnM (Maybe (LDerivStrategy GhcRn), a, NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LDerivStrategy GhcRn -> Maybe (LDerivStrategy GhcRn)
forall a. a -> Maybe a
Just LDerivStrategy GhcRn
ds', a
thing, NameSet
fvs)
  where
    rn_deriv_strat :: LDerivStrategy GhcPs
                   -> RnM (LDerivStrategy GhcRn, a, FreeVars)
    rn_deriv_strat :: LDerivStrategy GhcPs -> RnM (LDerivStrategy GhcRn, a, NameSet)
rn_deriv_strat (LDerivStrategy GhcPs
-> Located (SrcSpanLess (LDerivStrategy GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc ds :: SrcSpanLess (LDerivStrategy GhcPs)
ds) = do
      let extNeeded :: LangExt.Extension
          extNeeded :: Extension
extNeeded
            | ViaStrategy{} <- SrcSpanLess (LDerivStrategy GhcPs)
ds
            = Extension
LangExt.DerivingVia
            | Bool
otherwise
            = Extension
LangExt.DerivingStrategies

      Extension -> TcRn () -> TcRn ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
extNeeded (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
        SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWith (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DerivStrategy GhcPs -> SDoc
illegalDerivStrategyErr SrcSpanLess (LDerivStrategy GhcPs)
DerivStrategy GhcPs
ds

      case SrcSpanLess (LDerivStrategy GhcPs)
ds of
        StockStrategy    -> LDerivStrategy GhcRn -> RnM (LDerivStrategy GhcRn, a, NameSet)
forall mds. mds -> RnM (mds, a, NameSet)
boring_case (SrcSpan
-> SrcSpanLess (LDerivStrategy GhcRn) -> LDerivStrategy GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LDerivStrategy GhcRn)
forall pass. DerivStrategy pass
StockStrategy)
        AnyclassStrategy -> LDerivStrategy GhcRn -> RnM (LDerivStrategy GhcRn, a, NameSet)
forall mds. mds -> RnM (mds, a, NameSet)
boring_case (SrcSpan
-> SrcSpanLess (LDerivStrategy GhcRn) -> LDerivStrategy GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LDerivStrategy GhcRn)
forall pass. DerivStrategy pass
AnyclassStrategy)
        NewtypeStrategy  -> LDerivStrategy GhcRn -> RnM (LDerivStrategy GhcRn, a, NameSet)
forall mds. mds -> RnM (mds, a, NameSet)
boring_case (SrcSpan
-> SrcSpanLess (LDerivStrategy GhcRn) -> LDerivStrategy GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LDerivStrategy GhcRn)
forall pass. DerivStrategy pass
NewtypeStrategy)
        ViaStrategy via_ty ->
          do (via_ty' :: LHsSigType GhcRn
via_ty', fvs1 :: NameSet
fvs1) <- HsDocContext -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
doc XViaStrategy GhcPs
LHsSigType GhcPs
via_ty
             let HsIB { hsib_ext :: forall pass thing. HsImplicitBndrs pass thing -> XHsIB pass thing
hsib_ext  = XHsIB GhcRn (LHsType GhcRn)
via_imp_tvs
                      , hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = LHsType GhcRn
via_body } = LHsSigType GhcRn
via_ty'
                 (via_exp_tv_bndrs :: [LHsTyVarBndr GhcRn]
via_exp_tv_bndrs, _, _) = LHsType GhcRn
-> ([LHsTyVarBndr GhcRn], LHsContext GhcRn, LHsType GhcRn)
forall pass.
LHsType pass
-> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
splitLHsSigmaTy LHsType GhcRn
via_body
                 via_exp_tvs :: [Name]
via_exp_tvs = (LHsTyVarBndr GhcRn -> Name) -> [LHsTyVarBndr GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr GhcRn -> Name
forall pass. LHsTyVarBndr pass -> IdP pass
hsLTyVarName [LHsTyVarBndr GhcRn]
via_exp_tv_bndrs
                 via_tvs :: [Name]
via_tvs = [Name]
XHsIB GhcRn (LHsType GhcRn)
via_imp_tvs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
via_exp_tvs
             (thing :: a
thing, fvs2 :: NameSet
fvs2) <- [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
extendTyVarEnvFVRn [Name]
via_tvs (RnM (a, NameSet) -> RnM (a, NameSet))
-> RnM (a, NameSet) -> RnM (a, NameSet)
forall a b. (a -> b) -> a -> b
$
                              [Name] -> SDoc -> RnM (a, NameSet)
thing_inside [Name]
via_tvs (LHsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
via_ty')
             (LDerivStrategy GhcRn, a, NameSet)
-> RnM (LDerivStrategy GhcRn, a, NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan
-> SrcSpanLess (LDerivStrategy GhcRn) -> LDerivStrategy GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XViaStrategy GhcRn -> DerivStrategy GhcRn
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy XViaStrategy GhcRn
LHsSigType GhcRn
via_ty'), a
thing, NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs2)

    boring_case :: mds
                -> RnM (mds, a, FreeVars)
    boring_case :: mds -> RnM (mds, a, NameSet)
boring_case mds :: mds
mds = do
      (thing :: a
thing, fvs :: NameSet
fvs) <- [Name] -> SDoc -> RnM (a, NameSet)
thing_inside [] SDoc
empty
      (mds, a, NameSet) -> RnM (mds, a, NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (mds
mds, a
thing, NameSet
fvs)

-- | Errors if a @via@ type binds any floating type variables.
-- See @Note [Floating `via` type variables]@
rnAndReportFloatingViaTvs
  :: forall a. Outputable a
  => [Name]  -- ^ The bound type variables from a @via@ type.
  -> SrcSpan -- ^ The source span (for error reporting only).
  -> SDoc    -- ^ The pretty-printed @via@ type (for error reporting only).
  -> String  -- ^ A description of what the @via@ type scopes over
             --   (for error reporting only).
  -> RnM (a, FreeVars) -- ^ The thing the @via@ type scopes over.
  -> RnM (a, FreeVars)
rnAndReportFloatingViaTvs :: [Name]
-> SrcSpan
-> SDoc
-> String
-> RnM (a, NameSet)
-> RnM (a, NameSet)
rnAndReportFloatingViaTvs tv_names :: [Name]
tv_names loc :: SrcSpan
loc ppr_via_ty :: SDoc
ppr_via_ty via_scope_desc :: String
via_scope_desc thing_inside :: RnM (a, NameSet)
thing_inside
  = do (thing :: a
thing, thing_fvs :: NameSet
thing_fvs) <- RnM (a, NameSet)
thing_inside
       SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (a -> NameSet -> Name -> TcRn ()
report_floating_via_tv a
thing NameSet
thing_fvs) [Name]
tv_names
       (a, NameSet) -> RnM (a, NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
thing, NameSet
thing_fvs)
  where
    report_floating_via_tv :: a -> FreeVars -> Name -> RnM ()
    report_floating_via_tv :: a -> NameSet -> Name -> TcRn ()
report_floating_via_tv thing :: a
thing used_names :: NameSet
used_names tv_name :: Name
tv_name
      = Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
tv_name Name -> NameSet -> Bool
`elemNameSet` NameSet
used_names) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
addErr (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
          [ String -> SDoc
text "Type variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tv_name) SDoc -> SDoc -> SDoc
<+>
            String -> SDoc
text "is bound in the" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text "via") SDoc -> SDoc -> SDoc
<+>
            String -> SDoc
text "type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
ppr_via_ty
          , String -> SDoc
text "but is not mentioned in the derived" SDoc -> SDoc -> SDoc
<+>
            String -> SDoc
text String
via_scope_desc SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
thing) SDoc -> SDoc -> SDoc
<>
            String -> SDoc
text ", which is illegal" ]

{-
Note [Floating `via` type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Imagine the following `deriving via` clause:

    data Quux
      deriving Eq via (Const a Quux)

This should be rejected. Why? Because it would generate the following instance:

    instance Eq Quux where
      (==) = coerce @(Quux         -> Quux         -> Bool)
                    @(Const a Quux -> Const a Quux -> Bool)
                    (==) :: Const a Quux -> Const a Quux -> Bool

This instance is ill-formed, as the `a` in `Const a Quux` is unbound. The
problem is that `a` is never used anywhere in the derived class `Eq`. Since
`a` is bound but has no use sites, we refer to it as "floating".

We use the rnAndReportFloatingViaTvs function to check that any type renamed
within the context of the `via` deriving strategy actually uses all bound
`via` type variables, and if it doesn't, it throws an error.
-}

badGadtStupidTheta :: HsDocContext -> SDoc
badGadtStupidTheta :: HsDocContext -> SDoc
badGadtStupidTheta _
  = [SDoc] -> SDoc
vcat [String -> SDoc
text "No context is allowed on a GADT-style data declaration",
          String -> SDoc
text "(You can put a context on each constructor, though.)"]

illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc
illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc
illegalDerivStrategyErr ds :: DerivStrategy GhcPs
ds
  = [SDoc] -> SDoc
vcat [ String -> SDoc
text "Illegal deriving strategy" SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> DerivStrategy GhcPs -> SDoc
forall a. DerivStrategy a -> SDoc
derivStrategyName DerivStrategy GhcPs
ds
         , String -> SDoc
text String
enableStrategy ]

  where
    enableStrategy :: String
    enableStrategy :: String
enableStrategy
      | ViaStrategy{} <- DerivStrategy GhcPs
ds
      = "Use DerivingVia to enable this extension"
      | Bool
otherwise
      = "Use DerivingStrategies to enable this extension"

multipleDerivClausesErr :: SDoc
multipleDerivClausesErr :: SDoc
multipleDerivClausesErr
  = [SDoc] -> SDoc
vcat [ String -> SDoc
text "Illegal use of multiple, consecutive deriving clauses"
         , String -> SDoc
text "Use DerivingStrategies to allow this" ]

rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
                        --             inside an *class decl* for cls
                        --             used for associated types
          -> FamilyDecl GhcPs
          -> RnM (FamilyDecl GhcRn, FreeVars)
rnFamDecl :: Maybe Name -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, NameSet)
rnFamDecl mb_cls :: Maybe Name
mb_cls (FamilyDecl { fdLName :: forall pass. FamilyDecl pass -> Located (IdP pass)
fdLName = Located (IdP GhcPs)
tycon, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcPs
tyvars
                             , fdFixity :: forall pass. FamilyDecl pass -> LexicalFixity
fdFixity = LexicalFixity
fixity
                             , fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcPs
info, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = LFamilyResultSig GhcPs
res_sig
                             , fdInjectivityAnn :: forall pass. FamilyDecl pass -> Maybe (LInjectivityAnn pass)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcPs)
injectivity })
  = do { Located Name
tycon' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon
       ; ((tyvars' :: LHsQTyVars GhcRn
tyvars', res_sig' :: LFamilyResultSig GhcRn
res_sig', injectivity' :: Maybe (LInjectivityAnn GhcRn)
injectivity'), fv1 :: NameSet
fv1) <-
            HsDocContext
-> Maybe SDoc
-> Maybe Name
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn
    -> Bool
    -> RnM
         ((LHsQTyVars GhcRn, LFamilyResultSig GhcRn,
           Maybe (LInjectivityAnn GhcRn)),
          NameSet))
-> RnM
     ((LHsQTyVars GhcRn, LFamilyResultSig GhcRn,
       Maybe (LInjectivityAnn GhcRn)),
      NameSet)
forall a b.
HsDocContext
-> Maybe SDoc
-> Maybe a
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindHsQTyVars HsDocContext
doc Maybe SDoc
forall a. Maybe a
Nothing Maybe Name
mb_cls [GenLocated SrcSpan RdrName]
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn
  -> Bool
  -> RnM
       ((LHsQTyVars GhcRn, LFamilyResultSig GhcRn,
         Maybe (LInjectivityAnn GhcRn)),
        NameSet))
 -> RnM
      ((LHsQTyVars GhcRn, LFamilyResultSig GhcRn,
        Maybe (LInjectivityAnn GhcRn)),
       NameSet))
-> (LHsQTyVars GhcRn
    -> Bool
    -> RnM
         ((LHsQTyVars GhcRn, LFamilyResultSig GhcRn,
           Maybe (LInjectivityAnn GhcRn)),
          NameSet))
-> RnM
     ((LHsQTyVars GhcRn, LFamilyResultSig GhcRn,
       Maybe (LInjectivityAnn GhcRn)),
      NameSet)
forall a b. (a -> b) -> a -> b
$ \ tyvars' :: LHsQTyVars GhcRn
tyvars' _ ->
            do { let rn_sig :: FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, NameSet)
rn_sig = HsDocContext
-> FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, NameSet)
rnFamResultSig HsDocContext
doc
               ; (res_sig' :: LFamilyResultSig GhcRn
res_sig', fv_kind :: NameSet
fv_kind) <- (SrcSpanLess (LFamilyResultSig GhcPs)
 -> TcM (SrcSpanLess (LFamilyResultSig GhcRn), NameSet))
-> LFamilyResultSig GhcPs -> TcM (LFamilyResultSig GhcRn, NameSet)
forall a b c.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b, c)) -> a -> TcM (b, c)
wrapLocFstM SrcSpanLess (LFamilyResultSig GhcPs)
-> TcM (SrcSpanLess (LFamilyResultSig GhcRn), NameSet)
FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, NameSet)
rn_sig LFamilyResultSig GhcPs
res_sig
               ; Maybe (LInjectivityAnn GhcRn)
injectivity' <- (LInjectivityAnn GhcPs
 -> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn))
-> Maybe (LInjectivityAnn GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LInjectivityAnn GhcRn))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (LHsQTyVars GhcRn
-> LFamilyResultSig GhcRn
-> LInjectivityAnn GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
rnInjectivityAnn LHsQTyVars GhcRn
tyvars' LFamilyResultSig GhcRn
res_sig')
                                          Maybe (LInjectivityAnn GhcPs)
injectivity
               ; ((LHsQTyVars GhcRn, LFamilyResultSig GhcRn,
  Maybe (LInjectivityAnn GhcRn)),
 NameSet)
-> RnM
     ((LHsQTyVars GhcRn, LFamilyResultSig GhcRn,
       Maybe (LInjectivityAnn GhcRn)),
      NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ( (LHsQTyVars GhcRn
tyvars', LFamilyResultSig GhcRn
res_sig', Maybe (LInjectivityAnn GhcRn)
injectivity') , NameSet
fv_kind ) }
       ; (info' :: FamilyInfo GhcRn
info', fv2 :: NameSet
fv2) <- Located Name -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, NameSet)
rn_info Located Name
tycon' FamilyInfo GhcPs
info
       ; (FamilyDecl GhcRn, NameSet) -> RnM (FamilyDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (FamilyDecl :: forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl { fdExt :: XCFamilyDecl GhcRn
fdExt = XCFamilyDecl GhcRn
NoExt
noExt
                            , fdLName :: Located (IdP GhcRn)
fdLName = Located Name
Located (IdP GhcRn)
tycon', fdTyVars :: LHsQTyVars GhcRn
fdTyVars = LHsQTyVars GhcRn
tyvars'
                            , fdFixity :: LexicalFixity
fdFixity = LexicalFixity
fixity
                            , fdInfo :: FamilyInfo GhcRn
fdInfo = FamilyInfo GhcRn
info', fdResultSig :: LFamilyResultSig GhcRn
fdResultSig = LFamilyResultSig GhcRn
res_sig'
                            , fdInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcRn)
injectivity' }
                , NameSet
fv1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fv2) }
  where
     doc :: HsDocContext
doc = GenLocated SrcSpan RdrName -> HsDocContext
TyFamilyCtx GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon
     kvs :: [GenLocated SrcSpan RdrName]
kvs = LFamilyResultSig GhcPs -> [GenLocated SrcSpan RdrName]
extractRdrKindSigVars LFamilyResultSig GhcPs
res_sig

     ----------------------
     rn_info :: Located Name
             -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
     rn_info :: Located Name -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, NameSet)
rn_info (Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ fam_name :: SrcSpanLess (Located Name)
fam_name) (ClosedTypeFamily (Just eqns :: [LTyFamInstEqn GhcPs]
eqns))
       = do { (eqns' :: [Located (TyFamInstEqn GhcRn)]
eqns', fvs :: NameSet
fvs)
                <- (TyFamInstEqn GhcPs -> RnM (TyFamInstEqn GhcRn, NameSet))
-> [LTyFamInstEqn GhcPs]
-> RnM ([Located (TyFamInstEqn GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList (Maybe (Name, [Name])
-> ClosedTyFamInfo
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, NameSet)
rnTyFamInstEqn Maybe (Name, [Name])
forall a. Maybe a
Nothing (GenLocated SrcSpan RdrName -> Name -> ClosedTyFamInfo
ClosedTyFam GenLocated SrcSpan RdrName
Located (IdP GhcPs)
tycon Name
SrcSpanLess (Located Name)
fam_name))
                                          -- no class context
                          [LTyFamInstEqn GhcPs]
eqns
            ; (FamilyInfo GhcRn, NameSet) -> RnM (FamilyInfo GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Located (TyFamInstEqn GhcRn)] -> FamilyInfo GhcRn
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily ([Located (TyFamInstEqn GhcRn)]
-> Maybe [Located (TyFamInstEqn GhcRn)]
forall a. a -> Maybe a
Just [Located (TyFamInstEqn GhcRn)]
eqns'), NameSet
fvs) }
     rn_info _ (ClosedTypeFamily Nothing)
       = (FamilyInfo GhcRn, NameSet) -> RnM (FamilyInfo GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Located (TyFamInstEqn GhcRn)] -> FamilyInfo GhcRn
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily Maybe [Located (TyFamInstEqn GhcRn)]
forall a. Maybe a
Nothing, NameSet
emptyFVs)
     rn_info _ OpenTypeFamily = (FamilyInfo GhcRn, NameSet) -> RnM (FamilyInfo GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (FamilyInfo GhcRn
forall pass. FamilyInfo pass
OpenTypeFamily, NameSet
emptyFVs)
     rn_info _ DataFamily     = (FamilyInfo GhcRn, NameSet) -> RnM (FamilyInfo GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (FamilyInfo GhcRn
forall pass. FamilyInfo pass
DataFamily, NameSet
emptyFVs)
rnFamDecl _ (XFamilyDecl _) = String -> RnM (FamilyDecl GhcRn, NameSet)
forall a. String -> a
panic "rnFamDecl"

rnFamResultSig :: HsDocContext
               -> FamilyResultSig GhcPs
               -> RnM (FamilyResultSig GhcRn, FreeVars)
rnFamResultSig :: HsDocContext
-> FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, NameSet)
rnFamResultSig _ (NoSig _)
   = (FamilyResultSig GhcRn, NameSet)
-> RnM (FamilyResultSig GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XNoSig GhcRn -> FamilyResultSig GhcRn
forall pass. XNoSig pass -> FamilyResultSig pass
NoSig XNoSig GhcRn
NoExt
noExt, NameSet
emptyFVs)
rnFamResultSig doc :: HsDocContext
doc (KindSig _ kind :: LHsType GhcPs
kind)
   = do { (rndKind :: LHsType GhcRn
rndKind, ftvs :: NameSet
ftvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsKind HsDocContext
doc LHsType GhcPs
kind
        ;  (FamilyResultSig GhcRn, NameSet)
-> RnM (FamilyResultSig GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCKindSig GhcRn -> LHsType GhcRn -> FamilyResultSig GhcRn
forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
KindSig XCKindSig GhcRn
NoExt
noExt LHsType GhcRn
rndKind, NameSet
ftvs) }
rnFamResultSig doc :: HsDocContext
doc (TyVarSig _ tvbndr :: LHsTyVarBndr GhcPs
tvbndr)
   = do { -- `TyVarSig` tells us that user named the result of a type family by
          -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
          -- be sure that the supplied result name is not identical to an
          -- already in-scope type variable from an enclosing class.
          --
          --  Example of disallowed declaration:
          --         class C a b where
          --            type F b = a | a -> b
          LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
       ;  let resName :: IdP GhcPs
resName = LHsTyVarBndr GhcPs -> IdP GhcPs
forall pass. LHsTyVarBndr pass -> IdP pass
hsLTyVarName LHsTyVarBndr GhcPs
tvbndr
       ;  Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RdrName
IdP GhcPs
resName RdrName -> LocalRdrEnv -> Bool
`elemLocalRdrEnv` LocalRdrEnv
rdr_env) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
          SrcSpan -> SDoc -> TcRn ()
addErrAt (LHsTyVarBndr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsTyVarBndr GhcPs
tvbndr) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                     ([SDoc] -> SDoc
hsep [ String -> SDoc
text "Type variable", SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
IdP GhcPs
resName) SDoc -> SDoc -> SDoc
<> SDoc
comma
                           , String -> SDoc
text "naming a type family result,"
                           ] SDoc -> SDoc -> SDoc
$$
                      String -> SDoc
text "shadows an already bound type variable")

       ; HsDocContext
-> Maybe Any
-> LHsTyVarBndr GhcPs
-> (LHsTyVarBndr GhcRn -> RnM (FamilyResultSig GhcRn, NameSet))
-> RnM (FamilyResultSig GhcRn, NameSet)
forall a b.
HsDocContext
-> Maybe a
-> LHsTyVarBndr GhcPs
-> (LHsTyVarBndr GhcRn -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindLHsTyVarBndr HsDocContext
doc Maybe Any
forall a. Maybe a
Nothing -- This might be a lie, but it's used for
                                      -- scoping checks that are irrelevant here
                          LHsTyVarBndr GhcPs
tvbndr ((LHsTyVarBndr GhcRn -> RnM (FamilyResultSig GhcRn, NameSet))
 -> RnM (FamilyResultSig GhcRn, NameSet))
-> (LHsTyVarBndr GhcRn -> RnM (FamilyResultSig GhcRn, NameSet))
-> RnM (FamilyResultSig GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ tvbndr' :: LHsTyVarBndr GhcRn
tvbndr' ->
         (FamilyResultSig GhcRn, NameSet)
-> RnM (FamilyResultSig GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTyVarSig GhcRn -> LHsTyVarBndr GhcRn -> FamilyResultSig GhcRn
forall pass.
XTyVarSig pass -> LHsTyVarBndr pass -> FamilyResultSig pass
TyVarSig XTyVarSig GhcRn
NoExt
noExt LHsTyVarBndr GhcRn
tvbndr', Name -> NameSet
unitFV (LHsTyVarBndr GhcRn -> IdP GhcRn
forall pass. LHsTyVarBndr pass -> IdP pass
hsLTyVarName LHsTyVarBndr GhcRn
tvbndr')) }
rnFamResultSig _ (XFamilyResultSig _) = String -> RnM (FamilyResultSig GhcRn, NameSet)
forall a. String -> a
panic "rnFamResultSig"

-- Note [Renaming injectivity annotation]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- During renaming of injectivity annotation we have to make several checks to
-- make sure that it is well-formed.  At the moment injectivity annotation
-- consists of a single injectivity condition, so the terms "injectivity
-- annotation" and "injectivity condition" might be used interchangeably.  See
-- Note [Injectivity annotation] for a detailed discussion of currently allowed
-- injectivity annotations.
--
-- Checking LHS is simple because the only type variable allowed on the LHS of
-- injectivity condition is the variable naming the result in type family head.
-- Example of disallowed annotation:
--
--     type family Foo a b = r | b -> a
--
-- Verifying RHS of injectivity consists of checking that:
--
--  1. only variables defined in type family head appear on the RHS (kind
--     variables are also allowed).  Example of disallowed annotation:
--
--        type family Foo a = r | r -> b
--
--  2. for associated types the result variable does not shadow any of type
--     class variables. Example of disallowed annotation:
--
--        class Foo a b where
--           type F a = b | b -> a
--
-- Breaking any of these assumptions results in an error.

-- | Rename injectivity annotation. Note that injectivity annotation is just the
-- part after the "|".  Everything that appears before it is renamed in
-- rnFamDecl.
rnInjectivityAnn :: LHsQTyVars GhcRn           -- ^ Type variables declared in
                                               --   type family head
                 -> LFamilyResultSig GhcRn     -- ^ Result signature
                 -> LInjectivityAnn GhcPs      -- ^ Injectivity annotation
                 -> RnM (LInjectivityAnn GhcRn)
rnInjectivityAnn :: LHsQTyVars GhcRn
-> LFamilyResultSig GhcRn
-> LInjectivityAnn GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
rnInjectivityAnn tvBndrs :: LHsQTyVars GhcRn
tvBndrs (LFamilyResultSig GhcRn
-> Located (SrcSpanLess (LFamilyResultSig GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (TyVarSig _ resTv))
                 (LInjectivityAnn GhcPs
-> Located (SrcSpanLess (LInjectivityAnn GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L srcSpan :: SrcSpan
srcSpan (InjectivityAnn injFrom injTo))
 = do
   { (injDecl' :: LInjectivityAnn GhcRn
injDecl'@(LInjectivityAnn GhcRn
-> Located (SrcSpanLess (LInjectivityAnn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (InjectivityAnn injFrom' injTo')), noRnErrors :: Bool
noRnErrors)
          <- IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
-> TcRn (LInjectivityAnn GhcRn, Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs (IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
 -> TcRn (LInjectivityAnn GhcRn, Bool))
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
-> TcRn (LInjectivityAnn GhcRn, Bool)
forall a b. (a -> b) -> a -> b
$
             [Name]
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [LHsTyVarBndr GhcRn -> IdP GhcRn
forall pass. LHsTyVarBndr pass -> IdP pass
hsLTyVarName LHsTyVarBndr GhcRn
resTv] (IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
forall a b. (a -> b) -> a -> b
$
             -- The return type variable scopes over the injectivity annotation
             -- e.g.   type family F a = (r::*) | r -> a
             do { Located Name
injFrom' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
rnLTyVar GenLocated SrcSpan RdrName
Located (IdP GhcPs)
injFrom
                ; [Located Name]
injTo'   <- (GenLocated SrcSpan RdrName -> RnM (Located Name))
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan RdrName -> RnM (Located Name)
rnLTyVar [GenLocated SrcSpan RdrName]
[Located (IdP GhcPs)]
injTo
                ; LInjectivityAnn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (LInjectivityAnn GhcRn
 -> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn))
-> LInjectivityAnn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (LInjectivityAnn GhcRn) -> LInjectivityAnn GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
srcSpan (Located (IdP GhcRn)
-> [Located (IdP GhcRn)] -> InjectivityAnn GhcRn
forall pass.
Located (IdP pass) -> [Located (IdP pass)] -> InjectivityAnn pass
InjectivityAnn Located Name
Located (IdP GhcRn)
injFrom' [Located Name]
[Located (IdP GhcRn)]
injTo') }

   ; let tvNames :: Set Name
tvNames  = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ LHsQTyVars GhcRn -> [Name]
hsAllLTyVarNames LHsQTyVars GhcRn
tvBndrs
         resName :: IdP GhcRn
resName  = LHsTyVarBndr GhcRn -> IdP GhcRn
forall pass. LHsTyVarBndr pass -> IdP pass
hsLTyVarName LHsTyVarBndr GhcRn
resTv
         -- See Note [Renaming injectivity annotation]
         lhsValid :: Bool
lhsValid = Ordering
EQ Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== (Name -> Name -> Ordering
stableNameCmp Name
IdP GhcRn
resName (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
Located (IdP GhcRn)
injFrom'))
         rhsValid :: Set Name
rhsValid = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located Name]
[Located (IdP GhcRn)]
injTo') Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Name
tvNames

   -- if renaming of type variables ended with errors (eg. there were
   -- not-in-scope variables) don't check the validity of injectivity
   -- annotation. This gives better error messages.
   ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
noRnErrors Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
lhsValid) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
        SrcSpan -> SDoc -> TcRn ()
addErrAt (GenLocated SrcSpan RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc GenLocated SrcSpan RdrName
Located (IdP GhcPs)
injFrom)
              ( [SDoc] -> SDoc
vcat [ String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ "Incorrect type variable on the LHS of "
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ "injectivity condition"
              , Int -> SDoc -> SDoc
nest 5
              ( [SDoc] -> SDoc
vcat [ String -> SDoc
text "Expected :" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
IdP GhcRn
resName
                     , String -> SDoc
text "Actual   :" SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpan RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan RdrName
Located (IdP GhcPs)
injFrom ])])

   ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
noRnErrors Bool -> Bool -> Bool
&& Bool -> Bool
not (Set Name -> Bool
forall a. Set a -> Bool
Set.null Set Name
rhsValid)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
      do { let errorVars :: [Name]
errorVars = Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Set Name
rhsValid
         ; SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
srcSpan (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ ( [SDoc] -> SDoc
hsep
                        [ String -> SDoc
text "Unknown type variable" SDoc -> SDoc -> SDoc
<> [Name] -> SDoc
forall a. [a] -> SDoc
plural [Name]
errorVars
                        , String -> SDoc
text "on the RHS of injectivity condition:"
                        , [Name] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [Name]
errorVars ] ) }

   ; LInjectivityAnn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return LInjectivityAnn GhcRn
injDecl' }

-- We can only hit this case when the user writes injectivity annotation without
-- naming the result:
--
--   type family F a | result -> a
--   type family F a :: * | result -> a
--
-- So we rename injectivity annotation like we normally would except that
-- this time we expect "result" to be reported not in scope by rnLTyVar.
rnInjectivityAnn _ _ (LInjectivityAnn GhcPs
-> Located (SrcSpanLess (LInjectivityAnn GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L srcSpan :: SrcSpan
srcSpan (InjectivityAnn injFrom injTo)) =
   SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
srcSpan (IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
forall a b. (a -> b) -> a -> b
$ do
   (injDecl' :: LInjectivityAnn GhcRn
injDecl', _) <- IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
-> TcRn (LInjectivityAnn GhcRn, Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs (IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
 -> TcRn (LInjectivityAnn GhcRn, Bool))
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
-> TcRn (LInjectivityAnn GhcRn, Bool)
forall a b. (a -> b) -> a -> b
$ do
     Located Name
injFrom' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
rnLTyVar GenLocated SrcSpan RdrName
Located (IdP GhcPs)
injFrom
     [Located Name]
injTo'   <- (GenLocated SrcSpan RdrName -> RnM (Located Name))
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan RdrName -> RnM (Located Name)
rnLTyVar [GenLocated SrcSpan RdrName]
[Located (IdP GhcPs)]
injTo
     LInjectivityAnn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (LInjectivityAnn GhcRn
 -> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn))
-> LInjectivityAnn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (LInjectivityAnn GhcRn) -> LInjectivityAnn GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
srcSpan (Located (IdP GhcRn)
-> [Located (IdP GhcRn)] -> InjectivityAnn GhcRn
forall pass.
Located (IdP pass) -> [Located (IdP pass)] -> InjectivityAnn pass
InjectivityAnn Located Name
Located (IdP GhcRn)
injFrom' [Located Name]
[Located (IdP GhcRn)]
injTo')
   LInjectivityAnn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (LInjectivityAnn GhcRn
 -> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn))
-> LInjectivityAnn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LInjectivityAnn GhcRn)
forall a b. (a -> b) -> a -> b
$ LInjectivityAnn GhcRn
injDecl'

{-
Note [Stupid theta]
~~~~~~~~~~~~~~~~~~~
Trac #3850 complains about a regression wrt 6.10 for
     data Show a => T a
There is no reason not to allow the stupid theta if there are no data
constructors.  It's still stupid, but does no harm, and I don't want
to cause programs to break unnecessarily (notably HList).  So if there
are no data constructors we allow h98_style = True
-}


{- *****************************************************
*                                                      *
     Support code for type/data declarations
*                                                      *
***************************************************** -}

---------------
wrongTyFamName :: Name -> Name -> SDoc
wrongTyFamName :: Name -> Name -> SDoc
wrongTyFamName fam_tc_name :: Name
fam_tc_name eqn_tc_name :: Name
eqn_tc_name
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Mismatched type name in type family instance.")
       2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text "Expected:" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fam_tc_name
               , String -> SDoc
text "  Actual:" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
eqn_tc_name ])

-----------------
rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], NameSet)
rnConDecls = (LConDecl GhcPs -> RnM (LConDecl GhcRn, NameSet))
-> [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], NameSet)
forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn ((SrcSpanLess (LConDecl GhcPs)
 -> TcM (SrcSpanLess (LConDecl GhcRn), NameSet))
-> LConDecl GhcPs -> RnM (LConDecl GhcRn, NameSet)
forall a b c.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b, c)) -> a -> TcM (b, c)
wrapLocFstM SrcSpanLess (LConDecl GhcPs)
-> TcM (SrcSpanLess (LConDecl GhcRn), NameSet)
ConDecl GhcPs -> RnM (ConDecl GhcRn, NameSet)
rnConDecl)

rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, NameSet)
rnConDecl decl :: ConDecl GhcPs
decl@(ConDeclH98 { con_name :: forall pass. ConDecl pass -> Located (IdP pass)
con_name = Located (IdP GhcPs)
name, con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr pass]
con_ex_tvs = [LHsTyVarBndr GhcPs]
ex_tvs
                           , con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcPs)
mcxt, con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_args = HsConDeclDetails GhcPs
args
                           , con_doc :: forall pass. ConDecl pass -> Maybe LHsDocString
con_doc = Maybe LHsDocString
mb_doc })
  = do  { ()
_        <- (SrcSpanLess (GenLocated SrcSpan RdrName) -> TcRn ())
-> GenLocated SrcSpan RdrName -> TcRn ()
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM SrcSpanLess (GenLocated SrcSpan RdrName) -> TcRn ()
RdrName -> TcRn ()
checkConName GenLocated SrcSpan RdrName
Located (IdP GhcPs)
name
        ; Located Name
new_name <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
Located (IdP GhcPs)
name
        ; Maybe LHsDocString
mb_doc'  <- Maybe LHsDocString -> RnM (Maybe LHsDocString)
rnMbLHsDoc Maybe LHsDocString
mb_doc

        -- We bind no implicit binders here; this is just like
        -- a nested HsForAllTy.  E.g. consider
        --         data T a = forall (b::k). MkT (...)
        -- The 'k' will already be in scope from the bindHsQTyVars
        -- for the data decl itself. So we'll get
        --         data T {k} a = ...
        -- And indeed we may later discover (a::k).  But that's the
        -- scoping we get.  So no implicit binders at the existential forall

        ; let ctxt :: HsDocContext
ctxt = [Located Name] -> HsDocContext
ConDeclCtx [Located Name
new_name]
        ; HsDocContext
-> Maybe SDoc
-> Maybe Any
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (ConDecl GhcRn, NameSet))
-> RnM (ConDecl GhcRn, NameSet)
forall a b.
HsDocContext
-> Maybe SDoc
-> Maybe a
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindLHsTyVarBndrs HsDocContext
ctxt (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (HsDocContext -> SDoc
inHsDocContext HsDocContext
ctxt))
                            Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr GhcPs]
ex_tvs (([LHsTyVarBndr GhcRn] -> RnM (ConDecl GhcRn, NameSet))
 -> RnM (ConDecl GhcRn, NameSet))
-> ([LHsTyVarBndr GhcRn] -> RnM (ConDecl GhcRn, NameSet))
-> RnM (ConDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ new_ex_tvs :: [LHsTyVarBndr GhcRn]
new_ex_tvs ->
    do  { (new_context :: Maybe (LHsContext GhcRn)
new_context, fvs1 :: NameSet
fvs1) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), NameSet)
rnMbContext HsDocContext
ctxt Maybe (LHsContext GhcPs)
mcxt
        ; (new_args :: HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
new_args,    fvs2 :: NameSet
fvs2) <- Name
-> HsDocContext
-> HsConDeclDetails GhcPs
-> RnM
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
      NameSet)
rnConDeclDetails (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
new_name) HsDocContext
ctxt HsConDeclDetails GhcPs
args
        ; let all_fvs :: NameSet
all_fvs  = NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs2
        ; String -> SDoc -> TcRn ()
traceRn "rnConDecl" (GenLocated SrcSpan RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan RdrName
Located (IdP GhcPs)
name SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat
             [ String -> SDoc
text "ex_tvs:" SDoc -> SDoc -> SDoc
<+> [LHsTyVarBndr GhcPs] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr GhcPs]
ex_tvs
             , String -> SDoc
text "new_ex_dqtvs':" SDoc -> SDoc -> SDoc
<+> [LHsTyVarBndr GhcRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr GhcRn]
new_ex_tvs ])

        ; (ConDecl GhcRn, NameSet) -> RnM (ConDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConDecl GhcPs
decl { con_ext :: XConDeclH98 GhcRn
con_ext = XConDeclH98 GhcRn
NoExt
noExt
                       , con_name :: Located (IdP GhcRn)
con_name = Located Name
Located (IdP GhcRn)
new_name, con_ex_tvs :: [LHsTyVarBndr GhcRn]
con_ex_tvs = [LHsTyVarBndr GhcRn]
new_ex_tvs
                       , con_mb_cxt :: Maybe (LHsContext GhcRn)
con_mb_cxt = Maybe (LHsContext GhcRn)
new_context, con_args :: HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
con_args = HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
new_args
                       , con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
mb_doc' },
                  NameSet
all_fvs) }}

rnConDecl decl :: ConDecl GhcPs
decl@(ConDeclGADT { con_names :: forall pass. ConDecl pass -> [Located (IdP pass)]
con_names   = [Located (IdP GhcPs)]
names
                            , con_forall :: forall pass. ConDecl pass -> Located Bool
con_forall  = (Located Bool -> Located (SrcSpanLess (Located Bool))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ explicit_forall :: SrcSpanLess (Located Bool)
explicit_forall)
                            , con_qvars :: forall pass. ConDecl pass -> LHsQTyVars pass
con_qvars   = LHsQTyVars GhcPs
qtvs
                            , con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt  = Maybe (LHsContext GhcPs)
mcxt
                            , con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_args    = HsConDeclDetails GhcPs
args
                            , con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty  = LHsType GhcPs
res_ty
                            , con_doc :: forall pass. ConDecl pass -> Maybe LHsDocString
con_doc = Maybe LHsDocString
mb_doc })
  = do  { (GenLocated SrcSpan RdrName -> TcRn ())
-> [GenLocated SrcSpan RdrName] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((SrcSpanLess (GenLocated SrcSpan RdrName) -> TcRn ())
-> GenLocated SrcSpan RdrName -> TcRn ()
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM SrcSpanLess (GenLocated SrcSpan RdrName) -> TcRn ()
RdrName -> TcRn ()
checkConName) [GenLocated SrcSpan RdrName]
[Located (IdP GhcPs)]
names
        ; [Located Name]
new_names <- (GenLocated SrcSpan RdrName -> RnM (Located Name))
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn [GenLocated SrcSpan RdrName]
[Located (IdP GhcPs)]
names
        ; Maybe LHsDocString
mb_doc'   <- Maybe LHsDocString -> RnM (Maybe LHsDocString)
rnMbLHsDoc Maybe LHsDocString
mb_doc

        ; let explicit_tkvs :: [LHsTyVarBndr GhcPs]
explicit_tkvs = LHsQTyVars GhcPs -> [LHsTyVarBndr GhcPs]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit LHsQTyVars GhcPs
qtvs
              theta :: [LHsType GhcPs]
theta         = Maybe (LHsContext GhcPs) -> [LHsType GhcPs]
forall pass. Maybe (LHsContext pass) -> [LHsType pass]
hsConDeclTheta Maybe (LHsContext GhcPs)
mcxt
              arg_tys :: [LHsType GhcPs]
arg_tys       = HsConDeclDetails GhcPs -> [LHsType GhcPs]
forall pass. HsConDeclDetails pass -> [LBangType pass]
hsConDeclArgTys HsConDeclDetails GhcPs
args

          -- We must ensure that we extract the free tkvs in left-to-right
          -- order of their appearance in the constructor type.
          -- That order governs the order the implicitly-quantified type
          -- variable, and hence the order needed for visible type application
          -- See Trac #14808.
              free_tkvs :: FreeKiTyVarsWithDups
free_tkvs = [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extractHsTvBndrs [LHsTyVarBndr GhcPs]
explicit_tkvs (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
                          [LHsType GhcPs] -> FreeKiTyVarsWithDups
extractHsTysRdrTyVarsDups ([LHsType GhcPs]
theta [LHsType GhcPs] -> [LHsType GhcPs] -> [LHsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsType GhcPs]
arg_tys [LHsType GhcPs] -> [LHsType GhcPs] -> [LHsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsType GhcPs
res_ty])

              ctxt :: HsDocContext
ctxt    = [Located Name] -> HsDocContext
ConDeclCtx [Located Name]
new_names
              mb_ctxt :: Maybe SDoc
mb_ctxt = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (HsDocContext -> SDoc
inHsDocContext HsDocContext
ctxt)

        ; String -> SDoc -> TcRn ()
traceRn "rnConDecl" ([GenLocated SrcSpan RdrName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan RdrName]
[Located (IdP GhcPs)]
names SDoc -> SDoc -> SDoc
$$ FreeKiTyVarsWithDups -> SDoc
forall a. Outputable a => a -> SDoc
ppr FreeKiTyVarsWithDups
free_tkvs SDoc -> SDoc -> SDoc
$$ Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
SrcSpanLess (Located Bool)
explicit_forall )
        ; Bool
-> FreeKiTyVarsWithDups
-> ([Name] -> RnM (ConDecl GhcRn, NameSet))
-> RnM (ConDecl GhcRn, NameSet)
forall a.
Bool
-> FreeKiTyVarsWithDups
-> ([Name] -> RnM (a, NameSet))
-> RnM (a, NameSet)
rnImplicitBndrs (Bool -> Bool
not Bool
SrcSpanLess (Located Bool)
explicit_forall) FreeKiTyVarsWithDups
free_tkvs (([Name] -> RnM (ConDecl GhcRn, NameSet))
 -> RnM (ConDecl GhcRn, NameSet))
-> ([Name] -> RnM (ConDecl GhcRn, NameSet))
-> RnM (ConDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ implicit_tkvs :: [Name]
implicit_tkvs ->
          HsDocContext
-> Maybe SDoc
-> Maybe Any
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (ConDecl GhcRn, NameSet))
-> RnM (ConDecl GhcRn, NameSet)
forall a b.
HsDocContext
-> Maybe SDoc
-> Maybe a
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindLHsTyVarBndrs HsDocContext
ctxt Maybe SDoc
mb_ctxt Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr GhcPs]
explicit_tkvs (([LHsTyVarBndr GhcRn] -> RnM (ConDecl GhcRn, NameSet))
 -> RnM (ConDecl GhcRn, NameSet))
-> ([LHsTyVarBndr GhcRn] -> RnM (ConDecl GhcRn, NameSet))
-> RnM (ConDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ explicit_tkvs :: [LHsTyVarBndr GhcRn]
explicit_tkvs ->
    do  { (new_cxt :: Maybe (LHsContext GhcRn)
new_cxt, fvs1 :: NameSet
fvs1)    <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), NameSet)
rnMbContext HsDocContext
ctxt Maybe (LHsContext GhcPs)
mcxt
        ; (new_args :: HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
new_args, fvs2 :: NameSet
fvs2)   <- Name
-> HsDocContext
-> HsConDeclDetails GhcPs
-> RnM
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
      NameSet)
rnConDeclDetails (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc ([Located Name] -> Located Name
forall a. [a] -> a
head [Located Name]
new_names)) HsDocContext
ctxt HsConDeclDetails GhcPs
args
        ; (new_res_ty :: LHsType GhcRn
new_res_ty, fvs3 :: NameSet
fvs3) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsType HsDocContext
ctxt LHsType GhcPs
res_ty

        ; let all_fvs :: NameSet
all_fvs = NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs2 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs3
              (args' :: HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
args', res_ty' :: LHsType GhcRn
res_ty')
                  = case HsConDeclDetails GhcPs
args of
                      InfixCon {}  -> String
-> SDoc
-> (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
    LHsType GhcRn)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "rnConDecl" ([GenLocated SrcSpan RdrName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan RdrName]
[Located (IdP GhcPs)]
names)
                      RecCon {}    -> (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
new_args, LHsType GhcRn
new_res_ty)
                      PrefixCon as :: [LHsType GhcPs]
as | (arg_tys :: [LHsType GhcRn]
arg_tys, final_res_ty :: LHsType GhcRn
final_res_ty) <- LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn)
splitHsFunType LHsType GhcRn
new_res_ty
                                   -> ASSERT( null as )
                                      -- See Note [GADT abstract syntax] in HsDecls
                                      ([LHsType GhcRn]
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [LHsType GhcRn]
arg_tys, LHsType GhcRn
final_res_ty)

              new_qtvs :: LHsQTyVars GhcRn
new_qtvs =  HsQTvs :: forall pass. XHsQTvs pass -> [LHsTyVarBndr pass] -> LHsQTyVars pass
HsQTvs { hsq_ext :: XHsQTvs GhcRn
hsq_ext = HsQTvsRn :: [Name] -> NameSet -> HsQTvsRn
HsQTvsRn
                                     { hsq_implicit :: [Name]
hsq_implicit  = [Name]
implicit_tkvs
                                     , hsq_dependent :: NameSet
hsq_dependent = NameSet
emptyNameSet }
                                 , hsq_explicit :: [LHsTyVarBndr GhcRn]
hsq_explicit  = [LHsTyVarBndr GhcRn]
explicit_tkvs }

        ; String -> SDoc -> TcRn ()
traceRn "rnConDecl2" ([GenLocated SrcSpan RdrName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan RdrName]
[Located (IdP GhcPs)]
names SDoc -> SDoc -> SDoc
$$ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
implicit_tkvs SDoc -> SDoc -> SDoc
$$ [LHsTyVarBndr GhcRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr GhcRn]
explicit_tkvs)
        ; (ConDecl GhcRn, NameSet) -> RnM (ConDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConDecl GhcPs
decl { con_g_ext :: XConDeclGADT GhcRn
con_g_ext = XConDeclGADT GhcRn
NoExt
noExt, con_names :: [Located (IdP GhcRn)]
con_names = [Located Name]
[Located (IdP GhcRn)]
new_names
                       , con_qvars :: LHsQTyVars GhcRn
con_qvars = LHsQTyVars GhcRn
new_qtvs, con_mb_cxt :: Maybe (LHsContext GhcRn)
con_mb_cxt = Maybe (LHsContext GhcRn)
new_cxt
                       , con_args :: HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
con_args = HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
args', con_res_ty :: LHsType GhcRn
con_res_ty = LHsType GhcRn
res_ty'
                       , con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
mb_doc' },
                  NameSet
all_fvs) } }

rnConDecl (XConDecl _) = String -> RnM (ConDecl GhcRn, NameSet)
forall a. String -> a
panic "rnConDecl"


rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
            -> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMbContext :: HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), NameSet)
rnMbContext _    Nothing    = (Maybe (LHsContext GhcRn), NameSet)
-> RnM (Maybe (LHsContext GhcRn), NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (LHsContext GhcRn)
forall a. Maybe a
Nothing, NameSet
emptyFVs)
rnMbContext doc :: HsDocContext
doc (Just cxt :: LHsContext GhcPs
cxt) = do { (ctx' :: LHsContext GhcRn
ctx',fvs :: NameSet
fvs) <- HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, NameSet)
rnContext HsDocContext
doc LHsContext GhcPs
cxt
                                ; (Maybe (LHsContext GhcRn), NameSet)
-> RnM (Maybe (LHsContext GhcRn), NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsContext GhcRn -> Maybe (LHsContext GhcRn)
forall a. a -> Maybe a
Just LHsContext GhcRn
ctx',NameSet
fvs) }

rnConDeclDetails
   :: Name
   -> HsDocContext
   -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs])
   -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
           FreeVars)
rnConDeclDetails :: Name
-> HsDocContext
-> HsConDeclDetails GhcPs
-> RnM
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
      NameSet)
rnConDeclDetails _ doc :: HsDocContext
doc (PrefixCon tys :: [LHsType GhcPs]
tys)
  = do { (new_tys :: [LHsType GhcRn]
new_tys, fvs :: NameSet
fvs) <- HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], NameSet)
rnLHsTypes HsDocContext
doc [LHsType GhcPs]
tys
       ; (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
 NameSet)
-> RnM
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
      NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsType GhcRn]
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [LHsType GhcRn]
new_tys, NameSet
fvs) }

rnConDeclDetails _ doc :: HsDocContext
doc (InfixCon ty1 :: LHsType GhcPs
ty1 ty2 :: LHsType GhcPs
ty2)
  = do { (new_ty1 :: LHsType GhcRn
new_ty1, fvs1 :: NameSet
fvs1) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsType HsDocContext
doc LHsType GhcPs
ty1
       ; (new_ty2 :: LHsType GhcRn
new_ty2, fvs2 :: NameSet
fvs2) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsType HsDocContext
doc LHsType GhcPs
ty2
       ; (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
 NameSet)
-> RnM
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
      NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcRn
-> LHsType GhcRn
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LHsType GhcRn
new_ty1 LHsType GhcRn
new_ty2, NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs2) }

rnConDeclDetails con :: Name
con doc :: HsDocContext
doc (RecCon (Located [LConDeclField GhcPs]
-> Located (SrcSpanLess (Located [LConDeclField GhcPs]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l fields :: SrcSpanLess (Located [LConDeclField GhcPs])
fields))
  = do  { [FieldLabel]
fls <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
con
        ; (new_fields :: [LConDeclField GhcRn]
new_fields, fvs :: NameSet
fvs) <- HsDocContext
-> [FieldLabel]
-> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], NameSet)
rnConDeclFields HsDocContext
doc [FieldLabel]
fls [LConDeclField GhcPs]
SrcSpanLess (Located [LConDeclField GhcPs])
fields
                -- No need to check for duplicate fields
                -- since that is done by RnNames.extendGlobalRdrEnvRn
        ; (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
 NameSet)
-> RnM
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
      NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located [LConDeclField GhcRn]
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpan
-> SrcSpanLess (Located [LConDeclField GhcRn])
-> Located [LConDeclField GhcRn]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [LConDeclField GhcRn]
SrcSpanLess (Located [LConDeclField GhcRn])
new_fields), NameSet
fvs) }

-------------------------------------------------

-- | Brings pattern synonym names and also pattern synonym selectors
-- from record pattern synonyms into scope.
extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv
                -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
extendPatSynEnv :: HsValBinds GhcPs
-> MiniFixityEnv
-> ([Name] -> TcRnIf TcGblEnv TcLclEnv a)
-> TcRnIf TcGblEnv TcLclEnv a
extendPatSynEnv val_decls :: HsValBinds GhcPs
val_decls local_fix_env :: MiniFixityEnv
local_fix_env thing :: [Name] -> TcRnIf TcGblEnv TcLclEnv a
thing = do {
     [(Name, [FieldLabel])]
names_with_fls <- HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
new_ps HsValBinds GhcPs
val_decls
   ; let pat_syn_bndrs :: [Name]
pat_syn_bndrs = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Name
nameName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector [FieldLabel]
fields
                                | (name :: Name
name, fields :: [FieldLabel]
fields) <- [(Name, [FieldLabel])]
names_with_fls ]
   ; let avails :: [AvailInfo]
avails = (Name -> AvailInfo) -> [Name] -> [AvailInfo]
forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail [Name]
pat_syn_bndrs
   ; (gbl_env :: TcGblEnv
gbl_env, lcl_env :: TcLclEnv
lcl_env) <- [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn [AvailInfo]
avails MiniFixityEnv
local_fix_env

   ; let field_env' :: NameEnv [FieldLabel]
field_env' = NameEnv [FieldLabel]
-> [(Name, [FieldLabel])] -> NameEnv [FieldLabel]
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcGblEnv -> NameEnv [FieldLabel]
tcg_field_env TcGblEnv
gbl_env) [(Name, [FieldLabel])]
names_with_fls
         final_gbl_env :: TcGblEnv
final_gbl_env = TcGblEnv
gbl_env { tcg_field_env :: NameEnv [FieldLabel]
tcg_field_env = NameEnv [FieldLabel]
field_env' }
   ; (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
final_gbl_env, TcLclEnv
lcl_env) ([Name] -> TcRnIf TcGblEnv TcLclEnv a
thing [Name]
pat_syn_bndrs) }
  where
    new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
    new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
new_ps (ValBinds _ binds :: LHsBinds GhcPs
binds _) = (LHsBindLR GhcPs GhcPs
 -> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])])
-> [(Name, [FieldLabel])]
-> LHsBinds GhcPs
-> TcM [(Name, [FieldLabel])]
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> b -> Bag a -> m b
foldrBagM LHsBindLR GhcPs GhcPs
-> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
new_ps' [] LHsBinds GhcPs
binds
    new_ps _ = String -> TcM [(Name, [FieldLabel])]
forall a. String -> a
panic "new_ps"

    new_ps' :: LHsBindLR GhcPs GhcPs
            -> [(Name, [FieldLabel])]
            -> TcM [(Name, [FieldLabel])]
    new_ps' :: LHsBindLR GhcPs GhcPs
-> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
new_ps' bind :: LHsBindLR GhcPs GhcPs
bind names :: [(Name, [FieldLabel])]
names
      | (LHsBindLR GhcPs GhcPs
-> Located (SrcSpanLess (LHsBindLR GhcPs GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L bind_loc :: SrcSpan
bind_loc (PatSynBind _ (PSB { psb_id = (dL->L _ n)
                                           , psb_args = RecCon as }))) <- LHsBindLR GhcPs GhcPs
bind
      = do
          Name
bnd_name <- GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTopSrcBinder (SrcSpan
-> SrcSpanLess (GenLocated SrcSpan RdrName)
-> GenLocated SrcSpan RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
bind_loc SrcSpanLess (GenLocated SrcSpan RdrName)
n)
          let rnames :: [GenLocated SrcSpan RdrName]
rnames = (RecordPatSynField (GenLocated SrcSpan RdrName)
 -> GenLocated SrcSpan RdrName)
-> [RecordPatSynField (GenLocated SrcSpan RdrName)]
-> [GenLocated SrcSpan RdrName]
forall a b. (a -> b) -> [a] -> [b]
map RecordPatSynField (GenLocated SrcSpan RdrName)
-> GenLocated SrcSpan RdrName
forall a. RecordPatSynField a -> a
recordPatSynSelectorId [RecordPatSynField (GenLocated SrcSpan RdrName)]
[RecordPatSynField (Located (IdP GhcPs))]
as
              mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs
              mkFieldOcc :: GenLocated SrcSpan RdrName -> LFieldOcc GhcPs
mkFieldOcc (GenLocated SrcSpan RdrName
-> Located (SrcSpanLess (GenLocated SrcSpan RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l name :: SrcSpanLess (GenLocated SrcSpan RdrName)
name) = SrcSpan -> SrcSpanLess (LFieldOcc GhcPs) -> LFieldOcc GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XCFieldOcc GhcPs -> GenLocated SrcSpan RdrName -> FieldOcc GhcPs
forall pass.
XCFieldOcc pass -> GenLocated SrcSpan RdrName -> FieldOcc pass
FieldOcc XCFieldOcc GhcPs
NoExt
noExt (SrcSpan
-> SrcSpanLess (GenLocated SrcSpan RdrName)
-> GenLocated SrcSpan RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (GenLocated SrcSpan RdrName)
name))
              field_occs :: [LFieldOcc GhcPs]
field_occs =  (GenLocated SrcSpan RdrName -> LFieldOcc GhcPs)
-> [GenLocated SrcSpan RdrName] -> [LFieldOcc GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan RdrName -> LFieldOcc GhcPs
mkFieldOcc [GenLocated SrcSpan RdrName]
rnames
          [FieldLabel]
flds     <- (LFieldOcc GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) FieldLabel)
-> [LFieldOcc GhcPs] -> RnM [FieldLabel]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool
-> [Name]
-> LFieldOcc GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) FieldLabel
newRecordSelector Bool
False [Name
bnd_name]) [LFieldOcc GhcPs]
field_occs
          [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
bnd_name, [FieldLabel]
flds)(Name, [FieldLabel])
-> [(Name, [FieldLabel])] -> [(Name, [FieldLabel])]
forall a. a -> [a] -> [a]
: [(Name, [FieldLabel])]
names)
      | (LHsBindLR GhcPs GhcPs
-> Located (SrcSpanLess (LHsBindLR GhcPs GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L bind_loc :: SrcSpan
bind_loc (PatSynBind _
                          (PSB { psb_id = (dL->L _ n)}))) <- LHsBindLR GhcPs GhcPs
bind
      = do
        Name
bnd_name <- GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTopSrcBinder (SrcSpan
-> SrcSpanLess (GenLocated SrcSpan RdrName)
-> GenLocated SrcSpan RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
bind_loc SrcSpanLess (GenLocated SrcSpan RdrName)
n)
        [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
bnd_name, [])(Name, [FieldLabel])
-> [(Name, [FieldLabel])] -> [(Name, [FieldLabel])]
forall a. a -> [a] -> [a]
: [(Name, [FieldLabel])]
names)
      | Bool
otherwise
      = [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name, [FieldLabel])]
names

{-
*********************************************************
*                                                      *
\subsection{Support code to rename types}
*                                                      *
*********************************************************
-}

rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds fds :: [LHsFunDep GhcPs]
fds
  = (Located (FunDep (GenLocated SrcSpan RdrName))
 -> IOEnv (Env TcGblEnv TcLclEnv) (Located (FunDep (Located Name))))
-> [Located (FunDep (GenLocated SrcSpan RdrName))]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located (FunDep (Located Name))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (Located (FunDep (GenLocated SrcSpan RdrName)))
 -> TcM (SrcSpanLess (Located (FunDep (Located Name)))))
-> Located (FunDep (GenLocated SrcSpan RdrName))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (FunDep (Located Name)))
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
wrapLocM FunDep (GenLocated SrcSpan RdrName)
-> IOEnv (Env TcGblEnv TcLclEnv) (FunDep (Located Name))
SrcSpanLess (Located (FunDep (GenLocated SrcSpan RdrName)))
-> TcM (SrcSpanLess (Located (FunDep (Located Name))))
rn_fds) [Located (FunDep (GenLocated SrcSpan RdrName))]
[LHsFunDep GhcPs]
fds
  where
    rn_fds :: FunDep (GenLocated SrcSpan RdrName)
-> IOEnv (Env TcGblEnv TcLclEnv) (FunDep (Located Name))
rn_fds (tys1 :: [GenLocated SrcSpan RdrName]
tys1, tys2 :: [GenLocated SrcSpan RdrName]
tys2)
      = do { [Located Name]
tys1' <- [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
rnHsTyVars [GenLocated SrcSpan RdrName]
tys1
           ; [Located Name]
tys2' <- [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
rnHsTyVars [GenLocated SrcSpan RdrName]
tys2
           ; FunDep (Located Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (FunDep (Located Name))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Located Name]
tys1', [Located Name]
tys2') }

rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
rnHsTyVars :: [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
rnHsTyVars tvs :: [GenLocated SrcSpan RdrName]
tvs  = (GenLocated SrcSpan RdrName -> RnM (Located Name))
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan RdrName -> RnM (Located Name)
rnHsTyVar [GenLocated SrcSpan RdrName]
tvs

rnHsTyVar :: Located RdrName -> RnM (Located Name)
rnHsTyVar :: GenLocated SrcSpan RdrName -> RnM (Located Name)
rnHsTyVar (GenLocated SrcSpan RdrName
-> Located (SrcSpanLess (GenLocated SrcSpan RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l tyvar :: SrcSpanLess (GenLocated SrcSpan RdrName)
tyvar) = do
  Name
tyvar' <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupOccRn SrcSpanLess (GenLocated SrcSpan RdrName)
RdrName
tyvar
  Located Name -> RnM (Located Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l Name
SrcSpanLess (Located Name)
tyvar')

{-
*********************************************************
*                                                      *
        findSplice
*                                                      *
*********************************************************

This code marches down the declarations, looking for the first
Template Haskell splice.  As it does so it
        a) groups the declarations into a HsGroup
        b) runs any top-level quasi-quotes
-}

findSplice :: [LHsDecl GhcPs]
           -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice :: [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice ds :: [LHsDecl GhcPs]
ds = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl HsGroup GhcPs
forall (p :: Pass). HsGroup (GhcPass p)
emptyRdrGroup [LHsDecl GhcPs]
ds

addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
     -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
-- This stuff reverses the declarations (again) but it doesn't matter
addl :: HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl gp :: HsGroup GhcPs
gp []           = (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsGroup GhcPs
gp, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
forall a. Maybe a
Nothing)
addl gp :: HsGroup GhcPs
gp ((LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l d :: SrcSpanLess (LHsDecl GhcPs)
d) : ds :: [LHsDecl GhcPs]
ds) = HsGroup GhcPs
-> SrcSpan
-> HsDecl GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
add HsGroup GhcPs
gp SrcSpan
l SrcSpanLess (LHsDecl GhcPs)
HsDecl GhcPs
d [LHsDecl GhcPs]
ds


add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
    -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))

-- #10047: Declaration QuasiQuoters are expanded immediately, without
--         causing a group split
add :: HsGroup GhcPs
-> SrcSpan
-> HsDecl GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
add gp :: HsGroup GhcPs
gp _ (SpliceD _ (SpliceDecl _ (Located (HsSplice GhcPs)
-> Located (SrcSpanLess (Located (HsSplice GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ qq :: SrcSpanLess (Located (HsSplice GhcPs))
qq@HsQuasiQuote{}) _)) ds :: [LHsDecl GhcPs]
ds
  = do { (ds' :: [LHsDecl GhcPs]
ds', _) <- HsSplice GhcPs -> RnM ([LHsDecl GhcPs], NameSet)
rnTopSpliceDecls SrcSpanLess (Located (HsSplice GhcPs))
HsSplice GhcPs
qq
       ; HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl HsGroup GhcPs
gp ([LHsDecl GhcPs]
ds' [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
ds)
       }

add gp :: HsGroup GhcPs
gp loc :: SrcSpan
loc (SpliceD _ splice :: SpliceDecl GhcPs
splice@(SpliceDecl _ _ flag :: SpliceExplicitFlag
flag)) ds :: [LHsDecl GhcPs]
ds
  = do { -- We've found a top-level splice.  If it is an *implicit* one
         -- (i.e. a naked top level expression)
         case SpliceExplicitFlag
flag of
           ExplicitSplice -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           ImplicitSplice -> do { Bool
th_on <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TemplateHaskell
                                ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
th_on (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                                  SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWith SDoc
badImplicitSplice }

       ; (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsGroup GhcPs
gp, (SpliceDecl GhcPs, [LHsDecl GhcPs])
-> Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
forall a. a -> Maybe a
Just (SpliceDecl GhcPs
splice, [LHsDecl GhcPs]
ds)) }
  where
    badImplicitSplice :: SDoc
badImplicitSplice = String -> SDoc
text "Parse error: module header, import declaration"
                     SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "or top-level declaration expected."
                     -- The compiler should suggest the above, and not using
                     -- TemplateHaskell since the former suggestion is more
                     -- relevant to the larger base of users.
                     -- See Trac #12146 for discussion.

-- Class declarations: pull out the fixity signatures to the top
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup GhcPs]
ts, hs_fixds :: forall p. HsGroup p -> [LFixitySig p]
hs_fixds = [LFixitySig GhcPs]
fs}) l :: SrcSpan
l (TyClD _ d :: TyClDecl GhcPs
d) ds :: [LHsDecl GhcPs]
ds
  | TyClDecl GhcPs -> Bool
forall pass. TyClDecl pass -> Bool
isClassDecl TyClDecl GhcPs
d
  = let fsigs :: [LFixitySig GhcPs]
fsigs = [ SrcSpan -> SrcSpanLess (LFixitySig GhcPs) -> LFixitySig GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LFixitySig GhcPs)
FixitySig GhcPs
f
                | (LSig GhcPs -> Located (SrcSpanLess (LSig GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l (FixSig _ f)) <- TyClDecl GhcPs -> [LSig GhcPs]
forall pass. TyClDecl pass -> [LSig pass]
tcdSigs TyClDecl GhcPs
d ] in
    HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_tyclds :: [TyClGroup GhcPs]
hs_tyclds = LTyClDecl GhcPs -> [TyClGroup GhcPs] -> [TyClGroup GhcPs]
forall (p :: Pass).
LTyClDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_tycld (SrcSpan -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LTyClDecl GhcPs)
TyClDecl GhcPs
d) [TyClGroup GhcPs]
ts, hs_fixds :: [LFixitySig GhcPs]
hs_fixds = [LFixitySig GhcPs]
fsigs [LFixitySig GhcPs] -> [LFixitySig GhcPs] -> [LFixitySig GhcPs]
forall a. [a] -> [a] -> [a]
++ [LFixitySig GhcPs]
fs}) [LHsDecl GhcPs]
ds
  | Bool
otherwise
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_tyclds :: [TyClGroup GhcPs]
hs_tyclds = LTyClDecl GhcPs -> [TyClGroup GhcPs] -> [TyClGroup GhcPs]
forall (p :: Pass).
LTyClDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_tycld (SrcSpan -> SrcSpanLess (LTyClDecl GhcPs) -> LTyClDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LTyClDecl GhcPs)
TyClDecl GhcPs
d) [TyClGroup GhcPs]
ts }) [LHsDecl GhcPs]
ds

-- Signatures: fixity sigs go a different place than all others
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_fixds :: forall p. HsGroup p -> [LFixitySig p]
hs_fixds = [LFixitySig GhcPs]
ts}) l :: SrcSpan
l (SigD _ (FixSig _ f :: FixitySig GhcPs
f)) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp {hs_fixds :: [LFixitySig GhcPs]
hs_fixds = SrcSpan -> SrcSpanLess (LFixitySig GhcPs) -> LFixitySig GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LFixitySig GhcPs)
FixitySig GhcPs
f LFixitySig GhcPs -> [LFixitySig GhcPs] -> [LFixitySig GhcPs]
forall a. a -> [a] -> [a]
: [LFixitySig GhcPs]
ts}) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds = HsValBinds GhcPs
ts}) l :: SrcSpan
l (SigD _ d :: Sig GhcPs
d) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp {hs_valds :: HsValBinds GhcPs
hs_valds = LSig GhcPs -> HsValBinds GhcPs -> HsValBinds GhcPs
forall (a :: Pass).
LSig (GhcPass a)
-> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig (SrcSpan -> SrcSpanLess (LSig GhcPs) -> LSig GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LSig GhcPs)
Sig GhcPs
d) HsValBinds GhcPs
ts}) [LHsDecl GhcPs]
ds

-- Value declarations: use add_bind
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds  = HsValBinds GhcPs
ts}) l :: SrcSpan
l (ValD _ d :: HsBind GhcPs
d) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_valds :: HsValBinds GhcPs
hs_valds = LHsBindLR GhcPs GhcPs -> HsValBinds GhcPs -> HsValBinds GhcPs
forall a. LHsBind a -> HsValBinds a -> HsValBinds a
add_bind (SrcSpan
-> SrcSpanLess (LHsBindLR GhcPs GhcPs) -> LHsBindLR GhcPs GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsBindLR GhcPs GhcPs)
HsBind GhcPs
d) HsValBinds GhcPs
ts }) [LHsDecl GhcPs]
ds

-- Role annotations: added to the TyClGroup
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup GhcPs]
ts}) l :: SrcSpan
l (RoleAnnotD _ d :: RoleAnnotDecl GhcPs
d) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_tyclds :: [TyClGroup GhcPs]
hs_tyclds = LRoleAnnotDecl GhcPs -> [TyClGroup GhcPs] -> [TyClGroup GhcPs]
forall (p :: Pass).
LRoleAnnotDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_role_annot (SrcSpan
-> SrcSpanLess (LRoleAnnotDecl GhcPs) -> LRoleAnnotDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LRoleAnnotDecl GhcPs)
RoleAnnotDecl GhcPs
d) [TyClGroup GhcPs]
ts }) [LHsDecl GhcPs]
ds

-- NB instance declarations go into TyClGroups. We throw them into the first
-- group, just as we do for the TyClD case. The renamer will go on to group
-- and order them later.
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup GhcPs]
ts})  l :: SrcSpan
l (InstD _ d :: InstDecl GhcPs
d) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_tyclds :: [TyClGroup GhcPs]
hs_tyclds = LInstDecl GhcPs -> [TyClGroup GhcPs] -> [TyClGroup GhcPs]
forall (p :: Pass).
LInstDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_instd (SrcSpan -> SrcSpanLess (LInstDecl GhcPs) -> LInstDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LInstDecl GhcPs)
InstDecl GhcPs
d) [TyClGroup GhcPs]
ts }) [LHsDecl GhcPs]
ds

-- The rest are routine
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_derivds :: forall p. HsGroup p -> [LDerivDecl p]
hs_derivds = [LDerivDecl GhcPs]
ts})  l :: SrcSpan
l (DerivD _ d :: DerivDecl GhcPs
d) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_derivds :: [LDerivDecl GhcPs]
hs_derivds = SrcSpan -> SrcSpanLess (LDerivDecl GhcPs) -> LDerivDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LDerivDecl GhcPs)
DerivDecl GhcPs
d LDerivDecl GhcPs -> [LDerivDecl GhcPs] -> [LDerivDecl GhcPs]
forall a. a -> [a] -> [a]
: [LDerivDecl GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_defds :: forall p. HsGroup p -> [LDefaultDecl p]
hs_defds  = [LDefaultDecl GhcPs]
ts})  l :: SrcSpan
l (DefD _ d :: DefaultDecl GhcPs
d) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_defds :: [LDefaultDecl GhcPs]
hs_defds = SrcSpan -> SrcSpanLess (LDefaultDecl GhcPs) -> LDefaultDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LDefaultDecl GhcPs)
DefaultDecl GhcPs
d LDefaultDecl GhcPs -> [LDefaultDecl GhcPs] -> [LDefaultDecl GhcPs]
forall a. a -> [a] -> [a]
: [LDefaultDecl GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_fords :: forall p. HsGroup p -> [LForeignDecl p]
hs_fords  = [LForeignDecl GhcPs]
ts}) l :: SrcSpan
l (ForD _ d :: ForeignDecl GhcPs
d) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_fords :: [LForeignDecl GhcPs]
hs_fords = SrcSpan -> SrcSpanLess (LForeignDecl GhcPs) -> LForeignDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LForeignDecl GhcPs)
ForeignDecl GhcPs
d LForeignDecl GhcPs -> [LForeignDecl GhcPs] -> [LForeignDecl GhcPs]
forall a. a -> [a] -> [a]
: [LForeignDecl GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_warnds :: forall p. HsGroup p -> [LWarnDecls p]
hs_warnds  = [LWarnDecls GhcPs]
ts})  l :: SrcSpan
l (WarningD _ d :: WarnDecls GhcPs
d) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_warnds :: [LWarnDecls GhcPs]
hs_warnds = SrcSpan -> SrcSpanLess (LWarnDecls GhcPs) -> LWarnDecls GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LWarnDecls GhcPs)
WarnDecls GhcPs
d LWarnDecls GhcPs -> [LWarnDecls GhcPs] -> [LWarnDecls GhcPs]
forall a. a -> [a] -> [a]
: [LWarnDecls GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_annds :: forall p. HsGroup p -> [LAnnDecl p]
hs_annds  = [LAnnDecl GhcPs]
ts}) l :: SrcSpan
l (AnnD _ d :: AnnDecl GhcPs
d) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_annds :: [LAnnDecl GhcPs]
hs_annds = SrcSpan -> SrcSpanLess (LAnnDecl GhcPs) -> LAnnDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LAnnDecl GhcPs)
AnnDecl GhcPs
d LAnnDecl GhcPs -> [LAnnDecl GhcPs] -> [LAnnDecl GhcPs]
forall a. a -> [a] -> [a]
: [LAnnDecl GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds  = [LRuleDecls GhcPs]
ts}) l :: SrcSpan
l (RuleD _ d :: RuleDecls GhcPs
d) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_ruleds :: [LRuleDecls GhcPs]
hs_ruleds = SrcSpan -> SrcSpanLess (LRuleDecls GhcPs) -> LRuleDecls GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LRuleDecls GhcPs)
RuleDecls GhcPs
d LRuleDecls GhcPs -> [LRuleDecls GhcPs] -> [LRuleDecls GhcPs]
forall a. a -> [a] -> [a]
: [LRuleDecls GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp l :: SrcSpan
l (DocD _ d :: DocDecl
d) ds :: [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_docs :: [LDocDecl]
hs_docs = (SrcSpan -> SrcSpanLess LDocDecl -> LDocDecl
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess LDocDecl
DocDecl
d) LDocDecl -> [LDocDecl] -> [LDocDecl]
forall a. a -> [a] -> [a]
: (HsGroup GhcPs -> [LDocDecl]
forall p. HsGroup p -> [LDocDecl]
hs_docs HsGroup GhcPs
gp) })  [LHsDecl GhcPs]
ds
add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = String
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
forall a. String -> a
panic "RnSource.add"
add (HsGroup {}) _ (XHsDecl _)                 _ = String
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
forall a. String -> a
panic "RnSource.add"
add (XHsGroup _) _ _                           _ = String
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
forall a. String -> a
panic "RnSource.add"

add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
          -> [TyClGroup (GhcPass p)]
add_tycld :: LTyClDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_tycld d :: LTyClDecl (GhcPass p)
d []       = [TyClGroup :: forall pass.
XCTyClGroup pass
-> [LTyClDecl pass]
-> [LRoleAnnotDecl pass]
-> [LInstDecl pass]
-> TyClGroup pass
TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext    = XCTyClGroup (GhcPass p)
NoExt
noExt
                                  , group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = [LTyClDecl (GhcPass p)
d]
                                  , group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles  = []
                                  , group_instds :: [LInstDecl (GhcPass p)]
group_instds = []
                                  }
                       ]
add_tycld d :: LTyClDecl (GhcPass p)
d (ds :: TyClGroup (GhcPass p)
ds@(TyClGroup { group_tyclds :: forall pass. TyClGroup pass -> [LTyClDecl pass]
group_tyclds = [LTyClDecl (GhcPass p)]
tyclds }):dss :: [TyClGroup (GhcPass p)]
dss)
  = TyClGroup (GhcPass p)
ds { group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = LTyClDecl (GhcPass p)
d LTyClDecl (GhcPass p)
-> [LTyClDecl (GhcPass p)] -> [LTyClDecl (GhcPass p)]
forall a. a -> [a] -> [a]
: [LTyClDecl (GhcPass p)]
tyclds } TyClGroup (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
dss
add_tycld _ (XTyClGroup _: _) = String -> [TyClGroup (GhcPass p)]
forall a. String -> a
panic "add_tycld"

add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
          -> [TyClGroup (GhcPass p)]
add_instd :: LInstDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_instd d :: LInstDecl (GhcPass p)
d []       = [TyClGroup :: forall pass.
XCTyClGroup pass
-> [LTyClDecl pass]
-> [LRoleAnnotDecl pass]
-> [LInstDecl pass]
-> TyClGroup pass
TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext    = XCTyClGroup (GhcPass p)
NoExt
noExt
                                  , group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = []
                                  , group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles  = []
                                  , group_instds :: [LInstDecl (GhcPass p)]
group_instds = [LInstDecl (GhcPass p)
d]
                                  }
                       ]
add_instd d :: LInstDecl (GhcPass p)
d (ds :: TyClGroup (GhcPass p)
ds@(TyClGroup { group_instds :: forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds = [LInstDecl (GhcPass p)]
instds }):dss :: [TyClGroup (GhcPass p)]
dss)
  = TyClGroup (GhcPass p)
ds { group_instds :: [LInstDecl (GhcPass p)]
group_instds = LInstDecl (GhcPass p)
d LInstDecl (GhcPass p)
-> [LInstDecl (GhcPass p)] -> [LInstDecl (GhcPass p)]
forall a. a -> [a] -> [a]
: [LInstDecl (GhcPass p)]
instds } TyClGroup (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
dss
add_instd _ (XTyClGroup _: _) = String -> [TyClGroup (GhcPass p)]
forall a. String -> a
panic "add_instd"

add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
               -> [TyClGroup (GhcPass p)]
add_role_annot :: LRoleAnnotDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_role_annot d :: LRoleAnnotDecl (GhcPass p)
d [] = [TyClGroup :: forall pass.
XCTyClGroup pass
-> [LTyClDecl pass]
-> [LRoleAnnotDecl pass]
-> [LInstDecl pass]
-> TyClGroup pass
TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext    = XCTyClGroup (GhcPass p)
NoExt
noExt
                                 , group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = []
                                 , group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles  = [LRoleAnnotDecl (GhcPass p)
d]
                                 , group_instds :: [LInstDecl (GhcPass p)]
group_instds = []
                                 }
                      ]
add_role_annot d :: LRoleAnnotDecl (GhcPass p)
d (tycls :: TyClGroup (GhcPass p)
tycls@(TyClGroup { group_roles :: forall pass. TyClGroup pass -> [LRoleAnnotDecl pass]
group_roles = [LRoleAnnotDecl (GhcPass p)]
roles }) : rest :: [TyClGroup (GhcPass p)]
rest)
  = TyClGroup (GhcPass p)
tycls { group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles = LRoleAnnotDecl (GhcPass p)
d LRoleAnnotDecl (GhcPass p)
-> [LRoleAnnotDecl (GhcPass p)] -> [LRoleAnnotDecl (GhcPass p)]
forall a. a -> [a] -> [a]
: [LRoleAnnotDecl (GhcPass p)]
roles } TyClGroup (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
rest
add_role_annot _ (XTyClGroup _: _) = String -> [TyClGroup (GhcPass p)]
forall a. String -> a
panic "add_role_annot"

add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b :: LHsBind a
b (ValBinds x :: XValBinds a a
x bs :: LHsBindsLR a a
bs sigs :: [LSig a]
sigs) = XValBinds a a -> LHsBindsLR a a -> [LSig a] -> HsValBinds a
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds a a
x (LHsBindsLR a a
bs LHsBindsLR a a -> LHsBind a -> LHsBindsLR a a
forall a. Bag a -> a -> Bag a
`snocBag` LHsBind a
b) [LSig a]
sigs
add_bind _ (XValBindsLR {})     = String -> HsValBinds a
forall a. String -> a
panic "RdrHsSyn:add_bind"

add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig :: LSig (GhcPass a)
-> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig s :: LSig (GhcPass a)
s (ValBinds x :: XValBinds (GhcPass a) (GhcPass a)
x bs :: LHsBindsLR (GhcPass a) (GhcPass a)
bs sigs :: [LSig (GhcPass a)]
sigs) = XValBinds (GhcPass a) (GhcPass a)
-> LHsBindsLR (GhcPass a) (GhcPass a)
-> [LSig (GhcPass a)]
-> HsValBinds (GhcPass a)
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds (GhcPass a) (GhcPass a)
x LHsBindsLR (GhcPass a) (GhcPass a)
bs (LSig (GhcPass a)
sLSig (GhcPass a) -> [LSig (GhcPass a)] -> [LSig (GhcPass a)]
forall a. a -> [a] -> [a]
:[LSig (GhcPass a)]
sigs)
add_sig _ (XValBindsLR {})     = String -> HsValBinds (GhcPass a)
forall a. String -> a
panic "RdrHsSyn:add_sig"