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

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

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

Main pass of renamer
-}

module GHC.Rename.Module (
        rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt
    ) where

import GHC.Prelude

import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )
import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )

import GHC.Hs
import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.Name.Reader
import GHC.Rename.HsType
import GHC.Rename.Bind
import GHC.Rename.Doc
import GHC.Rename.Env
import GHC.Rename.Utils ( mapFvRn, bindLocalNames
                        , checkDupRdrNamesN, bindLocalNamesFV
                        , checkShadowedRdrNames, warnUnusedTypePatterns
                        , newLocalBndrsRn
                        , noNestedForallsContextsErr
                        , addNoNestedForallsContextsErr, checkInferredVars, warnForallIdentifier )
import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) )
import GHC.Rename.Names
import GHC.Tc.Errors.Types
import GHC.Tc.Errors.Ppr (withHsDocContext, pprScopeError )
import GHC.Tc.Gen.Annotation ( annCtxt )
import GHC.Tc.Utils.Monad

import GHC.Types.ForeignCall ( CCallTarget(..) )
import GHC.Unit
import GHC.Unit.Module.Warnings
import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName
                        , monadClassName, returnMName, thenMName
                        , semigroupClassName, sappendName
                        , monoidClassName, mappendName
                        )
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.Avail
import GHC.Utils.Outputable
import GHC.Data.Bag
import GHC.Types.Basic  ( pprRuleName, TypeOrKind(..) )
import GHC.Data.FastString
import GHC.Types.SrcLoc as SrcLoc
import GHC.Driver.Session
import GHC.Utils.Misc   ( lengthExceeds, partitionWith )
import GHC.Utils.Panic
import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses )
import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
                               , stronglyConnCompFromEdgedVerticesUniq )
import GHC.Types.Unique.Set
import GHC.Data.OrdList
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, mapMaybe )
import qualified Data.Set as Set ( difference, fromList, toList, null )
import Data.Function ( on )

{- | @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 p]
hs_docs    = [LDocDecl GhcPs]
docs })
 = do {
   -- (A) Process the top-level fixity declarations, creating a mapping from
   --     FastStrings to FixItems. Also checks for duplicates.
   --     See Note [Top-level fixity signatures in an HsGroup] in GHC.Hs.Decls
   MiniFixityEnv
local_fix_env <- [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv forall a b. (a -> b) -> a -> b
$ forall (p :: Pass). HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)]
hsGroupTopLevelFixitySigs HsGroup GhcPs
group ;

   -- (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
   --
   ((TcGblEnv, TcLclEnv)
tc_envs, FreeVars
tc_bndrs) <- MiniFixityEnv
-> HsGroup GhcPs -> RnM ((TcGblEnv, TcLclEnv), FreeVars)
getLocalNonValBinders MiniFixityEnv
local_fix_env HsGroup GhcPs
group ;


   forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv, TcLclEnv)
tc_envs 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 (#9889)

   DuplicateRecordFields
dup_fields_ok <- DynFlags -> DuplicateRecordFields
xopt_DuplicateRecordFields forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags ;
   FieldSelectors
has_sel <- DynFlags -> FieldSelectors
xopt_FieldSelectors forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags ;
   forall a.
DuplicateRecordFields
-> FieldSelectors
-> HsValBinds GhcPs
-> MiniFixityEnv
-> ([Name] -> TcRnIf TcGblEnv TcLclEnv a)
-> TcRnIf TcGblEnv TcLclEnv a
extendPatSynEnv DuplicateRecordFields
dup_fields_ok FieldSelectors
has_sel HsValBinds GhcPs
val_decls MiniFixityEnv
local_fix_env forall a b. (a -> b) -> a -> b
$ \[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.

   -- We need to throw an error on such value bindings when in a boot file.
   Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig ;
   HsValBindsLR GhcRn GhcPs
new_lhs <- if Bool
is_boot
    then MiniFixityEnv -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnTopBindsLHSBoot MiniFixityEnv
local_fix_env HsValBinds GhcPs
val_decls
    else 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 = forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectHsIdBinders forall p. CollectFlag p
CollNoDictBinders HsValBindsLR GhcRn GhcPs
new_lhs } ;
                    -- Excludes pattern-synonym binders
                    -- They are already in scope
   String -> SDoc -> TcRn ()
traceRn String
"rnSrcDecls" (forall a. Outputable a => a -> SDoc
ppr [IdP GhcRn]
id_bndrs) ;
   (TcGblEnv, TcLclEnv)
tc_envs <- [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn (forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail [IdP GhcRn]
id_bndrs) MiniFixityEnv
local_fix_env ;
   forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv, TcLclEnv)
tc_envs 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 String
"Start rnTyClDecls" (forall a. Outputable a => a -> SDoc
ppr [TyClGroup GhcPs]
tycl_decls) ;
   ([TyClGroup GhcRn]
rn_tycl_decls, FreeVars
src_fvs1) <- [TyClGroup GhcPs] -> RnM ([TyClGroup GhcRn], FreeVars)
rnTyClDecls [TyClGroup GhcPs]
tycl_decls ;

   -- (F) Rename Value declarations right-hand sides
   String -> SDoc -> TcRn ()
traceRn String
"Start rnmono" SDoc
empty ;
   let { val_bndr_set :: FreeVars
val_bndr_set = [Name] -> FreeVars
mkNameSet [IdP GhcRn]
id_bndrs FreeVars -> FreeVars -> FreeVars
`unionNameSet` [Name] -> FreeVars
mkNameSet [Name]
pat_syn_bndrs } ;
   (HsValBinds GhcRn
rn_val_decls, 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 FreeVars
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnTopBindsBoot FreeVars
tc_bndrs HsValBindsLR GhcRn GhcPs
new_lhs
    else HsSigCtxt
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnValBindsRHS (FreeVars -> HsSigCtxt
TopSigCtxt FreeVars
val_bndr_set) HsValBindsLR GhcRn GhcPs
new_lhs ;
   String -> SDoc -> TcRn ()
traceRn String
"finish rnmono" (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 :: FreeVars
all_bndrs = FreeVars
tc_bndrs FreeVars -> FreeVars -> FreeVars
`unionNameSet` FreeVars
val_bndr_set } ;
   [GenLocated SrcSpanAnnA (FixitySig GhcRn)]
rn_fix_decls <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
rnSrcFixityDecl (FreeVars -> HsSigCtxt
TopSigCtxt FreeVars
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 GhcRn
rn_warns <- FreeVars -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn)
rnSrcWarnDecls FreeVars
all_bndrs [LWarnDecls GhcPs]
warn_decls ;

   -- (H) Rename Everything else

   ([LocatedA (RuleDecls GhcRn)]
rn_rule_decls,    FreeVars
src_fvs2) <- forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.ScopedTypeVariables forall a b. (a -> b) -> a -> b
$
                                   forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
rnHsRuleDecls [LRuleDecls GhcPs]
rule_decls ;
                           -- Inside RULES, scoped type variables are on
   ([LocatedA (ForeignDecl GhcRn)]
rn_foreign_decls, FreeVars
src_fvs3) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
rnHsForeignDecl [LForeignDecl GhcPs]
foreign_decls ;
   ([LocatedA (AnnDecl GhcRn)]
rn_ann_decls,     FreeVars
src_fvs4) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl       [LAnnDecl GhcPs]
ann_decls ;
   ([LocatedA (DefaultDecl GhcRn)]
rn_default_decls, FreeVars
src_fvs5) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
rnDefaultDecl   [LDefaultDecl GhcPs]
default_decls ;
   ([LocatedA (DerivDecl GhcRn)]
rn_deriv_decls,   FreeVars
src_fvs6) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
rnSrcDerivDecl  [LDerivDecl GhcPs]
deriv_decls ;
   ([LocatedA (SpliceDecl GhcRn)]
rn_splice_decls,  FreeVars
src_fvs7) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
rnSpliceDecl    [LSpliceDecl GhcPs]
splice_decls ;
   [GenLocated SrcSpanAnnA (DocDecl GhcRn)]
rn_docs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LDocDecl GhcPs -> RnM (LDocDecl GhcRn)
rnLDocDecl [LDocDecl GhcPs]
docs ;

   TcGblEnv
last_tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv ;
   -- (I) Compute the results and return
   let {rn_group :: HsGroup GhcRn
rn_group = HsGroup { hs_ext :: XCHsGroup GhcRn
hs_ext     = NoExtField
noExtField,
                             hs_valds :: HsValBinds GhcRn
hs_valds   = HsValBinds GhcRn
rn_val_decls,
                             hs_splcds :: [LSpliceDecl GhcRn]
hs_splcds  = [LocatedA (SpliceDecl GhcRn)]
rn_splice_decls,
                             hs_tyclds :: [TyClGroup GhcRn]
hs_tyclds  = [TyClGroup GhcRn]
rn_tycl_decls,
                             hs_derivds :: [LDerivDecl GhcRn]
hs_derivds = [LocatedA (DerivDecl GhcRn)]
rn_deriv_decls,
                             hs_fixds :: [LFixitySig GhcRn]
hs_fixds   = [GenLocated SrcSpanAnnA (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 :: [LForeignDecl GhcRn]
hs_fords  = [LocatedA (ForeignDecl GhcRn)]
rn_foreign_decls,
                             hs_annds :: [LAnnDecl GhcRn]
hs_annds  = [LocatedA (AnnDecl GhcRn)]
rn_ann_decls,
                             hs_defds :: [LDefaultDecl GhcRn]
hs_defds  = [LocatedA (DefaultDecl GhcRn)]
rn_default_decls,
                             hs_ruleds :: [LRuleDecls GhcRn]
hs_ruleds = [LocatedA (RuleDecls GhcRn)]
rn_rule_decls,
                             hs_docs :: [LDocDecl GhcRn]
hs_docs   = [GenLocated SrcSpanAnnA (DocDecl GhcRn)]
rn_docs } ;

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

        src_dus :: DefUses
src_dus = forall a. a -> OrdList a
unitOL (Maybe FreeVars, FreeVars)
other_def DefUses -> DefUses -> DefUses
`plusDU` DefUses
bind_dus DefUses -> DefUses -> DefUses
`plusDU` FreeVars -> DefUses
usesOnly FreeVars
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 GhcRn
tcg_warns = TcGblEnv -> Warnings GhcRn
tcg_warns TcGblEnv
tcg_env' forall p. Warnings p -> Warnings p -> Warnings p
`plusWarns` Warnings GhcRn
rn_warns };
       } ;
   String -> SDoc -> TcRn ()
traceRn String
"finish rnSrc" (forall a. Outputable a => a -> SDoc
ppr HsGroup GhcRn
rn_group) ;
   String -> SDoc -> TcRn ()
traceRn String
"finish Dus" (forall a. Outputable a => a -> SDoc
ppr DefUses
src_dus ) ;
   forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
final_tcg_env, HsGroup GhcRn
rn_group)
                    }}}}

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 TcGblEnv
tcg_env 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)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList :: forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList a -> RnM (b, FreeVars)
f [LocatedA a]
xs = forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA a -> RnM (b, FreeVars)
f) [LocatedA a]
xs

{-
*********************************************************
*                                                       *
        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 GhcRn)
rnSrcWarnDecls :: FreeVars -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn)
rnSrcWarnDecls FreeVars
_ []
  = forall (m :: * -> *) a. Monad m => a -> m a
return forall pass. Warnings pass
NoWarnings

rnSrcWarnDecls FreeVars
bndr_set [LWarnDecls GhcPs]
decls'
  = do { -- check for duplicates
       ; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ NonEmpty (GenLocated SrcSpanAnnN RdrName)
dups -> let ((L SrcSpanAnnN
loc RdrName
rdr) :| (GenLocated SrcSpanAnnN RdrName
lrdr':[GenLocated SrcSpanAnnN RdrName]
_)) = NonEmpty (GenLocated SrcSpanAnnN RdrName)
dups
                          in SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc) (GenLocated SrcSpanAnnN RdrName -> RdrName -> TcRnMessage
TcRnDuplicateWarningDecls GenLocated SrcSpanAnnN RdrName
lrdr' RdrName
rdr))
               [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
warn_rdr_dups
       ; [[(OccName, WarningTxt GhcRn)]]
pairs_s <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA WarnDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt GhcRn)]
rn_deprec) [GenLocated SrcSpanAnnA (WarnDecl GhcPs)]
decls
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. [(OccName, WarningTxt pass)] -> Warnings pass
WarnSome ((forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(OccName, WarningTxt GhcRn)]]
pairs_s))) }
 where
   decls :: [GenLocated SrcSpanAnnA (WarnDecl GhcPs)]
decls = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall pass. WarnDecls pass -> [LWarnDecl pass]
wd_warnings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LWarnDecls GhcPs]
decls'

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

   rn_deprec :: WarnDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt GhcRn)]
rn_deprec (Warning XWarning GhcPs
_ [LIdP GhcPs]
rdr_names WarningTxt GhcPs
txt)
       -- ensures that the names are defined locally
     = do { [(RdrName, Name)]
names <- 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
                                [LIdP GhcPs]
rdr_names
          ; WarningTxt GhcRn
txt' <- WarningTxt GhcPs -> RnM (WarningTxt GhcRn)
rnWarningTxt WarningTxt GhcPs
txt
          ; forall (m :: * -> *) a. Monad m => a -> m a
return [(RdrName -> OccName
rdrNameOcc RdrName
rdr, WarningTxt GhcRn
txt') | (RdrName
rdr, Name
_) <- [(RdrName, Name)]
names] }

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

   warn_rdr_dups :: [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
warn_rdr_dups = [GenLocated SrcSpanAnnN RdrName]
-> [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
findDupRdrNames
                   forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(L SrcSpanAnnA
_ (Warning XWarning GhcPs
_ [LIdP GhcPs]
ns WarningTxt GhcPs
_)) -> [LIdP GhcPs]
ns) [GenLocated SrcSpanAnnA (WarnDecl GhcPs)]
decls

rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)
rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)
rnWarningTxt (WarningTxt Located SourceText
st [Located (WithHsDocIdentifiers StringLiteral GhcPs)]
wst) = do
  [GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn)]
wst' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a.
WithHsDocIdentifiers a GhcPs -> RnM (WithHsDocIdentifiers a GhcRn)
rnHsDoc) [Located (WithHsDocIdentifiers StringLiteral GhcPs)]
wst
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall pass.
Located SourceText
-> [Located (WithHsDocIdentifiers StringLiteral pass)]
-> WarningTxt pass
WarningTxt Located SourceText
st [GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn)]
wst')
rnWarningTxt (DeprecatedTxt Located SourceText
st [Located (WithHsDocIdentifiers StringLiteral GhcPs)]
wst) = do
  [GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn)]
wst' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a.
WithHsDocIdentifiers a GhcPs -> RnM (WithHsDocIdentifiers a GhcRn)
rnHsDoc) [Located (WithHsDocIdentifiers StringLiteral GhcPs)]
wst
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall pass.
Located SourceText
-> [Located (WithHsDocIdentifiers StringLiteral pass)]
-> WarningTxt pass
DeprecatedTxt Located SourceText
st [GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn)]
wst')


findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)]
findDupRdrNames :: [GenLocated SrcSpanAnnN RdrName]
-> [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
findDupRdrNames = forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (\ GenLocated SrcSpanAnnN RdrName
x -> \ GenLocated SrcSpanAnnN RdrName
y -> RdrName -> OccName
rdrNameOcc (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
x) forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN 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

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

rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl ann :: AnnDecl GhcPs
ann@(HsAnnotation XHsAnnotation GhcPs
_ SourceText
s AnnProvenance GhcPs
provenance XRec GhcPs (HsExpr GhcPs)
expr)
  = forall a. SDoc -> TcM a -> TcM a
addErrCtxt (forall (p :: Pass).
OutputableBndrId p =>
AnnDecl (GhcPass p) -> SDoc
annCtxt AnnDecl GhcPs
ann) forall a b. (a -> b) -> a -> b
$
    do { (AnnProvenance GhcRn
provenance', FreeVars
provenance_fvs) <- AnnProvenance GhcPs -> RnM (AnnProvenance GhcRn, FreeVars)
rnAnnProvenance AnnProvenance GhcPs
provenance
       ; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
expr_fvs) <- forall a. ThStage -> TcM a -> TcM a
setStage (SpliceType -> ThStage
Splice SpliceType
Untyped) forall a b. (a -> b) -> a -> b
$
                              XRec GhcPs (HsExpr GhcPs) -> TcRn (LHsExpr GhcRn, FreeVars)
rnLExpr XRec GhcPs (HsExpr GhcPs)
expr
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XHsAnnotation pass
-> SourceText
-> AnnProvenance pass
-> XRec pass (HsExpr pass)
-> AnnDecl pass
HsAnnotation forall a. EpAnn a
noAnn SourceText
s AnnProvenance GhcRn
provenance' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr',
                 FreeVars
provenance_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
expr_fvs) }

rnAnnProvenance :: AnnProvenance GhcPs
                -> RnM (AnnProvenance GhcRn, FreeVars)
rnAnnProvenance :: AnnProvenance GhcPs -> RnM (AnnProvenance GhcRn, FreeVars)
rnAnnProvenance AnnProvenance GhcPs
provenance = do
    AnnProvenance GhcRn
provenance' <- case AnnProvenance GhcPs
provenance of
      ValueAnnProvenance LIdP GhcPs
n -> forall pass. LIdP pass -> AnnProvenance pass
ValueAnnProvenance
                          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
n
      TypeAnnProvenance LIdP GhcPs
n  -> forall pass. LIdP pass -> AnnProvenance pass
TypeAnnProvenance
                          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
n
      AnnProvenance GhcPs
ModuleAnnProvenance  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall pass. AnnProvenance pass
ModuleAnnProvenance
    forall (m :: * -> *) a. Monad m => a -> m a
return (AnnProvenance GhcRn
provenance', forall b a. b -> (a -> b) -> Maybe a -> b
maybe FreeVars
emptyFVs Name -> FreeVars
unitFV (forall p. UnXRec p => AnnProvenance p -> Maybe (IdP p)
annProvenanceName_maybe AnnProvenance GhcRn
provenance'))

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

rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
rnDefaultDecl (DefaultDecl XCDefaultDecl GhcPs
_ [LHsType GhcPs]
tys)
  = do { ([GenLocated SrcSpanAnnA (HsType GhcRn)]
tys', FreeVars
fvs) <- HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes HsDocContext
doc_str [LHsType GhcPs]
tys
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCDefaultDecl pass -> [LHsType pass] -> DefaultDecl pass
DefaultDecl NoExtField
noExtField [GenLocated SrcSpanAnnA (HsType GhcRn)]
tys', FreeVars
fvs) }
  where
    doc_str :: HsDocContext
doc_str = HsDocContext
DefaultDeclCtx

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

rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
rnHsForeignDecl (ForeignImport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = LIdP 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 <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; GenLocated SrcSpanAnnN RdrName -> TcRn ()
warnForallIdentifier LIdP GhcPs
name
       ; GenLocated SrcSpanAnnN Name
name' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
name
       ; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty', FreeVars
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType (GenLocated SrcSpanAnnN RdrName -> HsDocContext
ForeignDeclCtx LIdP GhcPs
name) TypeOrKind
TypeLevel LHsSigType GhcPs
ty

        -- Mark any PackageTarget style imports as coming from the current package
       ; let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
topEnv
             spec' :: ForeignImport
spec'  = Unit -> ForeignImport -> ForeignImport
patchForeignImport (HomeUnit -> Unit
homeUnitAsUnit HomeUnit
home_unit) ForeignImport
spec

       ; forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport { fd_i_ext :: XForeignImport GhcRn
fd_i_ext = NoExtField
noExtField
                               , fd_name :: LIdP GhcRn
fd_name = GenLocated SrcSpanAnnN Name
name', fd_sig_ty :: LHsSigType GhcRn
fd_sig_ty = GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty'
                               , fd_fi :: ForeignImport
fd_fi = ForeignImport
spec' }, FreeVars
fvs) }

rnHsForeignDecl (ForeignExport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = LIdP 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 { GenLocated SrcSpanAnnN Name
name' <- forall ann.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupLocatedOccRn LIdP GhcPs
name
       ; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty', FreeVars
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType (GenLocated SrcSpanAnnN RdrName -> HsDocContext
ForeignDeclCtx LIdP GhcPs
name) TypeOrKind
TypeLevel LHsSigType GhcPs
ty
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignExport { fd_e_ext :: XForeignExport GhcRn
fd_e_ext = NoExtField
noExtField
                               , fd_name :: LIdP GhcRn
fd_name = GenLocated SrcSpanAnnN Name
name', fd_sig_ty :: LHsSigType GhcRn
fd_sig_ty = GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty'
                               , fd_fe :: ForeignExport
fd_fe = ForeignExport
spec }
                , FreeVars
fvs FreeVars -> Name -> FreeVars
`addOneFV` forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN 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

-- | 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 :: Unit -> ForeignImport -> ForeignImport
patchForeignImport :: Unit -> ForeignImport -> ForeignImport
patchForeignImport Unit
unit (CImport Located CCallConv
cconv Located Safety
safety Maybe Header
fs CImportSpec
spec Located SourceText
src)
        = Located CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport Located CCallConv
cconv Located Safety
safety Maybe Header
fs (Unit -> CImportSpec -> CImportSpec
patchCImportSpec Unit
unit CImportSpec
spec) Located SourceText
src

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

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

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

rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl (TyFamInstD { tfid_inst :: forall pass. InstDecl pass -> TyFamInstDecl pass
tfid_inst = TyFamInstDecl GhcPs
tfi })
  = do { (TyFamInstDecl GhcRn
tfi', FreeVars
fvs) <- AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl (ClosedTyFamInfo -> AssocTyFamInfo
NonAssocTyFamEqn ClosedTyFamInfo
NotClosedTyFam) TyFamInstDecl GhcPs
tfi
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (TyFamInstD { tfid_ext :: XTyFamInstD GhcRn
tfid_ext = NoExtField
noExtField, tfid_inst :: TyFamInstDecl GhcRn
tfid_inst = TyFamInstDecl GhcRn
tfi' }, FreeVars
fvs) }

rnSrcInstDecl (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl GhcPs
dfi })
  = do { (DataFamInstDecl GhcRn
dfi', FreeVars
fvs) <- AssocTyFamInfo
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl (ClosedTyFamInfo -> AssocTyFamInfo
NonAssocTyFamEqn ClosedTyFamInfo
NotClosedTyFam) DataFamInstDecl GhcPs
dfi
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (DataFamInstD { dfid_ext :: XDataFamInstD GhcRn
dfid_ext = NoExtField
noExtField, dfid_inst :: DataFamInstDecl GhcRn
dfid_inst = DataFamInstDecl GhcRn
dfi' }, FreeVars
fvs) }

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

-- | 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 Name
cls LHsSigType GhcRn
poly_ty LHsBinds GhcRn
mbinds = do
    forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNonCanonicalMonadInstances
        forall a b. (a -> b) -> a -> b
$ String -> TcRn ()
checkCanonicalMonadInstances
        String
"https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"

    forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNonCanonicalMonoidInstances
        forall a b. (a -> b) -> a -> b
$ String -> TcRn ()
checkCanonicalMonoidInstances
        String
"https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"

  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 :: String -> TcRn ()
checkCanonicalMonadInstances String
refURL
      | Name
cls forall a. Eq a => a -> a -> Bool
== Name
applicativeClassName =
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
              case HsBindLR GhcRn GhcRn
mbind of
                  FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Name
name
                          , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
                      | Name
name forall a. Eq a => a -> a -> Bool
== Name
pureAName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Name
returnMName
                      -> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL
                            WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"pure" String
"return"

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

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

      | Name
cls forall a. Eq a => a -> a -> Bool
== Name
monadClassName =
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
              case HsBindLR GhcRn GhcRn
mbind of
                  FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Name
name
                          , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
                      | Name
name forall a. Eq a => a -> a -> Bool
== Name
returnMName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Name
pureAName
                      -> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL
                            WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"return" String
"pure"

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

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

      | Bool
otherwise = 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 :: String -> TcRn ()
checkCanonicalMonoidInstances String
refURL
      | Name
cls forall a. Eq a => a -> a -> Bool
== Name
semigroupClassName =
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
              case HsBindLR GhcRn GhcRn
mbind of
                  FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id      = L SrcSpanAnnN
_ Name
name
                          , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
                      | Name
name forall a. Eq a => a -> a -> Bool
== Name
sappendName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Name
mappendName
                      -> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL
                            WarningFlag
Opt_WarnNonCanonicalMonoidInstances String
"(<>)" String
"mappend"

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

      | Name
cls forall a. Eq a => a -> a -> Bool
== Name
monoidClassName =
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
              case HsBindLR GhcRn GhcRn
mbind of
                  FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Name
name
                          , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
                      | Name
name forall a. Eq a => a -> a -> Bool
== Name
mappendName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Name
sappendName
                      -> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL
                            WarningFlag
Opt_WarnNonCanonicalMonoidInstances
                            String
"mappend" String
"(<>)"

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

      | Bool
otherwise = 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 -> XRec p [LMatch p body]
mg_alts = (L SrcSpanAnnL
_ [L SrcSpanAnnA
_ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = []
                                             , m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
grhss })])}
        | GRHSs XCGRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ [L SrcAnn NoEpAnns
_ (GRHS XCGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ [] GenLocated SrcSpanAnnA (HsExpr GhcRn)
body)] HsLocalBinds GhcRn
lbinds <- GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
grhss
        , EmptyLocalBinds XEmptyLocalBinds GhcRn GhcRn
_ <- HsLocalBinds GhcRn
lbinds
        , HsVar XVar GhcRn
_ LIdP GhcRn
lrhsName  <- forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcRn)
body  = forall a. a -> Maybe a
Just (forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
lrhsName)
    isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
_ = forall a. Maybe a
Nothing

    -- got "lhs = rhs" but expected something different
    addWarnNonCanonicalMethod1 :: String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL WarningFlag
flag String
lhs String
rhs = do
        let dia :: TcRnMessage
dia = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$
              DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
flag) [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
                [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Noncanonical" SDoc -> SDoc -> SDoc
<+>
                       SDoc -> SDoc
quotes (String -> SDoc
text (String
lhs forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ String
rhs)) SDoc -> SDoc -> SDoc
<+>
                       String -> SDoc
text String
"definition detected"
                     , LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
poly_ty
                     , String -> SDoc
text String
"Move definition from" SDoc -> SDoc -> SDoc
<+>
                       SDoc -> SDoc
quotes (String -> SDoc
text String
rhs) SDoc -> SDoc -> SDoc
<+>
                       String -> SDoc
text String
"to" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
lhs)
                     , String -> SDoc
text String
"See also:" SDoc -> SDoc -> SDoc
<+>
                       String -> SDoc
text String
refURL
                     ]
        TcRnMessage -> TcRn ()
addDiagnostic TcRnMessage
dia

    -- expected "lhs = rhs" but got something else
    addWarnNonCanonicalMethod2 :: String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL WarningFlag
flag String
lhs String
rhs = do
        let dia :: TcRnMessage
dia = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$
              DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
flag) [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
                [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Noncanonical" SDoc -> SDoc -> SDoc
<+>
                       SDoc -> SDoc
quotes (String -> SDoc
text String
lhs) SDoc -> SDoc -> SDoc
<+>
                       String -> SDoc
text String
"definition detected"
                     , LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
poly_ty
                     , SDoc -> SDoc
quotes (String -> SDoc
text String
lhs) SDoc -> SDoc -> SDoc
<+>
                       String -> SDoc
text String
"will eventually be removed in favour of" SDoc -> SDoc -> SDoc
<+>
                       SDoc -> SDoc
quotes (String -> SDoc
text String
rhs)
                     , String -> SDoc
text String
"Either remove definition for" SDoc -> SDoc -> SDoc
<+>
                       SDoc -> SDoc
quotes (String -> SDoc
text String
lhs) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"(recommended)" SDoc -> SDoc -> SDoc
<+>
                       String -> SDoc
text String
"or define as" SDoc -> SDoc -> SDoc
<+>
                       SDoc -> SDoc
quotes (String -> SDoc
text (String
lhs forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ String
rhs))
                     , String -> SDoc
text String
"See also:" SDoc -> SDoc -> SDoc
<+>
                       String -> SDoc
text String
refURL
                     ]
        TcRnMessage -> TcRn ()
addDiagnostic TcRnMessage
dia

    -- stolen from GHC.Tc.TyCl.Instance
    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
hs_inst_ty
      = SDoc -> SDoc
inst_decl_ctxt (forall a. Outputable a => a -> SDoc
ppr (forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType GhcRn
hs_inst_ty))

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


rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
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 (XRec pass OverlapMode)
cid_overlap_mode = Maybe (XRec GhcPs OverlapMode)
oflag
                           , cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_datafam_insts = [LDataFamInstDecl GhcPs]
adts })
  = do { HsDocContext -> Maybe SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
ctxt Maybe SDoc
inf_err LHsSigType GhcPs
inst_ty
       ; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty', FreeVars
inst_fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType HsDocContext
ctxt TypeOrKind
TypeLevel LHsSigType GhcPs
inst_ty
       ; let ([Name]
ktv_names, Maybe (LHsContext GhcRn)
_, LHsType GhcRn
head_ty') = LHsSigType GhcRn
-> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)
splitLHsInstDeclTy GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty'
             -- Check if there are any nested `forall`s or contexts, which are
             -- illegal in the type of an instance declaration (see
             -- Note [No nested foralls or contexts in instance types] in
             -- GHC.Hs.Type)...
             mb_nested_msg :: Maybe (SrcSpan, SDoc)
mb_nested_msg = SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc)
noNestedForallsContextsErr
                               (String -> SDoc
text String
"Instance head") LHsType GhcRn
head_ty'
             -- ...then check if the instance head is actually headed by a
             -- class type constructor...
             eith_cls :: Either (SrcSpan, SDoc) Name
eith_cls = case forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
LHsType (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p)))
hsTyGetAppHead_maybe LHsType GhcRn
head_ty' of
               Just (L SrcSpanAnnN
_ IdP GhcRn
cls) -> forall a b. b -> Either a b
Right IdP GhcRn
cls
               Maybe (LocatedN (IdP GhcRn))
Nothing        -> forall a b. a -> Either a b
Left
                 ( forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsType GhcRn
head_ty'
                 , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal head of an instance declaration:"
                           SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr LHsType GhcRn
head_ty'))
                      Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Instance heads must be of the form"
                              , Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"C ty_1 ... ty_n"
                              , String -> SDoc
text String
"where" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Char -> SDoc
char Char
'C')
                                SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is a class"
                              ])
                 )
         -- ...finally, attempt to retrieve the class type constructor, failing
         -- with an error message if there isn't one. To avoid excessive
         -- amounts of error messages, we will only report one of the errors
         -- from mb_nested_msg or eith_cls at a time.
       ; Name
cls <- case (Maybe (SrcSpan, SDoc)
mb_nested_msg, Either (SrcSpan, SDoc) Name
eith_cls) of
           (Maybe (SrcSpan, SDoc)
Nothing,   Right Name
cls) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
cls
           (Just (SrcSpan, SDoc)
err1, Either (SrcSpan, SDoc) Name
_)         -> (SrcSpan, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) Name
bail_out (SrcSpan, SDoc)
err1
           (Maybe (SrcSpan, SDoc)
_,         Left (SrcSpan, SDoc)
err2) -> (SrcSpan, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) Name
bail_out (SrcSpan, SDoc)
err2

          -- 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
       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds', [GenLocated SrcSpanAnnA (Sig GhcRn)]
uprags', FreeVars
meth_fvs) <- Bool
-> Name
-> [Name]
-> LHsBinds GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)
rnMethodBinds Bool
False Name
cls [Name]
ktv_names LHsBinds GhcPs
mbinds [LSig GhcPs]
uprags

       ; Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> TcRn ()
checkCanonicalInstances Name
cls GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty' Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds'

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

       ; let all_fvs :: FreeVars
all_fvs = FreeVars
meth_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
more_fvs
                                FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
inst_fvs
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstDecl { cid_ext :: XCClsInstDecl GhcRn
cid_ext = NoExtField
noExtField
                             , cid_poly_ty :: LHsSigType GhcRn
cid_poly_ty = GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty', cid_binds :: LHsBinds GhcRn
cid_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds'
                             , cid_sigs :: [LSig GhcRn]
cid_sigs = [GenLocated SrcSpanAnnA (Sig GhcRn)]
uprags', cid_tyfam_insts :: [LTyFamInstDecl GhcRn]
cid_tyfam_insts = [LocatedA (TyFamInstDecl GhcRn)]
ats'
                             , cid_overlap_mode :: Maybe (XRec GhcRn OverlapMode)
cid_overlap_mode = Maybe (XRec GhcPs OverlapMode)
oflag
                             , cid_datafam_insts :: [LDataFamInstDecl GhcRn]
cid_datafam_insts = [LocatedA (DataFamInstDecl GhcRn)]
adts' },
                 FreeVars
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).
  where
    ctxt :: HsDocContext
ctxt    = SDoc -> HsDocContext
GenericCtx forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"an instance declaration"
    inf_err :: Maybe SDoc
inf_err = forall a. a -> Maybe a
Just (String -> SDoc
text String
"Inferred type variables are not allowed")

    -- 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 #16114).
    bail_out :: (SrcSpan, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) Name
bail_out (SrcSpan
l, SDoc
err_msg) = do
      SrcSpan -> TcRnMessage -> TcRn ()
addErrAt SrcSpan
l forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (HsDocContext -> SDoc -> SDoc
withHsDocContext HsDocContext
ctxt SDoc
err_msg)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ OccName -> Name
mkUnboundName (CLabelString -> OccName
mkTcOccFS (String -> CLabelString
fsLit String
"<class>"))

rnFamEqn :: HsDocContext
         -> AssocTyFamInfo
         -> FreeKiTyVars
         -- ^ Additional kind variables to implicitly bind if there is no
         --   explicit forall. (See the comments on @all_imp_vars@ below for a
         --   more detailed explanation.)
         -> FamEqn GhcPs rhs
         -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
         -> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn :: forall rhs rhs'.
HsDocContext
-> AssocTyFamInfo
-> [GenLocated SrcSpanAnnN RdrName]
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn HsDocContext
doc AssocTyFamInfo
atfi [GenLocated SrcSpanAnnN RdrName]
extra_kvars
    (FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon  = LIdP GhcPs
tycon
            , feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs  = HsOuterFamEqnTyVarBndrs GhcPs
outer_bndrs
            , feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_pats   = HsTyPats GhcPs
pats
            , feqn_fixity :: forall pass rhs. FamEqn pass rhs -> LexicalFixity
feqn_fixity = LexicalFixity
fixity
            , feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs    = rhs
payload }) HsDocContext -> rhs -> RnM (rhs', FreeVars)
rn_payload
  = do { GenLocated SrcSpanAnnN Name
tycon' <- Maybe Name
-> GenLocated SrcSpanAnnN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupFamInstName Maybe Name
mb_cls LIdP GhcPs
tycon

         -- all_imp_vars represent the implicitly bound type variables. This is
         -- empty if we have an explicit `forall` (see
         -- Note [forall-or-nothing rule] in GHC.Hs.Type), which means
         -- ignoring:
         --
         -- - pat_kity_vars, the free variables mentioned in the type patterns
         --   on the LHS of the equation, and
         -- - extra_kvars, which is one of the following:
         --   * For type family instances, extra_kvars are the free kind
         --     variables mentioned in an outermost kind signature on the RHS
         --     of the equation.
         --     (See Note [Implicit quantification in type synonyms] in
         --     GHC.Rename.HsType.)
         --   * For data family instances, extra_kvars are the free kind
         --     variables mentioned in the explicit return kind, if one is
         --     provided. (e.g., the `k` in `data instance T :: k -> Type`).
         --
         -- Some examples:
         --
         -- @
         -- type family F a b
         -- type instance forall a b c. F [(a, b)] c = a -> b -> c
         --   -- all_imp_vars = []
         -- type instance F [(a, b)] c = a -> b -> c
         --   -- all_imp_vars = [a, b, c]
         --
         -- type family G :: Maybe a
         -- type instance forall a. G = (Nothing :: Maybe a)
         --   -- all_imp_vars = []
         -- type instance G = (Nothing :: Maybe a)
         --   -- all_imp_vars = [a]
         --
         -- data family H :: k -> Type
         -- data instance forall k. H :: k -> Type where ...
         --   -- all_imp_vars = []
         -- data instance H :: k -> Type where ...
         --   -- all_imp_vars = [k]
         -- @
         --
         -- For associated type family instances, exclude the type variables
         -- bound by the instance head with filterInScopeM (#19649).
       ; [GenLocated SrcSpanAnnN RdrName]
all_imp_vars <- [GenLocated SrcSpanAnnN RdrName]
-> RnM [GenLocated SrcSpanAnnN RdrName]
filterInScopeM forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnN RdrName]
pat_kity_vars forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnN RdrName]
extra_kvars

       ; forall flag assoc a.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> Maybe assoc
-> [GenLocated SrcSpanAnnN RdrName]
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs HsDocContext
doc Maybe Name
mb_cls [GenLocated SrcSpanAnnN RdrName]
all_imp_vars HsOuterFamEqnTyVarBndrs GhcPs
outer_bndrs forall a b. (a -> b) -> a -> b
$ \HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs ->
    do { ([HsArg
   (GenLocated SrcSpanAnnA (HsType GhcRn))
   (GenLocated SrcSpanAnnA (HsType GhcRn))]
pats', FreeVars
pat_fvs) <- HsDocContext
-> HsTyPats GhcPs -> RnM ([LHsTypeArg GhcRn], FreeVars)
rnLHsTypeArgs (GenLocated SrcSpanAnnN RdrName -> HsDocContext
FamPatCtx LIdP GhcPs
tycon) HsTyPats GhcPs
pats
       ; (rhs'
payload', FreeVars
rhs_fvs) <- HsDocContext -> rhs -> RnM (rhs', FreeVars)
rn_payload HsDocContext
doc rhs
payload

          -- Report unused binders on the LHS
          -- See Note [Unused type variables in family instances]
       ; let -- The SrcSpan that bindHsOuterFamEqnTyVarBndrs will attach to each
             -- implicitly bound type variable Name in outer_bndrs' will
             -- span the entire type family instance, which will be reflected in
             -- -Wunused-type-patterns warnings. We can be a little more precise
             -- than that by pointing to the LHS of the instance instead, which
             -- is what lhs_loc corresponds to.
             rn_outer_bndrs' :: HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs' = forall pass flag.
(XHsOuterImplicit pass -> XHsOuterImplicit pass)
-> HsOuterTyVarBndrs flag pass -> HsOuterTyVarBndrs flag pass
mapHsOuterImplicit (forall a b. (a -> b) -> [a] -> [b]
map (Name -> SrcSpan -> Name
`setNameLoc` SrcSpan
lhs_loc))
                                                  HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs

             groups :: [NonEmpty (LocatedN RdrName)]
             groups :: [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
groups = forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses forall a l. Ord a => GenLocated l a -> GenLocated l a -> Ordering
cmpLocated [GenLocated SrcSpanAnnN RdrName]
pat_kity_vars
       ; [Name]
nms_dups <- 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) forall a b. (a -> b) -> a -> b
$
                        [ GenLocated SrcSpanAnnN RdrName
tv | (GenLocated SrcSpanAnnN RdrName
tv :| (GenLocated SrcSpanAnnN RdrName
_:[GenLocated SrcSpanAnnN RdrName]
_)) <- [NonEmpty (GenLocated SrcSpanAnnN 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 :: FreeVars
nms_used = FreeVars -> [Name] -> FreeVars
extendNameSetList FreeVars
rhs_fvs forall a b. (a -> b) -> a -> b
$
                           [Name]
nms_dups {- (a) -} forall a. [a] -> [a] -> [a]
++ [Name]
inst_head_tvs {- (b) -}
             all_nms :: [Name]
all_nms = forall flag. HsOuterTyVarBndrs flag GhcRn -> [Name]
hsOuterTyVarNames HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs'
       ; [Name] -> FreeVars -> TcRn ()
warnUnusedTypePatterns [Name]
all_nms FreeVars
nms_used

         -- For associated family instances, if a type variable from the
         -- parent instance declaration is mentioned on the RHS of the
         -- associated family instance but not bound on the LHS, then reject
         -- that type variable as being out of scope.
         -- See Note [Renaming associated types].
         -- Per that Note, the LHS type variables consist of:
         --
         -- - The variables mentioned in the instance's type patterns
         --   (pat_fvs), and
         --
         -- - The variables mentioned in an outermost kind signature on the
         --   RHS. This is a subset of `rhs_fvs`. To compute it, we look up
         --   each RdrName in `extra_kvars` to find its corresponding Name in
         --   the LocalRdrEnv.
       ; [Name]
extra_kvar_nms <- forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Name)
lookupLocalOccRn_maybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnN RdrName]
extra_kvars
       ; let lhs_bound_vars :: FreeVars
lhs_bound_vars = FreeVars
pat_fvs FreeVars -> [Name] -> FreeVars
`extendNameSetList` [Name]
extra_kvar_nms
             improperly_scoped :: Name -> Bool
improperly_scoped Name
cls_tkv =
                  Name
cls_tkv Name -> FreeVars -> Bool
`elemNameSet` FreeVars
rhs_fvs
                    -- Mentioned on the RHS...
               Bool -> Bool -> Bool
&& Bool -> Bool
not (Name
cls_tkv Name -> FreeVars -> Bool
`elemNameSet` FreeVars
lhs_bound_vars)
                    -- ...but not bound on the LHS.
             bad_tvs :: [Name]
bad_tvs = forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
improperly_scoped [Name]
inst_head_tvs
       ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
bad_tvs) ([Name] -> TcRn ()
badAssocRhs [Name]
bad_tvs)

       ; let eqn_fvs :: FreeVars
eqn_fvs = FreeVars
rhs_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
pat_fvs
             -- See Note [Type family equations and occurrences]
             all_fvs :: FreeVars
all_fvs = case AssocTyFamInfo
atfi of
                         NonAssocTyFamEqn ClosedTyFamInfo
ClosedTyFam
                           -> FreeVars
eqn_fvs
                         AssocTyFamInfo
_ -> FreeVars
eqn_fvs FreeVars -> Name -> FreeVars
`addOneFV` forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
tycon'

       ; forall (m :: * -> *) a. Monad m => a -> m a
return (FamEqn { feqn_ext :: XCFamEqn GhcRn rhs'
feqn_ext    = forall a. EpAnn a
noAnn
                        , feqn_tycon :: LIdP GhcRn
feqn_tycon  = GenLocated SrcSpanAnnN Name
tycon'
                          -- Note [Wildcards in family instances]
                        , feqn_bndrs :: HsOuterTyVarBndrs () GhcRn
feqn_bndrs  = HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs'
                        , feqn_pats :: [LHsTypeArg GhcRn]
feqn_pats   = [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcRn))
   (GenLocated SrcSpanAnnA (HsType GhcRn))]
pats'
                        , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
                        , feqn_rhs :: rhs'
feqn_rhs    = rhs'
payload' },
                 FreeVars
all_fvs) } }
  where
    -- The parent class, if we are dealing with an associated type family
    -- instance.
    mb_cls :: Maybe Name
mb_cls = case AssocTyFamInfo
atfi of
      NonAssocTyFamEqn ClosedTyFamInfo
_   -> forall a. Maybe a
Nothing
      AssocTyFamDeflt Name
cls  -> forall a. a -> Maybe a
Just Name
cls
      AssocTyFamInst Name
cls [Name]
_ -> forall a. a -> Maybe a
Just Name
cls

    -- The type variables from the instance head, if we are dealing with an
    -- associated type family instance.
    inst_head_tvs :: [Name]
inst_head_tvs = case AssocTyFamInfo
atfi of
      NonAssocTyFamEqn ClosedTyFamInfo
_             -> []
      AssocTyFamDeflt Name
_              -> []
      AssocTyFamInst Name
_ [Name]
inst_head_tvs -> [Name]
inst_head_tvs

    pat_kity_vars :: [GenLocated SrcSpanAnnN RdrName]
pat_kity_vars = HsTyPats GhcPs -> [GenLocated SrcSpanAnnN RdrName]
extractHsTyArgRdrKiTyVars HsTyPats GhcPs
pats
             -- It is crucial that extractHsTyArgRdrKiTyVars return
             -- duplicate occurrences, since they're needed to help
             -- determine unused binders on the LHS.

    -- The SrcSpan of the LHS of the instance. For example, lhs_loc would be
    -- the highlighted part in the example below:
    --
    --   type instance F a b c = Either a b
    --                   ^^^^^
    lhs_loc :: SrcSpan
lhs_loc = case forall a b. (a -> b) -> [a] -> [b]
map forall (pass :: Pass). LHsTypeArg (GhcPass pass) -> SrcSpan
lhsTypeArgSrcSpan HsTyPats GhcPs
pats forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA [GenLocated SrcSpanAnnN RdrName]
extra_kvars of
      []         -> forall a. String -> a
panic String
"rnFamEqn.lhs_loc"
      [SrcSpan
loc]      -> SrcSpan
loc
      (SrcSpan
loc:[SrcSpan]
locs) -> SrcSpan
loc SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` forall a. [a] -> a
last [SrcSpan]
locs

    badAssocRhs :: [Name] -> RnM ()
    badAssocRhs :: [Name] -> TcRn ()
badAssocRhs [Name]
ns
      = TcRnMessage -> TcRn ()
addErr forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
           (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"The RHS of an associated type declaration mentions"
                      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"out-of-scope variable" SDoc -> SDoc -> SDoc
<> forall a. [a] -> SDoc
plural [Name]
ns
                      SDoc -> SDoc -> SDoc
<+> forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (SDoc -> SDoc
quotes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr) [Name]
ns)
                   Int
2 (String -> SDoc
text String
"All such variables must be bound on the LHS"))

rnTyFamInstDecl :: AssocTyFamInfo
                -> TyFamInstDecl GhcPs
                -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl :: AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl AssocTyFamInfo
atfi (TyFamInstDecl { tfid_xtn :: forall pass. TyFamInstDecl pass -> XCTyFamInstDecl pass
tfid_xtn = XCTyFamInstDecl GhcPs
x, tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn = TyFamInstEqn GhcPs
eqn })
  = do { (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
eqn', FreeVars
fvs) <- AssocTyFamInfo
-> TyFamInstEqn GhcPs -> RnM (TyFamInstEqn GhcRn, FreeVars)
rnTyFamInstEqn AssocTyFamInfo
atfi TyFamInstEqn GhcPs
eqn
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl GhcRn
tfid_xtn = XCTyFamInstDecl GhcPs
x, tfid_eqn :: TyFamInstEqn GhcRn
tfid_eqn = FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
eqn' }, FreeVars
fvs) }

-- | Tracks whether we are renaming:
--
-- 1. A type family equation that is not associated
--    with a parent type class ('NonAssocTyFamEqn'). Examples:
--
--    @
--    type family F a
--    type instance F Int = Bool  -- NonAssocTyFamEqn NotClosed
--
--    type family G a where
--       G Int = Bool             -- NonAssocTyFamEqn Closed
--    @
--
-- 2. An associated type family default declaration ('AssocTyFamDeflt').
--    Example:
--
--    @
--    class C a where
--      type A a
--      type instance A a = a -> a  -- AssocTyFamDeflt C
--    @
--
-- 3. An associated type family instance declaration ('AssocTyFamInst').
--    Example:
--
--    @
--    instance C a => C [a] where
--      type A [a] = Bool  -- AssocTyFamInst C [a]
--    @
data AssocTyFamInfo
  = NonAssocTyFamEqn
      ClosedTyFamInfo -- Is this a closed type family?
  | AssocTyFamDeflt
      Name            -- Name of the parent class
  | AssocTyFamInst
      Name            -- Name of the parent class
      [Name]          -- Names of the tyvars of the parent instance decl

-- | Tracks whether we are renaming an equation in a closed type family
-- equation ('ClosedTyFam') or not ('NotClosedTyFam').
data ClosedTyFamInfo
  = NotClosedTyFam
  | ClosedTyFam

rnTyFamInstEqn :: AssocTyFamInfo
               -> TyFamInstEqn GhcPs
               -> RnM (TyFamInstEqn GhcRn, FreeVars)
rnTyFamInstEqn :: AssocTyFamInfo
-> TyFamInstEqn GhcPs -> RnM (TyFamInstEqn GhcRn, FreeVars)
rnTyFamInstEqn AssocTyFamInfo
atfi eqn :: TyFamInstEqn GhcPs
eqn@(FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = LIdP GhcPs
tycon, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = LHsType GhcPs
rhs })
  = forall rhs rhs'.
HsDocContext
-> AssocTyFamInfo
-> [GenLocated SrcSpanAnnN RdrName]
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn (GenLocated SrcSpanAnnN RdrName -> HsDocContext
TySynCtx LIdP GhcPs
tycon) AssocTyFamInfo
atfi [GenLocated SrcSpanAnnN RdrName]
extra_kvs TyFamInstEqn GhcPs
eqn HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnTySyn
  where
    extra_kvs :: [GenLocated SrcSpanAnnN RdrName]
extra_kvs = LHsType GhcPs -> [GenLocated SrcSpanAnnN RdrName]
extractHsTyRdrTyVarsKindVars LHsType GhcPs
rhs

rnTyFamDefltDecl :: Name
                 -> TyFamDefltDecl GhcPs
                 -> RnM (TyFamDefltDecl GhcRn, FreeVars)
rnTyFamDefltDecl :: Name -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamDefltDecl Name
cls = AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl (Name -> AssocTyFamInfo
AssocTyFamDeflt Name
cls)

rnDataFamInstDecl :: AssocTyFamInfo
                  -> DataFamInstDecl GhcPs
                  -> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl :: AssocTyFamInfo
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl AssocTyFamInfo
atfi (DataFamInstDecl { dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn =
                    eqn :: FamEqn GhcPs (HsDataDefn GhcPs)
eqn@(FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = LIdP GhcPs
tycon
                                , feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs   = HsDataDefn GhcPs
rhs })})
  = do { let extra_kvs :: [GenLocated SrcSpanAnnN RdrName]
extra_kvs = HsDataDefn GhcPs -> [GenLocated SrcSpanAnnN RdrName]
extractDataDefnKindVars HsDataDefn GhcPs
rhs
       ; (FamEqn GhcRn (HsDataDefn GhcRn)
eqn', FreeVars
fvs) <-
           forall rhs rhs'.
HsDocContext
-> AssocTyFamInfo
-> [GenLocated SrcSpanAnnN RdrName]
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn (GenLocated SrcSpanAnnN RdrName -> HsDocContext
TyDataCtx LIdP GhcPs
tycon) AssocTyFamInfo
atfi [GenLocated SrcSpanAnnN RdrName]
extra_kvs FamEqn GhcPs (HsDataDefn GhcPs)
eqn HsDocContext
-> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (DataFamInstDecl { dfid_eqn :: FamEqn GhcRn (HsDataDefn GhcRn)
dfid_eqn = FamEqn GhcRn (HsDataDefn GhcRn)
eqn' }, FreeVars
fvs) }

-- 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], FreeVars)
rnATDecls Name
cls [LFamilyDecl GhcPs]
at_decls
  = forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList (Maybe Name -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, FreeVars)
rnFamDecl (forall a. a -> Maybe a
Just Name
cls)) [LFamilyDecl GhcPs]
at_decls

rnATInstDecls :: (AssocTyFamInfo ->           -- The function that renames
                  decl GhcPs ->               -- an instance. rnTyFamInstDecl
                  RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl
              -> Name      -- Class
              -> [Name]
              -> [LocatedA (decl GhcPs)]
              -> RnM ([LocatedA (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 GHC.Tc.TyCl.Instance
rnATInstDecls :: forall (decl :: * -> *).
(AssocTyFamInfo -> decl GhcPs -> RnM (decl GhcRn, FreeVars))
-> Name
-> [Name]
-> [LocatedA (decl GhcPs)]
-> RnM ([LocatedA (decl GhcRn)], FreeVars)
rnATInstDecls AssocTyFamInfo -> decl GhcPs -> RnM (decl GhcRn, FreeVars)
rnFun Name
cls [Name]
tv_ns [LocatedA (decl GhcPs)]
at_insts
  = forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList (AssocTyFamInfo -> decl GhcPs -> RnM (decl GhcRn, FreeVars)
rnFun (Name -> [Name] -> AssocTyFamInfo
AssocTyFamInst Name
cls [Name]
tv_ns)) [LocatedA (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 GHC.Tc.Gen.HsType

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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When renaming a type/data family instance, be it top-level or associated with
a class, we must check that all of the type variables mentioned on the RHS are
properly scoped. Specifically, the rule is this:

  Every variable mentioned on the RHS of a type instance declaration
  (whether associated or not) must be either
  * Mentioned on the LHS, or
  * Mentioned in an outermost kind signature on the RHS
    (see Note [Implicit quantification in type synonyms])

Here is a simple example of something we should reject:

  class C a b where
    type F a x
  instance C Int Bool where
    type F Int x = z

Here, `z` is mentioned on the RHS of the associated instance without being
mentioned on the LHS, nor is `z` mentioned in an outermost kind signature. The
renamer will reject `z` as being out of scope without much fuss.

Things get slightly trickier when the instance header itself binds type
variables. Consider this example (adapted from #5515):

   instance C (p,q) z where
      type F (p,q) x = (x, z)

According to the rule above, this instance is improperly scoped. However, due
to the way GHC's renamer works, `z` is /technically/ in scope, as GHC will
always bring type variables from an instance header into scope over the
associated type family instances. As a result, the renamer won't simply reject
the `z` as being out of scope (like it would for the `type F Int x = z`
example) unless further action is taken. It is important to reject this sort of
thing in the renamer, because if it is allowed to make it through to the
typechecker, unexpected shenanigans can occur (see #18021 for examples).

To prevent these sorts of shenanigans, we reject programs like the one above
with an extra validity check in rnFamEqn. For each type variable bound in the
parent instance head, we check if it is mentioned on the RHS of the associated
family instance but not bound on the LHS. If any of the instance-head-bound
variables meet these criteria, we throw an error.
(See rnFamEqn.improperly_scoped for how this is implemented.)

Some additional wrinkles:

* This Note only applies to *instance* declarations.  In *class* declarations
  there is no RHS to worry about, and the class variables can all be in scope
  (#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 C4 a where
      type T4 a b
    instance C4 (Maybe a) where
      type forall b. T4 (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 C4 (Maybe a)` part. (see #16116).

* In addition to the validity check in rnFamEqn.improperly_scoped, there is an
  additional check in GHC.Tc.Validity.checkFamPatBinders that checks each family
  instance equation for type variables used on the RHS but not bound on the
  LHS. This is not made redundant by rmFamEqn.improperly_scoped, as there are
  programs that each check will reject that the other check will not catch:

  - checkValidFamPats is used on all forms of family instances, whereas
    rmFamEqn.improperly_scoped only checks associated family instances. Since
    checkFamPatBinders occurs after typechecking, it can catch programs that
    introduce dodgy scoping by way of type synonyms (see #7536), which is
    impractical to accomplish in the renamer.
  - rnFamEqn.improperly_scoped catches some programs that, if allowed to escape
    the renamer, would accidentally be accepted by the typechecker. Here is one
    such program (#18021):

      class C5 a where
        data family D a

      instance forall a. C5 Int where
        data instance D Int = MkD a

    If this is not rejected in the renamer, the typechecker would treat this
    program as though the `a` were existentially quantified, like so:

      data instance D Int = forall a. MkD a

    This is likely not what the user intended!

    Here is another such program (#9574):

      class Funct f where
        type Codomain f
      instance Funct ('KProxy :: KProxy o) where
        type Codomain 'KProxy = NatTr (Proxy :: o -> Type)

    Where:

      data Proxy (a :: k) = Proxy
      data KProxy (t :: Type) = KProxy
      data NatTr (c :: o -> Type)

    Note that the `o` in the `Codomain 'KProxy` instance should be considered
    improperly scoped. It does not meet the criteria for being explicitly
    quantified, as it is not mentioned by name on the LHS, nor does it meet the
    criteria for being implicitly quantified, as it is used in a RHS kind
    signature that is not outermost (see Note [Implicit quantification in type
    synonyms]). However, `o` /is/ bound by the instance header, so if this
    program is not rejected by the renamer, the typechecker would treat it as
    though you had written this:

      instance Funct ('KProxy :: KProxy o) where
        type Codomain ('KProxy @o) = NatTr (Proxy :: o -> Type)

    Although this is a valid program, it's probably a stretch too far to turn
    `type Codomain 'KProxy = ...` into `type Codomain ('KProxy @o) = ...` here.
    If the user really wants the latter, it is simple enough to communicate
    their intent by mentioning `o` on the LHS by name.

Note [Type family equations and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In most data/type family equations, the type family name used in the equation
is treated as an occurrence. For example:

  module A where
    type family F a

  module B () where
    import B (F)
    type instance F Int = Bool

We do not want to warn about `F` being unused in the module `B`, as the
instance constitutes a use site for `F`. The exception to this rule is closed
type families, whose equations constitute a definition, not occurrences. For
example:

  module C () where
    type family CF a where
      CF Char = Float

Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is
defined but not used (#18470).

GHC accomplishes this in rnFamEqn when determining the set of free
variables to return at the end. If renaming a data family or open type family
equation, we add the name of the type family constructor to the set of returned
free variables to ensure that the name is marked as an occurrence. If renaming
a closed type family equation, we avoid adding the type family constructor name
to the free variables. This is quite simple, but it is not a perfect solution.
Consider this example:

  module X () where
    type family F a where
      F Int = Bool
      F Double = F Int

At present, GHC will treat any use of a type family constructor on the RHS of a
type family equation as an occurrence. Since `F` is used on the RHS of the
second equation of `F`, it is treated as an occurrence, causing `F` not to be
warned about. This is not ideal, since `F` isn't exported—it really /should/
cause a warning to be emitted. There is some discussion in #10089/#12920 about
how this limitation might be overcome, but until then, we stick to the
simplistic solution above, as it fixes the egregious bug in #18470.
-}


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

rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
rnSrcDerivDecl (DerivDecl XCDerivDecl GhcPs
_ LHsSigWcType GhcPs
ty Maybe (LDerivStrategy GhcPs)
mds Maybe (XRec GhcPs OverlapMode)
overlap)
  = do { Bool
standalone_deriv_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.StandaloneDeriving
       ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
standalone_deriv_ok (TcRnMessage -> TcRn ()
addErr TcRnMessage
standaloneDerivErr)
       ; HsDocContext -> Maybe SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
ctxt Maybe SDoc
inf_err LHsSigType GhcPs
nowc_ty
       ; (Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
mds', HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
ty', FreeVars
fvs) <- forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy HsDocContext
ctxt Maybe (LDerivStrategy GhcPs)
mds forall a b. (a -> b) -> a -> b
$ HsDocContext
-> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType HsDocContext
ctxt LHsSigWcType GhcPs
ty
         -- Check if there are any nested `forall`s or contexts, which are
         -- illegal in the type of an instance declaration (see
         -- Note [No nested foralls or contexts in instance types] in
         -- GHC.Hs.Type).
       ; HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
ctxt
           (String -> SDoc
text String
"Standalone-derived instance head")
           (forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead forall a b. (a -> b) -> a -> b
$ forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
ty')
       ; Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
mds' SrcSpan
loc
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCDerivDecl pass
-> LHsSigWcType pass
-> Maybe (LDerivStrategy pass)
-> Maybe (XRec pass OverlapMode)
-> DerivDecl pass
DerivDecl forall a. EpAnn a
noAnn HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
ty' Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
mds' Maybe (XRec GhcPs OverlapMode)
overlap, FreeVars
fvs) }
  where
    ctxt :: HsDocContext
ctxt    = HsDocContext
DerivDeclCtx
    inf_err :: Maybe SDoc
inf_err = forall a. a -> Maybe a
Just (String -> SDoc
text String
"Inferred type variables are not allowed")
    loc :: SrcSpan
loc = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType GhcPs
nowc_ty
    nowc_ty :: LHsSigType GhcPs
nowc_ty = forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType GhcPs
ty

standaloneDerivErr :: TcRnMessage
standaloneDerivErr :: TcRnMessage
standaloneDerivErr
  = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal standalone deriving declaration")
       Int
2 (String -> SDoc
text String
"Use StandaloneDeriving to enable this extension")

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

rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
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 { ([LocatedA (RuleDecl GhcRn)]
rn_rules,FreeVars
fvs) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl [LRuleDecl GhcPs]
rules
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (HsRules { rds_ext :: XCRuleDecls GhcRn
rds_ext = NoExtField
noExtField
                         , rds_src :: SourceText
rds_src = SourceText
src
                         , rds_rules :: [LRuleDecl GhcRn]
rds_rules = [LocatedA (RuleDecl GhcRn)]
rn_rules }, FreeVars
fvs) }

rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl (HsRule { rd_name :: forall pass. RuleDecl pass -> XRec pass (SourceText, CLabelString)
rd_name = XRec GhcPs (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 -> XRec pass (HsExpr pass)
rd_lhs  = XRec GhcPs (HsExpr GhcPs)
lhs
                     , rd_rhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
rd_rhs  = XRec GhcPs (HsExpr GhcPs)
rhs })
  = do { let rdr_names_w_loc :: [GenLocated SrcSpanAnnN RdrName]
rdr_names_w_loc = forall a b. (a -> b) -> [a] -> [b]
map (RuleBndr GhcPs -> GenLocated SrcSpanAnnN RdrName
get_var forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LRuleBndr GhcPs]
tmvs
       ; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GenLocated SrcSpanAnnN RdrName -> TcRn ()
warnForallIdentifier [GenLocated SrcSpanAnnN RdrName]
rdr_names_w_loc
       ; [GenLocated SrcSpanAnnN RdrName] -> TcRn ()
checkDupRdrNamesN [GenLocated SrcSpanAnnN RdrName]
rdr_names_w_loc
       ; [GenLocated SrcSpanAnnN RdrName] -> TcRn ()
checkShadowedRdrNames [GenLocated SrcSpanAnnN RdrName]
rdr_names_w_loc
       ; [Name]
names <- [GenLocated SrcSpanAnnN RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Name]
newLocalBndrsRn [GenLocated SrcSpanAnnN RdrName]
rdr_names_w_loc
       ; let doc :: HsDocContext
doc = CLabelString -> HsDocContext
RuleCtx (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (SourceText, CLabelString)
rule_name)
       ; forall b.
HsDocContext
-> Maybe [LHsTyVarBndr () GhcPs]
-> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindRuleTyVars HsDocContext
doc Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
tyvs forall a b. (a -> b) -> a -> b
$ \ Maybe [LHsTyVarBndr () GhcRn]
tyvs' ->
         forall ty_bndrs a.
HsDocContext
-> Maybe ty_bndrs
-> [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindRuleTmVars HsDocContext
doc Maybe [LHsTyVarBndr () GhcRn]
tyvs' [LRuleBndr GhcPs]
tmvs [Name]
names forall a b. (a -> b) -> a -> b
$ \ [LRuleBndr GhcRn]
tmvs' ->
    do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs', FreeVars
fv_lhs') <- XRec GhcPs (HsExpr GhcPs) -> TcRn (LHsExpr GhcRn, FreeVars)
rnLExpr XRec GhcPs (HsExpr GhcPs)
lhs
       ; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs', FreeVars
fv_rhs') <- XRec GhcPs (HsExpr GhcPs) -> TcRn (LHsExpr GhcRn, FreeVars)
rnLExpr XRec GhcPs (HsExpr GhcPs)
rhs
       ; CLabelString -> [Name] -> LHsExpr GhcRn -> FreeVars -> TcRn ()
checkValidRule (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (SourceText, CLabelString)
rule_name) [Name]
names GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs' FreeVars
fv_lhs'
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (HsRule { rd_ext :: XHsRule GhcRn
rd_ext  = FreeVars -> FreeVars -> HsRuleRn
HsRuleRn FreeVars
fv_lhs' FreeVars
fv_rhs'
                        , rd_name :: XRec GhcRn (SourceText, CLabelString)
rd_name = XRec GhcPs (SourceText, CLabelString)
rule_name
                        , rd_act :: Activation
rd_act  = Activation
act
                        , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc GhcRn)]
rd_tyvs = Maybe [LHsTyVarBndr () GhcRn]
tyvs'
                        , rd_tmvs :: [LRuleBndr GhcRn]
rd_tmvs = [LRuleBndr GhcRn]
tmvs'
                        , rd_lhs :: LHsExpr GhcRn
rd_lhs  = GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs'
                        , rd_rhs :: LHsExpr GhcRn
rd_rhs  = GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs' }, FreeVars
fv_lhs' FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_rhs') } }
  where
    get_var :: RuleBndr GhcPs -> LocatedN RdrName
    get_var :: RuleBndr GhcPs -> GenLocated SrcSpanAnnN RdrName
get_var (RuleBndrSig XRuleBndrSig GhcPs
_ LIdP GhcPs
v HsPatSigType GhcPs
_) = LIdP GhcPs
v
    get_var (RuleBndr XCRuleBndr GhcPs
_ LIdP GhcPs
v)      = LIdP GhcPs
v

bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
               -> [LRuleBndr GhcPs] -> [Name]
               -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
               -> RnM (a, FreeVars)
bindRuleTmVars :: forall ty_bndrs a.
HsDocContext
-> Maybe ty_bndrs
-> [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindRuleTmVars HsDocContext
doc Maybe ty_bndrs
tyvs [LRuleBndr GhcPs]
vars [Name]
names [LRuleBndr GhcRn] -> RnM (a, FreeVars)
thing_inside
  = [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
    -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
go [LRuleBndr GhcPs]
vars [Name]
names forall a b. (a -> b) -> a -> b
$ \ [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
vars' ->
    forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
names ([LRuleBndr GhcRn] -> RnM (a, FreeVars)
thing_inside [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
vars')
  where
    go :: [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
    -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
go ((L SrcAnn NoEpAnns
l (RuleBndr XCRuleBndr GhcPs
_ (L SrcSpanAnnN
loc RdrName
_))) : [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
vars) (Name
n : [Name]
ns) [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars)
thing_inside
      = [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
    -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
go [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
vars [Name]
ns forall a b. (a -> b) -> a -> b
$ \ [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
vars' ->
        [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars)
thing_inside (forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
l (forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass
RuleBndr forall a. EpAnn a
noAnn (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
n)) forall a. a -> [a] -> [a]
: [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
vars')

    go ((L SrcAnn NoEpAnns
l (RuleBndrSig XRuleBndrSig GhcPs
_ (L SrcSpanAnnN
loc RdrName
_) HsPatSigType GhcPs
bsig)) : [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
vars)
       (Name
n : [Name]
ns) [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars)
thing_inside
      = forall a.
HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigType HsPatSigTypeScoping
bind_free_tvs HsDocContext
doc HsPatSigType GhcPs
bsig forall a b. (a -> b) -> a -> b
$ \ HsPatSigType GhcRn
bsig' ->
        [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
    -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
go [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
vars [Name]
ns forall a b. (a -> b) -> a -> b
$ \ [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
vars' ->
        [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars)
thing_inside (forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
l (forall pass.
XRuleBndrSig pass
-> LIdP pass -> HsPatSigType pass -> RuleBndr pass
RuleBndrSig forall a. EpAnn a
noAnn (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
n) HsPatSigType GhcRn
bsig') forall a. a -> [a] -> [a]
: [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
vars')

    go [] [] [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars)
thing_inside = [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars)
thing_inside []
    go [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
vars [Name]
names [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars)
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"bindRuleVars" (forall a. Outputable a => a -> SDoc
ppr [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
vars SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [Name]
names)

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

bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs]
               -> (Maybe [LHsTyVarBndr () GhcRn]  -> RnM (b, FreeVars))
               -> RnM (b, FreeVars)
bindRuleTyVars :: forall b.
HsDocContext
-> Maybe [LHsTyVarBndr () GhcPs]
-> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindRuleTyVars HsDocContext
doc (Just [LHsTyVarBndr () GhcPs]
bndrs) Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)
thing_inside
  = forall flag a b.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls forall a. Maybe a
Nothing [LHsTyVarBndr () GhcPs]
bndrs (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)
thing_inside forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)
bindRuleTyVars HsDocContext
_ Maybe [LHsTyVarBndr () GhcPs]
_ Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)
thing_inside = Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)
thing_inside forall a. Maybe a
Nothing

{-
Note [Rule LHS validity checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Check the shape of a rewrite 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 -> FreeVars -> TcRn ()
checkValidRule CLabelString
rule_name [Name]
ids LHsExpr GhcRn
lhs' FreeVars
fv_lhs'
  = do  {       -- Check for the form of the LHS
          case ([Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
validRuleLhs [Name]
ids LHsExpr GhcRn
lhs') of
                Maybe (HsExpr GhcRn)
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just HsExpr GhcRn
bad -> forall a. TcRnMessage -> TcM a
failWithTc (CLabelString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage
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 -> FreeVars -> Bool
`elemNameSet` FreeVars
fv_lhs')]
        ; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcRnMessage -> TcRn ()
addErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLabelString -> Name -> TcRnMessage
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 [Name]
foralls LHsExpr GhcRn
lhs
  = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
lhs
  where
    checkl :: GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl = HsExpr GhcRn -> Maybe (HsExpr GhcRn)
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc

    check :: HsExpr GhcRn -> Maybe (HsExpr GhcRn)
check (OpApp XOpApp GhcRn
_ LHsExpr GhcRn
e1 LHsExpr GhcRn
op LHsExpr GhcRn
e2)              = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
op forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall {p} {a}. p -> Maybe a
checkl_e LHsExpr GhcRn
e1
                                                      forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall {p} {a}. p -> Maybe a
checkl_e LHsExpr GhcRn
e2
    check (HsApp XApp GhcRn
_ LHsExpr GhcRn
e1 LHsExpr GhcRn
e2)                 = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
e1 forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall {p} {a}. p -> Maybe a
checkl_e LHsExpr GhcRn
e2
    check (HsAppType XAppTypeE GhcRn
_ LHsExpr GhcRn
e LHsWcType (NoGhcTc GhcRn)
_)               = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
e
    check (HsVar XVar GhcRn
_ LIdP GhcRn
lv)
      | (forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
lv) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
foralls      = forall a. Maybe a
Nothing
    check HsExpr GhcRn
other                           = forall a. a -> Maybe a
Just HsExpr GhcRn
other  -- Failure

        -- Check an argument
    checkl_e :: p -> Maybe a
checkl_e p
_ = 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 -> TcRnMessage
badRuleVar :: CLabelString -> Name -> TcRnMessage
badRuleVar CLabelString
name Name
var
  = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
sep [String -> SDoc
text String
"Rule" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (CLabelString -> SDoc
ftext CLabelString
name) SDoc -> SDoc -> SDoc
<> SDoc
colon,
         String -> SDoc
text String
"Forall'd variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
var) SDoc -> SDoc -> SDoc
<+>
                String -> SDoc
text String
"does not appear on left hand side"]

badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage
badRuleLhsErr :: CLabelString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage
badRuleLhsErr CLabelString
name LHsExpr GhcRn
lhs HsExpr GhcRn
bad_e
  = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
sep [String -> SDoc
text String
"Rule" SDoc -> SDoc -> SDoc
<+> CLabelString -> SDoc
pprRuleName CLabelString
name SDoc -> SDoc -> SDoc
<> SDoc
colon,
         Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat [SDoc
err,
                       String -> SDoc
text String
"in left-hand side:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
lhs])]
    SDoc -> SDoc -> SDoc
$$
    String -> SDoc
text String
"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 XUnboundVar GhcRn
_ OccName
uv ->
          let rdr :: RdrName
rdr = OccName -> RdrName
mkRdrUnqual OccName
uv
          in  RdrName -> NotInScopeError -> SDoc
pprScopeError RdrName
rdr forall a b. (a -> b) -> a -> b
$ WhereLooking -> RdrName -> NotInScopeError
notInScopeErr WhereLooking
WL_Global (OccName -> RdrName
mkRdrUnqual OccName
uv)
        HsExpr GhcRn
_ -> String -> SDoc
text String
"Illegal expression:" SDoc -> SDoc -> 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 #4875


* Increase kind polymorphism.  See GHC.Tc.TyCl
  Note [Grouping of type and class declarations]

Why do the instance declarations participate?  At least two reasons

* Consider (#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 (#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 accommodate 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 GHC.Tc.Utils.Env
-}


rnTyClDecls :: [TyClGroup GhcPs]
            -> RnM ([TyClGroup GhcRn], FreeVars)
-- Rename the declarations and do dependency analysis on them
rnTyClDecls :: [TyClGroup GhcPs] -> RnM ([TyClGroup GhcRn], FreeVars)
rnTyClDecls [TyClGroup GhcPs]
tycl_ds
  = do { -- Rename the type/class, instance, and role declaraations
       ; [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
tycls_w_fvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA TyClDecl GhcPs -> RnM (TyClDecl GhcRn, FreeVars)
rnTyClDecl) (forall pass. [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls [TyClGroup GhcPs]
tycl_ds)
       ; let tc_names :: FreeVars
tc_names = [Name] -> FreeVars
mkNameSet (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
tycls_w_fvs)
       ; [(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)]
kisigs_w_fvs <- FreeVars
-> [LStandaloneKindSig GhcPs]
-> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
rnStandaloneKindSignatures FreeVars
tc_names (forall pass. [TyClGroup pass] -> [LStandaloneKindSig pass]
tyClGroupKindSigs [TyClGroup GhcPs]
tycl_ds)
       ; [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
instds_w_fvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl) (forall pass. [TyClGroup pass] -> [LInstDecl pass]
tyClGroupInstDecls [TyClGroup GhcPs]
tycl_ds)
       ; [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn)]
role_annots  <- FreeVars -> [LRoleAnnotDecl GhcPs] -> RnM [LRoleAnnotDecl GhcRn]
rnRoleAnnots FreeVars
tc_names (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
-> KindSig_FV_Env
-> [(LTyClDecl GhcRn, FreeVars)]
-> [SCC (LTyClDecl GhcRn)]
depAnalTyClDecls GlobalRdrEnv
rdr_env KindSig_FV_Env
kisig_fv_env [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
tycls_w_fvs
             role_annot_env :: RoleAnnotEnv
role_annot_env = [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv
mkRoleAnnotEnv [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn)]
role_annots
             (KindSigEnv
kisig_env, KindSig_FV_Env
kisig_fv_env) = [(LStandaloneKindSig GhcRn, FreeVars)]
-> (KindSigEnv, KindSig_FV_Env)
mkKindSig_fv_env [(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)]
kisigs_w_fvs

             inst_ds_map :: InstDeclFreeVarsMap
inst_ds_map = GlobalRdrEnv
-> FreeVars -> InstDeclFreeVarsMap -> InstDeclFreeVarsMap
mkInstDeclFreeVarsMap GlobalRdrEnv
rdr_env FreeVars
tc_names [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
instds_w_fvs
             ([LInstDecl GhcRn]
init_inst_ds, InstDeclFreeVarsMap
rest_inst_ds) = [Name]
-> InstDeclFreeVarsMap -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts [] InstDeclFreeVarsMap
inst_ds_map

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

             ([(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
final_inst_ds, [TyClGroup GhcRn]
groups)
                = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (RoleAnnotEnv
-> KindSigEnv
-> InstDeclFreeVarsMap
-> SCC (LTyClDecl GhcRn)
-> (InstDeclFreeVarsMap, TyClGroup GhcRn)
mk_group RoleAnnotEnv
role_annot_env KindSigEnv
kisig_env) InstDeclFreeVarsMap
rest_inst_ds [SCC (LTyClDecl GhcRn)]
tycl_sccs

             all_fvs :: FreeVars
all_fvs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
plusFV forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) FreeVars
emptyFVs [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
tycls_w_fvs  FreeVars -> FreeVars -> FreeVars
`plusFV`
                       forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
plusFV forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) FreeVars
emptyFVs [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
instds_w_fvs FreeVars -> FreeVars -> FreeVars
`plusFV`
                       forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
plusFV forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) FreeVars
emptyFVs [(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)]
kisigs_w_fvs

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

       ; forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
final_inst_ds)
                    (forall a. Outputable a => a -> SDoc
ppr [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
instds_w_fvs
                     SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr InstDeclFreeVarsMap
inst_ds_map
                     SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (forall a. [SCC a] -> [a]
flattenSCCs [SCC (LTyClDecl GhcRn)]
tycl_sccs)
                     SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
final_inst_ds)

       ; String -> SDoc -> TcRn ()
traceRn String
"rnTycl dependency analysis made groups" (forall a. Outputable a => a -> SDoc
ppr [TyClGroup GhcRn]
all_groups)
       ; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyClGroup GhcRn]
all_groups, FreeVars
all_fvs) }
  where
    mk_group :: RoleAnnotEnv
             -> KindSigEnv
             -> InstDeclFreeVarsMap
             -> SCC (LTyClDecl GhcRn)
             -> (InstDeclFreeVarsMap, TyClGroup GhcRn)
    mk_group :: RoleAnnotEnv
-> KindSigEnv
-> InstDeclFreeVarsMap
-> SCC (LTyClDecl GhcRn)
-> (InstDeclFreeVarsMap, TyClGroup GhcRn)
mk_group RoleAnnotEnv
role_env KindSigEnv
kisig_env InstDeclFreeVarsMap
inst_map SCC (LTyClDecl GhcRn)
scc
      = (InstDeclFreeVarsMap
inst_map', TyClGroup GhcRn
group)
      where
        tycl_ds :: [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
tycl_ds              = forall vertex. SCC vertex -> [vertex]
flattenSCC SCC (LTyClDecl GhcRn)
scc
        bndrs :: [Name]
bndrs                = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
tycl_ds
        roles :: [LRoleAnnotDecl GhcRn]
roles                = [Name] -> RoleAnnotEnv -> [LRoleAnnotDecl GhcRn]
getRoleAnnots [Name]
bndrs RoleAnnotEnv
role_env
        kisigs :: [LStandaloneKindSig GhcRn]
kisigs               = [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
getKindSigs   [Name]
bndrs KindSigEnv
kisig_env
        ([LInstDecl GhcRn]
inst_ds, InstDeclFreeVarsMap
inst_map') = [Name]
-> InstDeclFreeVarsMap -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts      [Name]
bndrs InstDeclFreeVarsMap
inst_map
        group :: TyClGroup GhcRn
group = TyClGroup { group_ext :: XCTyClGroup GhcRn
group_ext    = NoExtField
noExtField
                          , group_tyclds :: [LTyClDecl GhcRn]
group_tyclds = [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
tycl_ds
                          , group_kisigs :: [LStandaloneKindSig GhcRn]
group_kisigs = [LStandaloneKindSig GhcRn]
kisigs
                          , group_roles :: [LRoleAnnotDecl GhcRn]
group_roles  = [LRoleAnnotDecl GhcRn]
roles
                          , group_instds :: [LInstDecl GhcRn]
group_instds = [LInstDecl GhcRn]
inst_ds }

-- | Free variables of standalone kind signatures.
newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)

lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars
lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars
lookupKindSig_FV_Env (KindSig_FV_Env NameEnv FreeVars
e) Name
name
  = forall a. a -> Maybe a -> a
fromMaybe FreeVars
emptyFVs (forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv FreeVars
e Name
name)

-- | Standalone kind signatures.
type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn)

mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env)
mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)]
-> (KindSigEnv, KindSig_FV_Env)
mkKindSig_fv_env [(LStandaloneKindSig GhcRn, FreeVars)]
kisigs_w_fvs = (NameEnv (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
kisig_env, KindSig_FV_Env
kisig_fv_env)
  where
    kisig_env :: NameEnv (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
kisig_env = forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv forall a b. (a, b) -> a
fst NameEnv (LStandaloneKindSig GhcRn, FreeVars)
compound_env
    kisig_fv_env :: KindSig_FV_Env
kisig_fv_env = NameEnv FreeVars -> KindSig_FV_Env
KindSig_FV_Env (forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv forall a b. (a, b) -> b
snd NameEnv (LStandaloneKindSig GhcRn, FreeVars)
compound_env)
    NameEnv (LStandaloneKindSig GhcRn, FreeVars)
compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)
      = forall a. (a -> Name) -> [a] -> NameEnv a
mkNameEnvWith (forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(LStandaloneKindSig GhcRn, FreeVars)]
kisigs_w_fvs

getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
getKindSigs [Name]
bndrs KindSigEnv
kisig_env = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv KindSigEnv
kisig_env) [Name]
bndrs

rnStandaloneKindSignatures
  :: NameSet  -- names of types and classes in the current TyClGroup
  -> [LStandaloneKindSig GhcPs]
  -> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
rnStandaloneKindSignatures :: FreeVars
-> [LStandaloneKindSig GhcPs]
-> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
rnStandaloneKindSignatures FreeVars
tc_names [LStandaloneKindSig GhcPs]
kisigs
  = do { let ([GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)]
no_dups, [NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))]
dup_kisigs) = forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {l} {p :: Pass}.
GenLocated l (StandaloneKindSig (GhcPass p)) -> IdGhcP p
get_name) [LStandaloneKindSig GhcPs]
kisigs
             get_name :: GenLocated l (StandaloneKindSig (GhcPass p)) -> IdGhcP p
get_name = forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
       ; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (LStandaloneKindSig GhcPs) -> TcRn ()
dupKindSig_Err [NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))]
dup_kisigs
       ; forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA (FreeVars
-> StandaloneKindSig GhcPs
-> RnM (StandaloneKindSig GhcRn, FreeVars)
rnStandaloneKindSignature FreeVars
tc_names)) [GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)]
no_dups
       }

rnStandaloneKindSignature
  :: NameSet  -- names of types and classes in the current TyClGroup
  -> StandaloneKindSig GhcPs
  -> RnM (StandaloneKindSig GhcRn, FreeVars)
rnStandaloneKindSignature :: FreeVars
-> StandaloneKindSig GhcPs
-> RnM (StandaloneKindSig GhcRn, FreeVars)
rnStandaloneKindSignature FreeVars
tc_names (StandaloneKindSig XStandaloneKindSig GhcPs
_ LIdP GhcPs
v LHsSigType GhcPs
ki)
  = do  { Bool
standalone_ki_sig_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.StandaloneKindSignatures
        ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
standalone_ki_sig_ok forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addErr TcRnMessage
standaloneKiSigErr
        ; GenLocated SrcSpanAnnN Name
new_v <- HsSigCtxt
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigCtxtOccRnN (FreeVars -> HsSigCtxt
TopSigCtxt FreeVars
tc_names) (String -> SDoc
text String
"standalone kind signature") LIdP GhcPs
v
        ; let doc :: HsDocContext
doc = SDoc -> HsDocContext
StandaloneKindSigCtx (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
v)
        ; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_ki, FreeVars
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType HsDocContext
doc TypeOrKind
KindLevel LHsSigType GhcPs
ki
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XStandaloneKindSig pass
-> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig NoExtField
noExtField GenLocated SrcSpanAnnN Name
new_v GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_ki, FreeVars
fvs)
        }
  where
    standaloneKiSigErr :: TcRnMessage
    standaloneKiSigErr :: TcRnMessage
standaloneKiSigErr = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal standalone kind signature")
         Int
2 (String -> SDoc
text String
"Did you mean to enable StandaloneKindSignatures?")

depAnalTyClDecls :: GlobalRdrEnv
                 -> KindSig_FV_Env
                 -> [(LTyClDecl GhcRn, FreeVars)]
                 -> [SCC (LTyClDecl GhcRn)]
-- See Note [Dependency analysis of type, class, and instance decls]
depAnalTyClDecls :: GlobalRdrEnv
-> KindSig_FV_Env
-> [(LTyClDecl GhcRn, FreeVars)]
-> [SCC (LTyClDecl GhcRn)]
depAnalTyClDecls GlobalRdrEnv
rdr_env KindSig_FV_Env
kisig_fv_env [(LTyClDecl GhcRn, FreeVars)]
ds_w_fvs
  = 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 = [ forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d IdP GhcRn
name (forall a b. (a -> b) -> [a] -> [b]
map (GlobalRdrEnv -> Name -> Name
getParent GlobalRdrEnv
rdr_env) (forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet FreeVars
deps))
            | (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d, FreeVars
fvs) <- [(LTyClDecl GhcRn, FreeVars)]
ds_w_fvs,
              let { name :: IdP GhcRn
name = forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d)
                  ; kisig_fvs :: FreeVars
kisig_fvs = KindSig_FV_Env -> Name -> FreeVars
lookupKindSig_FV_Env KindSig_FV_Env
kisig_fv_env IdP GhcRn
name
                  ; deps :: FreeVars
deps = FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
kisig_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 GHC.Data.Graph.Directed.

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

getParent :: GlobalRdrEnv -> Name -> Name
getParent :: GlobalRdrEnv -> Name -> Name
getParent GlobalRdrEnv
rdr_env Name
n
  = case GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env Name
n of
      Just GlobalRdrElt
gre -> case GlobalRdrElt -> Parent
gre_par GlobalRdrElt
gre of
                    ParentIs  { par_is :: Parent -> Name
par_is = Name
p } -> Name
p
                    Parent
_                        -> Name
n
      Maybe GlobalRdrElt
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 :: FreeVars -> [LRoleAnnotDecl GhcPs] -> RnM [LRoleAnnotDecl GhcRn]
rnRoleAnnots FreeVars
tc_names [LRoleAnnotDecl GhcPs]
role_annots
  = do {  -- Check for duplicates *before* renaming, to avoid
          -- lumping together all the unboundNames
         let ([GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)]
no_dups, [NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))]
dup_annots) = forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {l} {p :: Pass}.
GenLocated l (RoleAnnotDecl (GhcPass p)) -> IdGhcP p
get_name) [LRoleAnnotDecl GhcPs]
role_annots
             get_name :: GenLocated l (RoleAnnotDecl (GhcPass p)) -> IdGhcP p
get_name = forall (p :: Pass). RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
roleAnnotDeclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
       ; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (LRoleAnnotDecl GhcPs) -> TcRn ()
dupRoleAnnotErr [NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))]
dup_annots
       ; forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA RoleAnnotDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (RoleAnnotDecl GhcRn)
rn_role_annot1) [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)]
no_dups }
  where
    rn_role_annot1 :: RoleAnnotDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (RoleAnnotDecl GhcRn)
rn_role_annot1 (RoleAnnotDecl XCRoleAnnotDecl GhcPs
_ LIdP GhcPs
tycon [XRec GhcPs (Maybe Role)]
roles)
      = do {  -- the name is an *occurrence*, but look it up only in the
              -- decls defined in this group (see #10263)
             GenLocated SrcSpanAnnN Name
tycon' <- HsSigCtxt
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigCtxtOccRnN (FreeVars -> HsSigCtxt
RoleAnnotCtxt FreeVars
tc_names)
                                           (String -> SDoc
text String
"role annotation")
                                           LIdP GhcPs
tycon
           ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall pass.
XCRoleAnnotDecl pass
-> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass
RoleAnnotDecl NoExtField
noExtField GenLocated SrcSpanAnnN Name
tycon' [XRec GhcPs (Maybe Role)]
roles }

dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> TcRn ()
dupRoleAnnotErr NonEmpty (LRoleAnnotDecl GhcPs)
list
  = SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Duplicate role annotations for" SDoc -> SDoc -> SDoc
<+>
          SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall (p :: Pass). RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
roleAnnotDeclName RoleAnnotDecl GhcPs
first_decl) SDoc -> SDoc -> SDoc
<> SDoc
colon)
       Int
2 ([SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}.
Outputable a =>
GenLocated (SrcSpanAnn' a) a -> SDoc
pp_role_annot forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
sorted_list)
    where
      sorted_list :: NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
sorted_list = forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy forall {a} {e}.
GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e -> Ordering
cmp_loc NonEmpty (LRoleAnnotDecl GhcPs)
list
      ((L SrcSpanAnnA
loc RoleAnnotDecl GhcPs
first_decl) :| [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)]
_) = NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
sorted_list

      pp_role_annot :: GenLocated (SrcSpanAnn' a) a -> SDoc
pp_role_annot (L SrcSpanAnn' a
loc a
decl) = SDoc -> Int -> SDoc -> SDoc
hang (forall a. Outputable a => a -> SDoc
ppr a
decl)
                                      Int
4 (String -> SDoc
text String
"-- written at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc))

      cmp_loc :: GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e -> Ordering
cmp_loc = SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA

dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()
dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> TcRn ()
dupKindSig_Err NonEmpty (LStandaloneKindSig GhcPs)
list
  = SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Duplicate standalone kind signatures for" SDoc -> SDoc -> SDoc
<+>
          SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName StandaloneKindSig GhcPs
first_decl) SDoc -> SDoc -> SDoc
<> SDoc
colon)
       Int
2 ([SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}.
Outputable a =>
GenLocated (SrcSpanAnn' a) a -> SDoc
pp_kisig forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
sorted_list)
    where
      sorted_list :: NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
sorted_list = forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy forall {a} {e}.
GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e -> Ordering
cmp_loc NonEmpty (LStandaloneKindSig GhcPs)
list
      ((L SrcSpanAnnA
loc StandaloneKindSig GhcPs
first_decl) :| [GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)]
_) = NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
sorted_list

      pp_kisig :: GenLocated (SrcSpanAnn' a) a -> SDoc
pp_kisig (L SrcSpanAnn' a
loc a
decl) =
        SDoc -> Int -> SDoc -> SDoc
hang (forall a. Outputable a => a -> SDoc
ppr a
decl) Int
4 (String -> SDoc
text String
"-- written at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc))

      cmp_loc :: GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e -> Ordering
cmp_loc = SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA

{- 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. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using
lookupGlobalOccRn led to #8485).
-}


{- ******************************************************
*                                                       *
       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
-> FreeVars -> InstDeclFreeVarsMap -> InstDeclFreeVarsMap
mkInstDeclFreeVarsMap GlobalRdrEnv
rdr_env FreeVars
tycl_bndrs InstDeclFreeVarsMap
inst_ds_fvs
  = [ (GenLocated SrcSpanAnnA (InstDecl GhcRn)
inst_decl, GlobalRdrEnv -> FreeVars -> FreeVars
toParents GlobalRdrEnv
rdr_env FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`intersectFVs` FreeVars
tycl_bndrs)
    | (GenLocated SrcSpanAnnA (InstDecl GhcRn)
inst_decl, FreeVars
fvs) <- InstDeclFreeVarsMap
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]
-> InstDeclFreeVarsMap -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts [Name]
bndrs InstDeclFreeVarsMap
inst_decl_map
  = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (LInstDecl GhcRn, FreeVars)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
pick_me InstDeclFreeVarsMap
inst_decl_map
  where
    pick_me :: (LInstDecl GhcRn, FreeVars)
            -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
    pick_me :: (LInstDecl GhcRn, FreeVars)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
pick_me (LInstDecl GhcRn
decl, FreeVars
fvs)
      | FreeVars -> Bool
isEmptyNameSet FreeVars
depleted_fvs = forall a b. a -> Either a b
Left LInstDecl GhcRn
decl
      | Bool
otherwise                   = forall a b. b -> Either a b
Right (LInstDecl GhcRn
decl, FreeVars
depleted_fvs)
      where
        depleted_fvs :: FreeVars
depleted_fvs = [Name] -> FreeVars -> FreeVars
delFVs [Name]
bndrs FreeVars
fvs

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

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

-- All flavours of top-level type family declarations ("type family", "newtype
-- family", and "data family")
rnTyClDecl :: TyClDecl GhcPs -> RnM (TyClDecl GhcRn, FreeVars)
rnTyClDecl (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcPs
fam })
  = do { (FamilyDecl GhcRn
fam', FreeVars
fvs) <- Maybe Name -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, FreeVars)
rnFamDecl forall a. Maybe a
Nothing FamilyDecl GhcPs
fam
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
noExtField FamilyDecl GhcRn
fam', FreeVars
fvs) }

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

-- "data", "newtype" declarations
rnTyClDecl (DataDecl
    { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP 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 = defn :: HsDataDefn GhcPs
defn@HsDataDefn{ dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data
                                   , dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsType GhcPs)
kind_sig} })
  = do { GenLocated SrcSpanAnnN Name
tycon' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
tycon
       ; let kvs :: [GenLocated SrcSpanAnnN RdrName]
kvs = HsDataDefn GhcPs -> [GenLocated SrcSpanAnnN RdrName]
extractDataDefnKindVars HsDataDefn GhcPs
defn
             doc :: HsDocContext
doc = GenLocated SrcSpanAnnN RdrName -> HsDocContext
TyDataCtx LIdP GhcPs
tycon
       ; String -> SDoc -> TcRn ()
traceRn String
"rntycl-data" (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
tycon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN RdrName]
kvs)
       ; forall a b.
HsDocContext
-> Maybe a
-> [GenLocated SrcSpanAnnN RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc forall a. Maybe a
Nothing [GenLocated SrcSpanAnnN RdrName]
kvs LHsQTyVars GhcPs
tyvars forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
no_rhs_kvs ->
    do { (HsDataDefn GhcRn
defn', FreeVars
fvs) <- HsDocContext
-> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn HsDocContext
doc HsDataDefn GhcPs
defn
       ; Bool
cusk <- forall (p :: Pass) (p' :: Pass).
LHsQTyVars (GhcPass p)
-> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> TcRn Bool
data_decl_has_cusk LHsQTyVars GhcRn
tyvars' NewOrData
new_or_data Bool
no_rhs_kvs Maybe (LHsType GhcPs)
kind_sig
       ; let rn_info :: DataDeclRn
rn_info = DataDeclRn { tcdDataCusk :: Bool
tcdDataCusk = Bool
cusk
                                  , tcdFVs :: FreeVars
tcdFVs      = FreeVars
fvs }
       ; String -> SDoc -> TcRn ()
traceRn String
"rndata" (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
tycon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bool
cusk SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bool
no_rhs_kvs)
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (DataDecl { tcdLName :: LIdP GhcRn
tcdLName    = GenLocated SrcSpanAnnN Name
tycon'
                          , tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars   = LHsQTyVars GhcRn
tyvars'
                          , tcdFixity :: LexicalFixity
tcdFixity   = LexicalFixity
fixity
                          , tcdDataDefn :: HsDataDefn GhcRn
tcdDataDefn = HsDataDefn GhcRn
defn'
                          , tcdDExt :: XDataDecl GhcRn
tcdDExt     = DataDeclRn
rn_info }, FreeVars
fvs) } }

rnTyClDecl (ClassDecl { tcdCtxt :: forall pass. TyClDecl pass -> Maybe (LHsContext pass)
tcdCtxt = Maybe (LHsContext GhcPs)
context, tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP 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 -> [LTyFamDefltDecl pass]
tcdATDefs = [LTyFamInstDecl GhcPs]
at_defs,
                        tcdDocs :: forall pass. TyClDecl pass -> [LDocDecl pass]
tcdDocs = [LDocDecl GhcPs]
docs})
  = do  { GenLocated SrcSpanAnnN Name
lcls' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
lcls
        ; let cls' :: Name
cls' = forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN 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
        ; ((LHsQTyVars GhcRn
tyvars', Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', [GenLocated SrcSpanAnnA (FunDep GhcRn)]
fds', [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats'), FreeVars
stuff_fvs)
            <- forall a b.
HsDocContext
-> Maybe a
-> [GenLocated SrcSpanAnnN RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
cls_doc forall a. Maybe a
Nothing forall a. [a]
kvs LHsQTyVars GhcPs
tyvars forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
_ -> do
                  -- Checks for distinct tyvars
             { (Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', FreeVars
cxt_fvs) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMaybeContext HsDocContext
cls_doc Maybe (LHsContext GhcPs)
context
             ; [GenLocated SrcSpanAnnA (FunDep GhcRn)]
fds'  <- [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds [LHsFunDep GhcPs]
fds
                         -- The fundeps have no free variables
             ; ([GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats', FreeVars
fv_ats) <- Name -> [LFamilyDecl GhcPs] -> RnM ([LFamilyDecl GhcRn], FreeVars)
rnATDecls Name
cls' [LFamilyDecl GhcPs]
ats
             ; let fvs :: FreeVars
fvs = FreeVars
cxt_fvs     FreeVars -> FreeVars -> FreeVars
`plusFV`
                         FreeVars
fv_ats
             ; forall (m :: * -> *) a. Monad m => a -> m a
return ((LHsQTyVars GhcRn
tyvars', Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', [GenLocated SrcSpanAnnA (FunDep GhcRn)]
fds', [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats'), FreeVars
fvs) }

        ; ([LocatedA (TyFamInstDecl GhcRn)]
at_defs', FreeVars
fv_at_defs) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList (Name -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamDefltDecl Name
cls') [LTyFamInstDecl GhcPs]
at_defs

        -- No need to check for duplicate associated type decls
        -- since that is done by GHC.Rename.Names.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 SrcSpanAnnN RdrName]
sig_rdr_names_w_locs =
                [GenLocated SrcSpanAnnN RdrName
op | L SrcSpanAnnA
_ (ClassOpSig XClassOpSig GhcPs
_ Bool
False [LIdP GhcPs]
ops LHsSigType GhcPs
_) <- [LSig GhcPs]
sigs
                    , GenLocated SrcSpanAnnN RdrName
op <- [LIdP GhcPs]
ops]
        ; [GenLocated SrcSpanAnnN RdrName] -> TcRn ()
checkDupRdrNamesN [GenLocated SrcSpanAnnN 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.
        ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds', [GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs', FreeVars
meth_fvs)
            <- Bool
-> Name
-> [Name]
-> LHsBinds GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)
rnMethodBinds Bool
True 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 GHC.Rename.Names.extendGlobalRdrEnvRn
                -- and the methods are already in scope

        ; let all_fvs :: FreeVars
all_fvs = FreeVars
meth_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
stuff_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_at_defs
        ; [GenLocated SrcSpanAnnA (DocDecl GhcRn)]
docs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LDocDecl GhcPs -> RnM (LDocDecl GhcRn)
rnLDocDecl [LDocDecl GhcPs]
docs
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (ClassDecl { tcdCtxt :: Maybe (LHsContext GhcRn)
tcdCtxt = Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', tcdLName :: LIdP GhcRn
tcdLName = GenLocated SrcSpanAnnN Name
lcls',
                              tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars', tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity,
                              tcdFDs :: [LHsFunDep GhcRn]
tcdFDs = [GenLocated SrcSpanAnnA (FunDep GhcRn)]
fds', tcdSigs :: [LSig GhcRn]
tcdSigs = [GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs',
                              tcdMeths :: LHsBinds GhcRn
tcdMeths = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds', tcdATs :: [LFamilyDecl GhcRn]
tcdATs = [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats', tcdATDefs :: [LTyFamInstDecl GhcRn]
tcdATDefs = [LocatedA (TyFamInstDecl GhcRn)]
at_defs',
                              tcdDocs :: [LDocDecl GhcRn]
tcdDocs = [GenLocated SrcSpanAnnA (DocDecl GhcRn)]
docs', tcdCExt :: XClassDecl GhcRn
tcdCExt = FreeVars
all_fvs },
                  FreeVars
all_fvs ) }
  where
    cls_doc :: HsDocContext
cls_doc  = GenLocated SrcSpanAnnN RdrName -> HsDocContext
ClassDeclCtx LIdP GhcPs
lcls

-- Does the data type declaration include a CUSK?
data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool
data_decl_has_cusk :: forall (p :: Pass) (p' :: Pass).
LHsQTyVars (GhcPass p)
-> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> TcRn Bool
data_decl_has_cusk LHsQTyVars (GhcPass p)
tyvars NewOrData
new_or_data Bool
no_rhs_kvs Maybe (LHsKind (GhcPass p'))
kind_sig = do
  { -- See Note [Unlifted Newtypes and CUSKs], and for a broader
    -- picture, see Note [Implementation of UnliftedNewtypes].
  ; Bool
unlifted_newtypes <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UnliftedNewtypes
  ; let non_cusk_newtype :: Bool
non_cusk_newtype
          | NewOrData
NewType <- NewOrData
new_or_data =
              Bool
unlifted_newtypes Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe (LHsKind (GhcPass p'))
kind_sig
          | Bool
otherwise = Bool
False
    -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls
  ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: Pass). LHsQTyVars (GhcPass p) -> Bool
hsTvbAllKinded LHsQTyVars (GhcPass p)
tyvars Bool -> Bool -> Bool
&& Bool
no_rhs_kvs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
non_cusk_newtype
  }

{- Note [Unlifted Newtypes and CUSKs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When unlifted newtypes are enabled, a newtype must have a kind signature
in order to be considered have a CUSK. This is because the flow of
kind inference works differently. Consider:

  newtype Foo = FooC Int

When UnliftedNewtypes is disabled, we decide that Foo has kind
`TYPE 'LiftedRep` without looking inside the data constructor. So, we
can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled,
we fill in the kind of Foo as a metavar that gets solved by unification
with the kind of the field inside FooC (that is, Int, whose kind is
`TYPE 'LiftedRep`). But since we have to look inside the data constructors
to figure out the kind signature of Foo, it does not have a CUSK.

See Note [Implementation of UnliftedNewtypes] for where this fits in to
the broader picture of UnliftedNewtypes.
-}

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

rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
           -> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn :: HsDocContext
-> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn HsDocContext
doc (HsDataDefn { dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_cType = Maybe (XRec GhcPs CType)
cType
                           , dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ctxt = Maybe (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  { -- DatatypeContexts (i.e., stupid contexts) can't be combined with
          -- GADT syntax. See Note [The stupid context] in GHC.Core.DataCon.
          Bool -> TcRnMessage -> TcRn ()
checkTc (Bool
h98_style Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcPs)
context))
                  (HsDocContext -> TcRnMessage
badGadtStupidTheta HsDocContext
doc)

        ; (Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
m_sig', FreeVars
sig_fvs) <- case Maybe (LHsType GhcPs)
m_sig of
             Just LHsType GhcPs
sig -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
doc LHsType GhcPs
sig
             Maybe (LHsType GhcPs)
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, FreeVars
emptyFVs)
        ; (Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', FreeVars
fvs1) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMaybeContext HsDocContext
doc Maybe (LHsContext GhcPs)
context
        ; ([GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)]
derivs',  FreeVars
fvs3) <- [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)], FreeVars)
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 ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
-> RnM ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
zap_lcl_env | Bool
h98_style = \ RnM ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
thing -> RnM ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
thing
                            | Bool
otherwise = forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
emptyLocalRdrEnv }
        ; ([GenLocated SrcSpanAnnA (ConDecl GhcRn)]
condecls', FreeVars
con_fvs) <- RnM ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
-> RnM ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
zap_lcl_env forall a b. (a -> b) -> a -> b
$ [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
rnConDecls [LConDecl GhcPs]
condecls
           -- No need to check for duplicate constructor decls
           -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn

        ; let all_fvs :: FreeVars
all_fvs = FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3 FreeVars -> FreeVars -> FreeVars
`plusFV`
                        FreeVars
con_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
sig_fvs
        ; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsDataDefn { dd_ext :: XCHsDataDefn GhcRn
dd_ext = NoExtField
noExtField
                              , dd_ND :: NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: Maybe (XRec GhcRn CType)
dd_cType = Maybe (XRec GhcPs CType)
cType
                              , dd_ctxt :: Maybe (LHsContext GhcRn)
dd_ctxt = Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', dd_kindSig :: Maybe (LHsType GhcRn)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
m_sig'
                              , dd_cons :: [LConDecl GhcRn]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
condecls'
                              , dd_derivs :: HsDeriving GhcRn
dd_derivs = [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)]
derivs' }
                 , FreeVars
all_fvs )
        }
  where
    h98_style :: Bool
h98_style = case [LConDecl GhcPs]
condecls of  -- Note [Stupid theta]
                     (L SrcSpanAnnA
_ (ConDeclGADT {}))                    : [LConDecl GhcPs]
_ -> Bool
False
                     [LConDecl GhcPs]
_                                             -> Bool
True

    rn_derivs :: [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)], FreeVars)
rn_derivs [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
ds
      = do { Bool
deriv_strats_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DerivingStrategies
           ; Bool -> TcRnMessage -> TcRn ()
failIfTc (forall a. [a] -> Int -> Bool
lengthExceeds [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
ds Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
deriv_strats_ok)
               TcRnMessage
multipleDerivClausesErr
           ; ([GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)]
ds', FreeVars
fvs) <- forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (HsDocContext
-> LHsDerivingClause GhcPs
-> RnM (LHsDerivingClause GhcRn, FreeVars)
rnLHsDerivingClause HsDocContext
doc) [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
ds
           ; forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)]
ds', FreeVars
fvs) }

warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
                 -> SrcSpan
                 -> RnM ()
warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (LDerivStrategy GhcRn)
mds SrcSpan
loc
  = do { DynFlags
dyn_flags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; case Maybe (LDerivStrategy GhcRn)
mds of
           Maybe (LDerivStrategy GhcRn)
Nothing ->
             let dia :: TcRnMessage
dia = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$
                   DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingDerivingStrategies) [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
                     (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
                     )
             in SrcSpan -> TcRnMessage -> TcRn ()
addDiagnosticAt SrcSpan
loc TcRnMessage
dia
           Maybe (LDerivStrategy GhcRn)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
       }
  where
    no_strat_warning :: SDoc
    no_strat_warning :: SDoc
no_strat_warning = String -> SDoc
text String
"No deriving strategy specified. Did you want stock"
                       SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", newtype, or anyclass?"
    deriv_strat_nenabled :: SDoc
    deriv_strat_nenabled :: SDoc
deriv_strat_nenabled = String -> SDoc
text String
"Use DerivingStrategies to specify a strategy."

rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs
                    -> RnM (LHsDerivingClause GhcRn, FreeVars)
rnLHsDerivingClause :: HsDocContext
-> LHsDerivingClause GhcPs
-> RnM (LHsDerivingClause GhcRn, FreeVars)
rnLHsDerivingClause HsDocContext
doc
                (L SrcAnn NoEpAnns
loc (HsDerivingClause
                              { deriv_clause_ext :: forall pass. HsDerivingClause pass -> XCHsDerivingClause pass
deriv_clause_ext = XCHsDerivingClause GhcPs
noExtField
                              , deriv_clause_strategy :: forall pass. HsDerivingClause pass -> Maybe (LDerivStrategy pass)
deriv_clause_strategy = Maybe (LDerivStrategy GhcPs)
dcs
                              , deriv_clause_tys :: forall pass. HsDerivingClause pass -> LDerivClauseTys pass
deriv_clause_tys = LDerivClauseTys GhcPs
dct }))
  = do { (Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
dcs', GenLocated SrcSpanAnnC (DerivClauseTys GhcRn)
dct', FreeVars
fvs)
           <- forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy HsDocContext
doc Maybe (LDerivStrategy GhcPs)
dcs forall a b. (a -> b) -> a -> b
$ LDerivClauseTys GhcPs -> RnM (LDerivClauseTys GhcRn, FreeVars)
rn_deriv_clause_tys LDerivClauseTys GhcPs
dct
       ; Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
dcs' (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcAnn NoEpAnns
loc)
       ; forall (f :: * -> *) a. Applicative f => a -> f a
pure ( forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
loc (HsDerivingClause { deriv_clause_ext :: XCHsDerivingClause GhcRn
deriv_clause_ext = XCHsDerivingClause GhcPs
noExtField
                                        , deriv_clause_strategy :: Maybe (LDerivStrategy GhcRn)
deriv_clause_strategy = Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
dcs'
                                        , deriv_clause_tys :: LDerivClauseTys GhcRn
deriv_clause_tys = GenLocated SrcSpanAnnC (DerivClauseTys GhcRn)
dct' })
              , FreeVars
fvs ) }
  where
    rn_deriv_clause_tys :: LDerivClauseTys GhcPs
                        -> RnM (LDerivClauseTys GhcRn, FreeVars)
    rn_deriv_clause_tys :: LDerivClauseTys GhcPs -> RnM (LDerivClauseTys GhcRn, FreeVars)
rn_deriv_clause_tys (L SrcSpanAnnC
l DerivClauseTys GhcPs
dct) = case DerivClauseTys GhcPs
dct of
      DctSingle XDctSingle GhcPs
x LHsSigType GhcPs
ty -> do
        (GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty', FreeVars
fvs) <- LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
rn_clause_pred LHsSigType GhcPs
ty
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
l (forall pass.
XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass
DctSingle XDctSingle GhcPs
x GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty'), FreeVars
fvs)
      DctMulti XDctMulti GhcPs
x [LHsSigType GhcPs]
tys -> do
        ([GenLocated SrcSpanAnnA (HsSigType GhcRn)]
tys', FreeVars
fvs) <- forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
rn_clause_pred [LHsSigType GhcPs]
tys
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
l (forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti XDctMulti GhcPs
x [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
tys'), FreeVars
fvs)

    rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
    rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
rn_clause_pred LHsSigType GhcPs
pred_ty = do
      let inf_err :: Maybe SDoc
inf_err = forall a. a -> Maybe a
Just (String -> SDoc
text String
"Inferred type variables are not allowed")
      HsDocContext -> Maybe SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
doc Maybe SDoc
inf_err LHsSigType GhcPs
pred_ty
      ret :: (GenLocated SrcSpanAnnA (HsSigType GhcRn), FreeVars)
ret@(GenLocated SrcSpanAnnA (HsSigType GhcRn)
pred_ty', FreeVars
_) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType HsDocContext
doc TypeOrKind
TypeLevel LHsSigType GhcPs
pred_ty
      -- Check if there are any nested `forall`s, which are illegal in a
      -- `deriving` clause.
      -- See Note [No nested foralls or contexts in instance types]
      -- (Wrinkle: Derived instances) in GHC.Hs.Type.
      HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
doc (String -> SDoc
text String
"Derived class type")
        (forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead GenLocated SrcSpanAnnA (HsSigType GhcRn)
pred_ty')
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsSigType GhcRn), FreeVars)
ret

rnLDerivStrategy :: forall a.
                    HsDocContext
                 -> Maybe (LDerivStrategy GhcPs)
                 -> RnM (a, FreeVars)
                 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy :: forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy HsDocContext
doc Maybe (LDerivStrategy GhcPs)
mds RnM (a, FreeVars)
thing_inside
  = case Maybe (LDerivStrategy GhcPs)
mds of
      Maybe (LDerivStrategy GhcPs)
Nothing -> forall ds. ds -> RnM (ds, a, FreeVars)
boring_case forall a. Maybe a
Nothing
      Just (L SrcAnn NoEpAnns
loc DerivStrategy GhcPs
ds) ->
        forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcAnn NoEpAnns
loc forall a b. (a -> b) -> a -> b
$ do
          (DerivStrategy GhcRn
ds', a
thing, FreeVars
fvs) <- DerivStrategy GhcPs -> RnM (DerivStrategy GhcRn, a, FreeVars)
rn_deriv_strat DerivStrategy GhcPs
ds
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
loc DerivStrategy GhcRn
ds'), a
thing, FreeVars
fvs)
  where
    rn_deriv_strat :: DerivStrategy GhcPs
                   -> RnM (DerivStrategy GhcRn, a, FreeVars)
    rn_deriv_strat :: DerivStrategy GhcPs -> RnM (DerivStrategy GhcRn, a, FreeVars)
rn_deriv_strat DerivStrategy GhcPs
ds = do
      let extNeeded :: LangExt.Extension
          extNeeded :: Extension
extNeeded
            | ViaStrategy{} <- DerivStrategy GhcPs
ds
            = Extension
LangExt.DerivingVia
            | Bool
otherwise
            = Extension
LangExt.DerivingStrategies

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

      case DerivStrategy GhcPs
ds of
        StockStrategy    XStockStrategy GhcPs
_ -> forall ds. ds -> RnM (ds, a, FreeVars)
boring_case (forall pass. XStockStrategy pass -> DerivStrategy pass
StockStrategy NoExtField
noExtField)
        AnyclassStrategy XAnyClassStrategy GhcPs
_ -> forall ds. ds -> RnM (ds, a, FreeVars)
boring_case (forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy NoExtField
noExtField)
        NewtypeStrategy  XNewtypeStrategy GhcPs
_ -> forall ds. ds -> RnM (ds, a, FreeVars)
boring_case (forall pass. XNewtypeStrategy pass -> DerivStrategy pass
NewtypeStrategy NoExtField
noExtField)
        ViaStrategy (XViaStrategyPs EpAnn [AddEpAnn]
_ LHsSigType GhcPs
via_ty) ->
          do HsDocContext -> Maybe SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
doc Maybe SDoc
inf_err LHsSigType GhcPs
via_ty
             (GenLocated SrcSpanAnnA (HsSigType GhcRn)
via_ty', FreeVars
fvs1) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType HsDocContext
doc TypeOrKind
TypeLevel LHsSigType GhcPs
via_ty
             let HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterTyVarBndrs Specificity GhcRn
via_outer_bndrs
                       , sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body  = LHsType GhcRn
via_body } = forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsSigType GhcRn)
via_ty'
                 via_tvs :: [Name]
via_tvs = forall flag. HsOuterTyVarBndrs flag GhcRn -> [Name]
hsOuterTyVarNames HsOuterTyVarBndrs Specificity GhcRn
via_outer_bndrs
             -- Check if there are any nested `forall`s, which are illegal in a
             -- `via` type.
             -- See Note [No nested foralls or contexts in instance types]
             -- (Wrinkle: Derived instances) in GHC.Hs.Type.
             HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
doc
               (SDoc -> SDoc
quotes (String -> SDoc
text String
"via") SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"type") LHsType GhcRn
via_body
             (a
thing, FreeVars
fvs2) <- forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
via_tvs RnM (a, FreeVars)
thing_inside
             forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy GenLocated SrcSpanAnnA (HsSigType GhcRn)
via_ty', a
thing, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2)

    inf_err :: Maybe SDoc
inf_err = forall a. a -> Maybe a
Just (String -> SDoc
text String
"Inferred type variables are not allowed")

    boring_case :: ds -> RnM (ds, a, FreeVars)
    boring_case :: forall ds. ds -> RnM (ds, a, FreeVars)
boring_case ds
ds = do
      (a
thing, FreeVars
fvs) <- RnM (a, FreeVars)
thing_inside
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (ds
ds, a
thing, FreeVars
fvs)

badGadtStupidTheta :: HsDocContext -> TcRnMessage
badGadtStupidTheta :: HsDocContext -> TcRnMessage
badGadtStupidTheta HsDocContext
_
  = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
vcat [String -> SDoc
text String
"No context is allowed on a GADT-style data declaration",
          String -> SDoc
text String
"(You can put a context on each constructor, though.)"]

illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage
illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage
illegalDerivStrategyErr DerivStrategy GhcPs
ds
  = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal deriving strategy" SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> 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
      = String
"Use DerivingVia to enable this extension"
      | Bool
otherwise
      = String
"Use DerivingStrategies to enable this extension"

multipleDerivClausesErr :: TcRnMessage
multipleDerivClausesErr :: TcRnMessage
multipleDerivClausesErr
  = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal use of multiple, consecutive deriving clauses"
         , String -> SDoc
text String
"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, FreeVars)
rnFamDecl Maybe Name
mb_cls (FamilyDecl { fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = LIdP GhcPs
tycon, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcPs
tyvars
                             , fdTopLevel :: forall pass. FamilyDecl pass -> TopLevelFlag
fdTopLevel = TopLevelFlag
toplevel
                             , 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 { GenLocated SrcSpanAnnN Name
tycon' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
tycon
       ; ((LHsQTyVars GhcRn
tyvars', GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn)
res_sig', Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
injectivity'), FreeVars
fv1) <-
            forall a b.
HsDocContext
-> Maybe a
-> [GenLocated SrcSpanAnnN RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc Maybe Name
mb_cls [GenLocated SrcSpanAnnN RdrName]
kvs LHsQTyVars GhcPs
tyvars forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
_ ->
            do { let rn_sig :: FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, FreeVars)
rn_sig = HsDocContext
-> FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, FreeVars)
rnFamResultSig HsDocContext
doc
               ; (GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn)
res_sig', FreeVars
fv_kind) <- forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, FreeVars)
rn_sig LFamilyResultSig GhcPs
res_sig
               ; Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
injectivity' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (LHsQTyVars GhcRn
-> LFamilyResultSig GhcRn
-> LInjectivityAnn GhcPs
-> RnM (LInjectivityAnn GhcRn)
rnInjectivityAnn LHsQTyVars GhcRn
tyvars' GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn)
res_sig')
                                          Maybe (LInjectivityAnn GhcPs)
injectivity
               ; forall (m :: * -> *) a. Monad m => a -> m a
return ( (LHsQTyVars GhcRn
tyvars', GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn)
res_sig', Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
injectivity') , FreeVars
fv_kind ) }
       ; (FamilyInfo GhcRn
info', FreeVars
fv2) <- FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
rn_info FamilyInfo GhcPs
info
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (FamilyDecl { fdExt :: XCFamilyDecl GhcRn
fdExt = forall a. EpAnn a
noAnn
                            , fdLName :: LIdP GhcRn
fdLName = GenLocated SrcSpanAnnN Name
tycon', fdTyVars :: LHsQTyVars GhcRn
fdTyVars = LHsQTyVars GhcRn
tyvars'
                            , fdTopLevel :: TopLevelFlag
fdTopLevel = TopLevelFlag
toplevel
                            , fdFixity :: LexicalFixity
fdFixity = LexicalFixity
fixity
                            , fdInfo :: FamilyInfo GhcRn
fdInfo = FamilyInfo GhcRn
info', fdResultSig :: LFamilyResultSig GhcRn
fdResultSig = GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn)
res_sig'
                            , fdInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
fdInjectivityAnn = Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
injectivity' }
                , FreeVars
fv1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv2) }
  where
     doc :: HsDocContext
doc = GenLocated SrcSpanAnnN RdrName -> HsDocContext
TyFamilyCtx LIdP GhcPs
tycon
     kvs :: [GenLocated SrcSpanAnnN RdrName]
kvs = LFamilyResultSig GhcPs -> [GenLocated SrcSpanAnnN RdrName]
extractRdrKindSigVars LFamilyResultSig GhcPs
res_sig

     ----------------------
     rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
     rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
rn_info (ClosedTypeFamily (Just [LTyFamInstEqn GhcPs]
eqns))
       = do { ([LocatedA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
eqns', FreeVars
fvs)
                <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList (AssocTyFamInfo
-> TyFamInstEqn GhcPs -> RnM (TyFamInstEqn GhcRn, FreeVars)
rnTyFamInstEqn (ClosedTyFamInfo -> AssocTyFamInfo
NonAssocTyFamEqn ClosedTyFamInfo
ClosedTyFam)) [LTyFamInstEqn GhcPs]
eqns
                                          -- no class context
            ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily (forall a. a -> Maybe a
Just [LocatedA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
eqns'), FreeVars
fvs) }
     rn_info (ClosedTypeFamily Maybe [LTyFamInstEqn GhcPs]
Nothing)
       = forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily forall a. Maybe a
Nothing, FreeVars
emptyFVs)
     rn_info FamilyInfo GhcPs
OpenTypeFamily = forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. FamilyInfo pass
OpenTypeFamily, FreeVars
emptyFVs)
     rn_info FamilyInfo GhcPs
DataFamily     = forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. FamilyInfo pass
DataFamily, FreeVars
emptyFVs)

rnFamResultSig :: HsDocContext
               -> FamilyResultSig GhcPs
               -> RnM (FamilyResultSig GhcRn, FreeVars)
rnFamResultSig :: HsDocContext
-> FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, FreeVars)
rnFamResultSig HsDocContext
_ (NoSig XNoSig GhcPs
_)
   = forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. XNoSig pass -> FamilyResultSig pass
NoSig NoExtField
noExtField, FreeVars
emptyFVs)
rnFamResultSig HsDocContext
doc (KindSig XCKindSig GhcPs
_ LHsType GhcPs
kind)
   = do { (GenLocated SrcSpanAnnA (HsType GhcRn)
rndKind, FreeVars
ftvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
doc LHsType GhcPs
kind
        ;  forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
KindSig NoExtField
noExtField GenLocated SrcSpanAnnA (HsType GhcRn)
rndKind, FreeVars
ftvs) }
rnFamResultSig HsDocContext
doc (TyVarSig XTyVarSig GhcPs
_ 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 = forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcPs
tvbndr
       ;  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IdP GhcPs
resName RdrName -> LocalRdrEnv -> Bool
`elemLocalRdrEnv` LocalRdrEnv
rdr_env) forall a b. (a -> b) -> a -> b
$
          SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsTyVarBndr () GhcPs
tvbndr) forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
                     ([SDoc] -> SDoc
hsep [ String -> SDoc
text String
"Type variable", SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr IdP GhcPs
resName) SDoc -> SDoc -> SDoc
<> SDoc
comma
                           , String -> SDoc
text String
"naming a type family result,"
                           ] SDoc -> SDoc -> SDoc
$$
                      String -> SDoc
text String
"shadows an already bound type variable")

       ; forall a flag b.
HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr HsDocContext
doc forall a. Maybe a
Nothing -- This might be a lie, but it's used for
                                      -- scoping checks that are irrelevant here
                          LHsTyVarBndr () GhcPs
tvbndr forall a b. (a -> b) -> a -> b
$ \ LHsTyVarBndr () GhcRn
tvbndr' ->
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XTyVarSig pass -> LHsTyVarBndr () pass -> FamilyResultSig pass
TyVarSig NoExtField
noExtField LHsTyVarBndr () GhcRn
tvbndr', Name -> FreeVars
unitFV (forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
tvbndr')) }

-- 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
-> RnM (LInjectivityAnn GhcRn)
rnInjectivityAnn LHsQTyVars GhcRn
tvBndrs (L SrcAnn NoEpAnns
_ (TyVarSig XTyVarSig GhcRn
_ LHsTyVarBndr () GhcRn
resTv))
                 (L SrcAnn NoEpAnns
srcSpan (InjectivityAnn XCInjectivityAnn GhcPs
x LIdP GhcPs
injFrom [LIdP GhcPs]
injTo))
 = do
   { (injDecl' :: GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
injDecl'@(L SrcAnn NoEpAnns
_ (InjectivityAnn XCInjectivityAnn GhcRn
_ LIdP GhcRn
injFrom' [LIdP GhcRn]
injTo')), Bool
noRnErrors)
          <- forall a. TcRn a -> TcRn (a, Bool)
askNoErrs forall a b. (a -> b) -> a -> b
$
             forall a. [Name] -> RnM a -> RnM a
bindLocalNames [forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
resTv] 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 { GenLocated SrcSpanAnnN Name
injFrom' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnLTyVar LIdP GhcPs
injFrom
                ; [GenLocated SrcSpanAnnN Name]
injTo'   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnLTyVar [LIdP GhcPs]
injTo
                -- Note: srcSpan is unchanged, but typechecker gets
                -- confused, l2l call makes it happy
                ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NoEpAnns
srcSpan) (forall pass.
XCInjectivityAnn pass
-> LIdP pass -> [LIdP pass] -> InjectivityAnn pass
InjectivityAnn XCInjectivityAnn GhcPs
x GenLocated SrcSpanAnnN Name
injFrom' [GenLocated SrcSpanAnnN Name]
injTo') }

   ; let tvNames :: Set Name
tvNames  = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ LHsQTyVars GhcRn -> [Name]
hsAllLTyVarNames LHsQTyVars GhcRn
tvBndrs
         resName :: IdP GhcRn
resName  = forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
resTv
         -- See Note [Renaming injectivity annotation]
         lhsValid :: Bool
lhsValid = Ordering
EQ forall a. Eq a => a -> a -> Bool
== (Name -> Name -> Ordering
stableNameCmp IdP GhcRn
resName (forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
injFrom'))
         rhsValid :: Set Name
rhsValid = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
injTo') 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.
   ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
noRnErrors Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
lhsValid) forall a b. (a -> b) -> a -> b
$
        SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LIdP GhcPs
injFrom) forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
              ( [SDoc] -> SDoc
vcat [ String -> SDoc
text forall a b. (a -> b) -> a -> b
$ String
"Incorrect type variable on the LHS of "
                           forall a. [a] -> [a] -> [a]
++ String
"injectivity condition"
              , Int -> SDoc -> SDoc
nest Int
5
              ( [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Expected :" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr IdP GhcRn
resName
                     , String -> SDoc
text String
"Actual   :" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
injFrom ])])

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

   ; forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated (SrcAnn NoEpAnns) (InjectivityAnn 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 LHsQTyVars GhcRn
_ LFamilyResultSig GhcRn
_ (L SrcAnn NoEpAnns
srcSpan (InjectivityAnn XCInjectivityAnn GhcPs
x LIdP GhcPs
injFrom [LIdP GhcPs]
injTo)) =
   forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcAnn NoEpAnns
srcSpan forall a b. (a -> b) -> a -> b
$ do
   (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
injDecl', Bool
_) <- forall a. TcRn a -> TcRn (a, Bool)
askNoErrs forall a b. (a -> b) -> a -> b
$ do
     GenLocated SrcSpanAnnN Name
injFrom' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnLTyVar LIdP GhcPs
injFrom
     [GenLocated SrcSpanAnnN Name]
injTo'   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnLTyVar [LIdP GhcPs]
injTo
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
srcSpan (forall pass.
XCInjectivityAnn pass
-> LIdP pass -> [LIdP pass] -> InjectivityAnn pass
InjectivityAnn XCInjectivityAnn GhcPs
x GenLocated SrcSpanAnnN Name
injFrom' [GenLocated SrcSpanAnnN Name]
injTo')
   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
injDecl'

{-
Note [Stupid theta]
~~~~~~~~~~~~~~~~~~~
#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
*                                                      *
***************************************************** -}

-----------------
rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
rnConDecls = forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl)

rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl decl :: ConDecl GhcPs
decl@(ConDeclH98 { con_name :: forall pass. ConDecl pass -> LIdP pass
con_name = LIdP GhcPs
name, con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs = [LHsTyVarBndr Specificity 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 -> HsConDeclH98Details pass
con_args = HsConDeclH98Details GhcPs
args
                           , con_doc :: forall pass. ConDecl pass -> Maybe (LHsDoc pass)
con_doc = Maybe (LHsDoc GhcPs)
mb_doc, con_forall :: forall pass. ConDecl pass -> Bool
con_forall = Bool
forall_ })
  = do  { ()
_        <- forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA RdrName -> TcRn ()
checkConName LIdP GhcPs
name
        ; GenLocated SrcSpanAnnN Name
new_name <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
name

        -- 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 = [GenLocated SrcSpanAnnN Name] -> HsDocContext
ConDeclCtx [GenLocated SrcSpanAnnN Name
new_name]
        ; forall flag a b.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
ctxt WarnUnusedForalls
WarnUnusedForalls
                            forall a. Maybe a
Nothing [LHsTyVarBndr Specificity GhcPs]
ex_tvs forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr Specificity GhcRn]
new_ex_tvs ->
    do  { (Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
new_context, FreeVars
fvs1) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMbContext HsDocContext
ctxt Maybe (LHsContext GhcPs)
mcxt
        ; (HsConDetails
  Void
  (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
  (GenLocated
     SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
new_args,    FreeVars
fvs2) <- Name
-> HsDocContext
-> HsConDeclH98Details GhcPs
-> RnM (HsConDeclH98Details GhcRn, FreeVars)
rnConDeclH98Details (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
new_name) HsDocContext
ctxt HsConDeclH98Details GhcPs
args
        ; let all_fvs :: FreeVars
all_fvs  = FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2
        ; String -> SDoc -> TcRn ()
traceRn String
"rnConDecl (ConDeclH98)" (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
name SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat
             [ String -> SDoc
text String
"ex_tvs:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr Specificity GhcPs]
ex_tvs
             , String -> SDoc
text String
"new_ex_dqtvs':" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr Specificity GhcRn]
new_ex_tvs ])

        ; Maybe (LHsDoc GhcRn)
mb_doc' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LHsDoc GhcPs -> RnM (LHsDoc GhcRn)
rnLHsDoc Maybe (LHsDoc GhcPs)
mb_doc
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (ConDecl GhcPs
decl { con_ext :: XConDeclH98 GhcRn
con_ext = forall a. EpAnn a
noAnn
                       , con_name :: LIdP GhcRn
con_name = GenLocated SrcSpanAnnN Name
new_name, con_ex_tvs :: [LHsTyVarBndr Specificity GhcRn]
con_ex_tvs = [LHsTyVarBndr Specificity GhcRn]
new_ex_tvs
                       , con_mb_cxt :: Maybe (LHsContext GhcRn)
con_mb_cxt = Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
new_context, con_args :: HsConDeclH98Details GhcRn
con_args = HsConDetails
  Void
  (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
  (GenLocated
     SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
new_args
                       , con_doc :: Maybe (LHsDoc GhcRn)
con_doc = Maybe (LHsDoc GhcRn)
mb_doc'
                       , con_forall :: Bool
con_forall = Bool
forall_ }, -- Remove when #18311 is fixed
                  FreeVars
all_fvs) }}

rnConDecl (ConDeclGADT { con_names :: forall pass. ConDecl pass -> [LIdP pass]
con_names   = [LIdP GhcPs]
names
                       , con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs   = L SrcSpanAnnA
l HsOuterSigTyVarBndrs GhcPs
outer_bndrs
                       , con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt  = Maybe (LHsContext GhcPs)
mcxt
                       , con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args  = HsConDeclGADTDetails 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 (LHsDoc pass)
con_doc     = Maybe (LHsDoc GhcPs)
mb_doc })
  = do  { forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA RdrName -> TcRn ()
checkConName) [LIdP GhcPs]
names
        ; [GenLocated SrcSpanAnnN Name]
new_names <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN) [LIdP GhcPs]
names

        ; let -- 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 #14808.
              implicit_bndrs :: [GenLocated SrcSpanAnnN RdrName]
implicit_bndrs =
                forall flag.
HsOuterTyVarBndrs flag GhcPs
-> [GenLocated SrcSpanAnnN RdrName]
-> [GenLocated SrcSpanAnnN RdrName]
extractHsOuterTvBndrs HsOuterSigTyVarBndrs GhcPs
outer_bndrs           forall a b. (a -> b) -> a -> b
$
                [LHsType GhcPs]
-> [GenLocated SrcSpanAnnN RdrName]
-> [GenLocated SrcSpanAnnN RdrName]
extractHsTysRdrTyVars (forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
hsConDeclTheta Maybe (LHsContext GhcPs)
mcxt) forall a b. (a -> b) -> a -> b
$
                HsConDeclGADTDetails GhcPs
-> [GenLocated SrcSpanAnnN RdrName]
-> [GenLocated SrcSpanAnnN RdrName]
extractConDeclGADTDetailsTyVars HsConDeclGADTDetails GhcPs
args        forall a b. (a -> b) -> a -> b
$
                [LHsType GhcPs]
-> [GenLocated SrcSpanAnnN RdrName]
-> [GenLocated SrcSpanAnnN RdrName]
extractHsTysRdrTyVars [LHsType GhcPs
res_ty] []

        ; let ctxt :: HsDocContext
ctxt = [GenLocated SrcSpanAnnN Name] -> HsDocContext
ConDeclCtx [GenLocated SrcSpanAnnN Name]
new_names

        ; forall flag assoc a.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> Maybe assoc
-> [GenLocated SrcSpanAnnN RdrName]
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs HsDocContext
ctxt forall a. Maybe a
Nothing [GenLocated SrcSpanAnnN RdrName]
implicit_bndrs HsOuterSigTyVarBndrs GhcPs
outer_bndrs forall a b. (a -> b) -> a -> b
$ \HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs' ->
    do  { (Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
new_cxt, FreeVars
fvs1)    <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMbContext HsDocContext
ctxt Maybe (LHsContext GhcPs)
mcxt
        ; (HsConDeclGADTDetails GhcRn
new_args, FreeVars
fvs2)   <- Name
-> HsDocContext
-> HsConDeclGADTDetails GhcPs
-> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
rnConDeclGADTDetails (forall l e. GenLocated l e -> e
unLoc (forall a. [a] -> a
head [GenLocated SrcSpanAnnN Name]
new_names)) HsDocContext
ctxt HsConDeclGADTDetails GhcPs
args
        ; (GenLocated SrcSpanAnnA (HsType GhcRn)
new_res_ty, FreeVars
fvs3) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
ctxt LHsType GhcPs
res_ty

         -- Ensure that there are no nested `forall`s or contexts, per
         -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)
         -- in GHC.Hs.Type.
       ; HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
ctxt
           (String -> SDoc
text String
"GADT constructor type signature") GenLocated SrcSpanAnnA (HsType GhcRn)
new_res_ty

        ; let all_fvs :: FreeVars
all_fvs = FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3

        ; String -> SDoc -> TcRn ()
traceRn String
"rnConDecl (ConDeclGADT)"
            (forall a. Outputable a => a -> SDoc
ppr [LIdP GhcPs]
names SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs')
        ; Maybe (LHsDoc GhcRn)
new_mb_doc <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LHsDoc GhcPs -> RnM (LHsDoc GhcRn)
rnLHsDoc Maybe (LHsDoc GhcPs)
mb_doc
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (ConDeclGADT { con_g_ext :: XConDeclGADT GhcRn
con_g_ext = forall a. EpAnn a
noAnn, con_names :: [LIdP GhcRn]
con_names = [GenLocated SrcSpanAnnN Name]
new_names
                              , con_bndrs :: XRec GhcRn (HsOuterTyVarBndrs Specificity GhcRn)
con_bndrs = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs', con_mb_cxt :: Maybe (LHsContext GhcRn)
con_mb_cxt = Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
new_cxt
                              , con_g_args :: HsConDeclGADTDetails GhcRn
con_g_args = HsConDeclGADTDetails GhcRn
new_args, con_res_ty :: LHsType GhcRn
con_res_ty = GenLocated SrcSpanAnnA (HsType GhcRn)
new_res_ty
                              , con_doc :: Maybe (LHsDoc GhcRn)
con_doc = Maybe (LHsDoc GhcRn)
new_mb_doc },
                  FreeVars
all_fvs) } }

rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
            -> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMbContext :: HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMbContext HsDocContext
_    Maybe (LHsContext GhcPs)
Nothing    = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, FreeVars
emptyFVs)
rnMbContext HsDocContext
doc Maybe (LHsContext GhcPs)
cxt = do { (Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
ctx',FreeVars
fvs) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMaybeContext HsDocContext
doc Maybe (LHsContext GhcPs)
cxt
                         ; forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
ctx',FreeVars
fvs) }

rnConDeclH98Details ::
      Name
   -> HsDocContext
   -> HsConDeclH98Details GhcPs
   -> RnM (HsConDeclH98Details GhcRn, FreeVars)
rnConDeclH98Details :: Name
-> HsDocContext
-> HsConDeclH98Details GhcPs
-> RnM (HsConDeclH98Details GhcRn, FreeVars)
rnConDeclH98Details Name
_ HsDocContext
doc (PrefixCon [Void]
_ [HsScaled GhcPs (LHsType GhcPs)]
tys)
  = do { ([HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
new_tys, FreeVars
fvs) <- forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc) [HsScaled GhcPs (LHsType GhcPs)]
tys
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [Void]
noTypeArgs [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
new_tys, FreeVars
fvs) }
rnConDeclH98Details Name
_ HsDocContext
doc (InfixCon HsScaled GhcPs (LHsType GhcPs)
ty1 HsScaled GhcPs (LHsType GhcPs)
ty2)
  = do { (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
new_ty1, FreeVars
fvs1) <- HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc HsScaled GhcPs (LHsType GhcPs)
ty1
       ; (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
new_ty2, FreeVars
fvs2) <- HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc HsScaled GhcPs (LHsType GhcPs)
ty2
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
new_ty1 HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
new_ty2, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }
rnConDeclH98Details Name
con HsDocContext
doc (RecCon XRec GhcPs [LConDeclField GhcPs]
flds)
  = do { (GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_flds, FreeVars
fvs) <- Name
-> HsDocContext
-> LocatedL [LConDeclField GhcPs]
-> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields Name
con HsDocContext
doc XRec GhcPs [LConDeclField GhcPs]
flds
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_flds, FreeVars
fvs) }

rnConDeclGADTDetails ::
      Name
   -> HsDocContext
   -> HsConDeclGADTDetails GhcPs
   -> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
rnConDeclGADTDetails :: Name
-> HsDocContext
-> HsConDeclGADTDetails GhcPs
-> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
rnConDeclGADTDetails Name
_ HsDocContext
doc (PrefixConGADT [HsScaled GhcPs (LHsType GhcPs)]
tys)
  = do { ([HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
new_tys, FreeVars
fvs) <- forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc) [HsScaled GhcPs (LHsType GhcPs)]
tys
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
new_tys, FreeVars
fvs) }
rnConDeclGADTDetails Name
con HsDocContext
doc (RecConGADT XRec GhcPs [LConDeclField GhcPs]
flds LHsUniToken "->" "\8594" GhcPs
arr)
  = do { (GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_flds, FreeVars
fvs) <- Name
-> HsDocContext
-> LocatedL [LConDeclField GhcPs]
-> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields Name
con HsDocContext
doc XRec GhcPs [LConDeclField GhcPs]
flds
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XRec pass [LConDeclField pass]
-> LHsUniToken "->" "\8594" pass -> HsConDeclGADTDetails pass
RecConGADT GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_flds LHsUniToken "->" "\8594" GhcPs
arr, FreeVars
fvs) }

rnRecConDeclFields ::
     Name
  -> HsDocContext
  -> LocatedL [LConDeclField GhcPs]
  -> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields :: Name
-> HsDocContext
-> LocatedL [LConDeclField GhcPs]
-> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields Name
con HsDocContext
doc (L SrcSpanAnnL
l [LConDeclField GhcPs]
fields)
  = do  { [FieldLabel]
fls <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
con
        ; ([GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_fields, FreeVars
fvs) <- HsDocContext
-> [FieldLabel]
-> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], FreeVars)
rnConDeclFields HsDocContext
doc [FieldLabel]
fls [LConDeclField GhcPs]
fields
                -- No need to check for duplicate fields
                -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
        ; forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_fields, FreeVars
fvs) }

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

-- | Brings pattern synonym names and also pattern synonym selectors
-- from record pattern synonyms into scope.
extendPatSynEnv :: DuplicateRecordFields -> FieldSelectors -> HsValBinds GhcPs -> MiniFixityEnv
                -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
extendPatSynEnv :: forall a.
DuplicateRecordFields
-> FieldSelectors
-> HsValBinds GhcPs
-> MiniFixityEnv
-> ([Name] -> TcRnIf TcGblEnv TcLclEnv a)
-> TcRnIf TcGblEnv TcLclEnv a
extendPatSynEnv DuplicateRecordFields
dup_fields_ok FieldSelectors
has_sel HsValBinds GhcPs
val_decls MiniFixityEnv
local_fix_env [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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Name
nameforall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector [FieldLabel]
fields
                                | (Name
name, [FieldLabel]
fields) <- [(Name, [FieldLabel])]
names_with_fls ]
   ; let avails :: [AvailInfo]
avails = forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, [FieldLabel])]
names_with_fls)
               forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> AvailInfo
availField (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Name, [FieldLabel])]
names_with_fls)
   ; (TcGblEnv
gbl_env, TcLclEnv
lcl_env) <- [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn [AvailInfo]
avails MiniFixityEnv
local_fix_env

   ; let field_env' :: NameEnv [FieldLabel]
field_env' = 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' }
   ; forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (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 XValBinds GhcPs GhcPs
_ LHsBinds GhcPs
binds [LSig GhcPs]
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM LHsBindLR GhcPs GhcPs
-> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
new_ps' [] LHsBinds GhcPs
binds
    new_ps HsValBinds GhcPs
_ = forall a. String -> a
panic String
"new_ps"

    new_ps' :: LHsBindLR GhcPs GhcPs
            -> [(Name, [FieldLabel])]
            -> TcM [(Name, [FieldLabel])]
    new_ps' :: LHsBindLR GhcPs GhcPs
-> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
new_ps' LHsBindLR GhcPs GhcPs
bind [(Name, [FieldLabel])]
names
      | (L SrcSpanAnnA
bind_loc (PatSynBind XPatSynBind GhcPs GhcPs
_ (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L SrcSpanAnnN
_ RdrName
n
                                       , psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = RecCon [RecordPatSynField GhcPs]
as }))) <- LHsBindLR GhcPs GhcPs
bind
      = do
          Name
bnd_name <- GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
newTopSrcBinder (forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnA
bind_loc) RdrName
n)
          let field_occs :: [GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)]
field_occs = forall a b. (a -> b) -> [a] -> [b]
map ((\ FieldOcc GhcPs
f -> forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan forall a b. (a -> b) -> a -> b
$ forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (forall pass. FieldOcc pass -> XRec pass RdrName
foLabel FieldOcc GhcPs
f)) FieldOcc GhcPs
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. RecordPatSynField pass -> FieldOcc pass
recordPatSynField) [RecordPatSynField GhcPs]
as
          [FieldLabel]
flds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DuplicateRecordFields
-> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
newRecordSelector DuplicateRecordFields
dup_fields_ok FieldSelectors
has_sel [Name
bnd_name]) [GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)]
field_occs
          forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
bnd_name, [FieldLabel]
flds)forall a. a -> [a] -> [a]
: [(Name, [FieldLabel])]
names)
      | L SrcSpanAnnA
bind_loc (PatSynBind XPatSynBind GhcPs GhcPs
_ (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L SrcSpanAnnN
_ RdrName
n})) <- LHsBindLR GhcPs GhcPs
bind
      = do
        Name
bnd_name <- GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
newTopSrcBinder (forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
bind_loc) RdrName
n)
        forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
bnd_name, [])forall a. a -> [a] -> [a]
: [(Name, [FieldLabel])]
names)
      | Bool
otherwise
      = 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 [LHsFunDep GhcPs]
fds
  = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA FunDep GhcPs -> RnM (FunDep GhcRn)
rn_fds) [LHsFunDep GhcPs]
fds
  where
    rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn)
    rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn)
rn_fds (FunDep XCFunDep GhcPs
x [LIdP GhcPs]
tys1 [LIdP GhcPs]
tys2)
      = do { [GenLocated SrcSpanAnnN Name]
tys1' <- [GenLocated SrcSpanAnnN RdrName]
-> RnM [GenLocated SrcSpanAnnN Name]
rnHsTyVars [LIdP GhcPs]
tys1
           ; [GenLocated SrcSpanAnnN Name]
tys2' <- [GenLocated SrcSpanAnnN RdrName]
-> RnM [GenLocated SrcSpanAnnN Name]
rnHsTyVars [LIdP GhcPs]
tys2
           ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCFunDep pass -> [LIdP pass] -> [LIdP pass] -> FunDep pass
FunDep XCFunDep GhcPs
x [GenLocated SrcSpanAnnN Name]
tys1' [GenLocated SrcSpanAnnN Name]
tys2') }

rnHsTyVars :: [LocatedN RdrName] -> RnM [LocatedN Name]
rnHsTyVars :: [GenLocated SrcSpanAnnN RdrName]
-> RnM [GenLocated SrcSpanAnnN Name]
rnHsTyVars [GenLocated SrcSpanAnnN RdrName]
tvs  = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnHsTyVar [GenLocated SrcSpanAnnN RdrName]
tvs

rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name)
rnHsTyVar :: GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnHsTyVar (L SrcSpanAnnN
l RdrName
tyvar) = do
  Name
tyvar' <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupOccRn RdrName
tyvar
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l 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 [LHsDecl GhcPs]
ds = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl 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 HsGroup GhcPs
gp []           = forall (m :: * -> *) a. Monad m => a -> m a
return (HsGroup GhcPs
gp, forall a. Maybe a
Nothing)
addl HsGroup GhcPs
gp (L SrcSpanAnnA
l HsDecl GhcPs
d : [LHsDecl GhcPs]
ds) = HsGroup GhcPs
-> SrcSpanAnnA
-> HsDecl GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
add HsGroup GhcPs
gp SrcSpanAnnA
l HsDecl GhcPs
d [LHsDecl GhcPs]
ds


add :: HsGroup GhcPs -> SrcSpanAnnA -> 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
-> SrcSpanAnnA
-> HsDecl GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
add HsGroup GhcPs
gp SrcSpanAnnA
_ (SpliceD XSpliceD GhcPs
_ (SpliceDecl XSpliceDecl GhcPs
_ (L SrcSpanAnnA
_ qq :: HsSplice GhcPs
qq@HsQuasiQuote{}) SpliceExplicitFlag
_)) [LHsDecl GhcPs]
ds
  = do { ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds', FreeVars
_) <- HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls HsSplice GhcPs
qq
       ; HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl HsGroup GhcPs
gp ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds' forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
ds)
       }

add HsGroup GhcPs
gp SrcSpanAnnA
loc (SpliceD XSpliceD GhcPs
_ splice :: SpliceDecl GhcPs
splice@(SpliceDecl XSpliceDecl GhcPs
_ XRec GhcPs (HsSplice GhcPs)
_ SpliceExplicitFlag
flag)) [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
           SpliceExplicitFlag
ExplicitSplice -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           SpliceExplicitFlag
ImplicitSplice -> do { Bool
th_on <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TemplateHaskell
                                ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
th_on forall a b. (a -> b) -> a -> b
$ forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$
                                  forall a. TcRnMessage -> TcM a
failWith TcRnMessage
badImplicitSplice }

       ; forall (m :: * -> *) a. Monad m => a -> m a
return (HsGroup GhcPs
gp, forall a. a -> Maybe a
Just (SpliceDecl GhcPs
splice, [LHsDecl GhcPs]
ds)) }
  where
    badImplicitSplice :: TcRnMessage
    badImplicitSplice :: TcRnMessage
badImplicitSplice = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
                        String -> SDoc
text String
"Parse error: module header, import declaration"
                     SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"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 #12146 for discussion.

-- Class declarations: added to the TyClGroup
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup GhcPs]
ts}) SrcSpanAnnA
l (TyClD XTyClD GhcPs
_ TyClDecl GhcPs
d) [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 = forall (p :: Pass).
LTyClDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_tycld (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l 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}) SrcSpanAnnA
l (SigD XSigD GhcPs
_ (FixSig XFixSig GhcPs
_ FixitySig GhcPs
f)) [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 = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l FixitySig GhcPs
f forall a. a -> [a] -> [a]
: [LFixitySig GhcPs]
ts}) [LHsDecl GhcPs]
ds

-- Standalone kind signatures: added to the TyClGroup
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup GhcPs]
ts}) SrcSpanAnnA
l (KindSigD XKindSigD GhcPs
_ StandaloneKindSig GhcPs
s) [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 = forall (p :: Pass).
LStandaloneKindSig (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_kisig (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l StandaloneKindSig GhcPs
s) [TyClGroup GhcPs]
ts}) [LHsDecl GhcPs]
ds

add gp :: HsGroup GhcPs
gp@(HsGroup {hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds = HsValBinds GhcPs
ts}) SrcSpanAnnA
l (SigD XSigD GhcPs
_ Sig GhcPs
d) [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 = forall (a :: Pass).
LSig (GhcPass a)
-> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l 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}) SrcSpanAnnA
l (ValD XValD GhcPs
_ HsBindLR GhcPs GhcPs
d) [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 = forall a. LHsBind a -> HsValBinds a -> HsValBinds a
add_bind (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsBindLR GhcPs 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}) SrcSpanAnnA
l (RoleAnnotD XRoleAnnotD GhcPs
_ RoleAnnotDecl GhcPs
d) [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 = forall (p :: Pass).
LRoleAnnotDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_role_annot (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l 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})  SrcSpanAnnA
l (InstD XInstD GhcPs
_ InstDecl GhcPs
d) [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 = forall (p :: Pass).
LInstDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_instd (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l 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})  SrcSpanAnnA
l (DerivD XDerivD GhcPs
_ DerivDecl GhcPs
d) [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 = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l DerivDecl GhcPs
d 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})  SrcSpanAnnA
l (DefD XDefD GhcPs
_ DefaultDecl GhcPs
d) [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 = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l DefaultDecl GhcPs
d 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}) SrcSpanAnnA
l (ForD XForD GhcPs
_ ForeignDecl GhcPs
d) [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 = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l ForeignDecl GhcPs
d 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})  SrcSpanAnnA
l (WarningD XWarningD GhcPs
_ WarnDecls GhcPs
d) [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 = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l WarnDecls GhcPs
d 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}) SrcSpanAnnA
l (AnnD XAnnD GhcPs
_ AnnDecl GhcPs
d) [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 = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l AnnDecl GhcPs
d 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}) SrcSpanAnnA
l (RuleD XRuleD GhcPs
_ RuleDecls GhcPs
d) [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 = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l RuleDecls GhcPs
d forall a. a -> [a] -> [a]
: [LRuleDecls GhcPs]
ts }) [LHsDecl GhcPs]
ds
add HsGroup GhcPs
gp SrcSpanAnnA
l (DocD XDocD GhcPs
_ DocDecl GhcPs
d) [LHsDecl GhcPs]
ds
  = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_docs :: [LDocDecl GhcPs]
hs_docs = (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l DocDecl GhcPs
d) forall a. a -> [a] -> [a]
: (forall p. HsGroup p -> [LDocDecl p]
hs_docs HsGroup GhcPs
gp) })  [LHsDecl GhcPs]
ds

add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
          -> [TyClGroup (GhcPass p)]
add_tycld :: forall (p :: Pass).
LTyClDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_tycld LTyClDecl (GhcPass p)
d []       = [TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext    = NoExtField
noExtField
                                  , group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = [LTyClDecl (GhcPass p)
d]
                                  , group_kisigs :: [LStandaloneKindSig (GhcPass p)]
group_kisigs = []
                                  , group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles  = []
                                  , group_instds :: [LInstDecl (GhcPass p)]
group_instds = []
                                  }
                       ]
add_tycld LTyClDecl (GhcPass p)
d (ds :: TyClGroup (GhcPass p)
ds@(TyClGroup { group_tyclds :: forall pass. TyClGroup pass -> [LTyClDecl pass]
group_tyclds = [LTyClDecl (GhcPass p)]
tyclds }):[TyClGroup (GhcPass p)]
dss)
  = TyClGroup (GhcPass p)
ds { group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = LTyClDecl (GhcPass p)
d forall a. a -> [a] -> [a]
: [LTyClDecl (GhcPass p)]
tyclds } forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
dss

add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
          -> [TyClGroup (GhcPass p)]
add_instd :: forall (p :: Pass).
LInstDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_instd LInstDecl (GhcPass p)
d []       = [TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext    = NoExtField
noExtField
                                  , group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = []
                                  , group_kisigs :: [LStandaloneKindSig (GhcPass p)]
group_kisigs = []
                                  , group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles  = []
                                  , group_instds :: [LInstDecl (GhcPass p)]
group_instds = [LInstDecl (GhcPass p)
d]
                                  }
                       ]
add_instd LInstDecl (GhcPass p)
d (ds :: TyClGroup (GhcPass p)
ds@(TyClGroup { group_instds :: forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds = [LInstDecl (GhcPass p)]
instds }):[TyClGroup (GhcPass p)]
dss)
  = TyClGroup (GhcPass p)
ds { group_instds :: [LInstDecl (GhcPass p)]
group_instds = LInstDecl (GhcPass p)
d forall a. a -> [a] -> [a]
: [LInstDecl (GhcPass p)]
instds } forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
dss

add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
               -> [TyClGroup (GhcPass p)]
add_role_annot :: forall (p :: Pass).
LRoleAnnotDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_role_annot LRoleAnnotDecl (GhcPass p)
d [] = [TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext    = NoExtField
noExtField
                                 , group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = []
                                 , group_kisigs :: [LStandaloneKindSig (GhcPass p)]
group_kisigs = []
                                 , group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles  = [LRoleAnnotDecl (GhcPass p)
d]
                                 , group_instds :: [LInstDecl (GhcPass p)]
group_instds = []
                                 }
                      ]
add_role_annot LRoleAnnotDecl (GhcPass p)
d (tycls :: TyClGroup (GhcPass p)
tycls@(TyClGroup { group_roles :: forall pass. TyClGroup pass -> [LRoleAnnotDecl pass]
group_roles = [LRoleAnnotDecl (GhcPass p)]
roles }) : [TyClGroup (GhcPass p)]
rest)
  = TyClGroup (GhcPass p)
tycls { group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles = LRoleAnnotDecl (GhcPass p)
d forall a. a -> [a] -> [a]
: [LRoleAnnotDecl (GhcPass p)]
roles } forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
rest

add_kisig :: LStandaloneKindSig (GhcPass p)
         -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_kisig :: forall (p :: Pass).
LStandaloneKindSig (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_kisig LStandaloneKindSig (GhcPass p)
d [] = [TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext    = NoExtField
noExtField
                            , group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = []
                            , group_kisigs :: [LStandaloneKindSig (GhcPass p)]
group_kisigs = [LStandaloneKindSig (GhcPass p)
d]
                            , group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles  = []
                            , group_instds :: [LInstDecl (GhcPass p)]
group_instds = []
                            }
                 ]
add_kisig LStandaloneKindSig (GhcPass p)
d (tycls :: TyClGroup (GhcPass p)
tycls@(TyClGroup { group_kisigs :: forall pass. TyClGroup pass -> [LStandaloneKindSig pass]
group_kisigs = [LStandaloneKindSig (GhcPass p)]
kisigs }) : [TyClGroup (GhcPass p)]
rest)
  = TyClGroup (GhcPass p)
tycls { group_kisigs :: [LStandaloneKindSig (GhcPass p)]
group_kisigs = LStandaloneKindSig (GhcPass p)
d forall a. a -> [a] -> [a]
: [LStandaloneKindSig (GhcPass p)]
kisigs } forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
rest

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

add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig :: forall (a :: Pass).
LSig (GhcPass a)
-> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig LSig (GhcPass a)
s (ValBinds XValBinds (GhcPass a) (GhcPass a)
x LHsBindsLR (GhcPass a) (GhcPass a)
bs [LSig (GhcPass a)]
sigs) = 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)
sforall a. a -> [a] -> [a]
:[LSig (GhcPass a)]
sigs)
add_sig LSig (GhcPass a)
_ (XValBindsLR {})     = forall a. String -> a
panic String
"GHC.Rename.Module.add_sig"