{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Rename.Module (
rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt
) where
import GHC.Prelude hiding ( head )
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 (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 GHC.Core.DataCon ( isSrcStrict )
import Control.Monad
import Control.Arrow ( first )
import Data.Foldable ( toList )
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..), head )
import Data.Maybe ( isNothing, fromMaybe, mapMaybe )
import qualified Data.Set as Set ( difference, fromList, toList, null )
import Data.Function ( on )
rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)
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 {
MiniFixityEnv
local_fix_env <- [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv ([LFixitySig GhcPs] -> RnM MiniFixityEnv)
-> [LFixitySig GhcPs] -> RnM MiniFixityEnv
forall a b. (a -> b) -> a -> b
$ HsGroup GhcPs -> [LFixitySig GhcPs]
forall (p :: Pass). HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)]
hsGroupTopLevelFixitySigs HsGroup GhcPs
group ;
((TcGblEnv, TcLclEnv)
tc_envs, FreeVars
tc_bndrs) <- MiniFixityEnv
-> HsGroup GhcPs -> RnM ((TcGblEnv, TcLclEnv), FreeVars)
getLocalNonValBinders MiniFixityEnv
local_fix_env HsGroup GhcPs
group ;
(TcGblEnv, TcLclEnv)
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv, TcLclEnv)
tc_envs (RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$ do {
TcRn ()
failIfErrsM ;
DuplicateRecordFields
dup_fields_ok <- DynFlags -> DuplicateRecordFields
xopt_DuplicateRecordFields (DynFlags -> DuplicateRecordFields)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) DuplicateRecordFields
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags ;
FieldSelectors
has_sel <- DynFlags -> FieldSelectors
xopt_FieldSelectors (DynFlags -> FieldSelectors)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) FieldSelectors
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags ;
DuplicateRecordFields
-> FieldSelectors
-> HsValBinds GhcPs
-> MiniFixityEnv
-> ([Name] -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn)
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] -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn))
-> ([Name] -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$ \[Name]
pat_syn_bndrs -> do {
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 ;
let { id_bndrs :: [IdP GhcRn]
id_bndrs = CollectFlag GhcRn -> HsValBindsLR GhcRn GhcPs -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectHsIdBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders HsValBindsLR GhcRn GhcPs
new_lhs } ;
String -> SDoc -> TcRn ()
traceRn String
"rnSrcDecls" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IdP GhcRn]
[Name]
id_bndrs) ;
(TcGblEnv, TcLclEnv)
tc_envs <- [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn ((Name -> AvailInfo) -> [Name] -> [AvailInfo]
forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail [IdP GhcRn]
[Name]
id_bndrs) MiniFixityEnv
local_fix_env ;
(TcGblEnv, TcLclEnv)
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv, TcLclEnv)
tc_envs (RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> TcRn ()
traceRn String
"Start rnTyClDecls" ([TyClGroup GhcPs] -> SDoc
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 ;
String -> SDoc -> TcRn ()
traceRn String
"Start rnmono" SDoc
forall doc. IsOutput doc => doc
empty ;
let { val_bndr_set :: FreeVars
val_bndr_set = [Name] -> FreeVars
mkNameSet [IdP GhcRn]
[Name]
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
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" (HsValBinds GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBinds GhcRn
rn_val_decls) ;
let { all_bndrs :: FreeVars
all_bndrs = FreeVars
tc_bndrs FreeVars -> FreeVars -> FreeVars
`unionNameSet` FreeVars
val_bndr_set } ;
[GenLocated SrcSpanAnnA (FixitySig GhcRn)]
rn_fix_decls <- (GenLocated SrcSpanAnnA (FixitySig GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (FixitySig GhcRn)))
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnA (FixitySig GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((FixitySig GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (FixitySig GhcRn))
-> GenLocated SrcSpanAnnA (FixitySig GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (FixitySig GhcRn))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b)
-> GenLocated SrcSpanAnnA a -> m (GenLocated SrcSpanAnnA b)
mapM (HsSigCtxt
-> FixitySig GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (FixitySig GhcRn)
rnSrcFixityDecl (FreeVars -> HsSigCtxt
TopSigCtxt FreeVars
all_bndrs)))
[LFixitySig GhcPs]
[GenLocated SrcSpanAnnA (FixitySig GhcPs)]
fix_decls ;
Warnings GhcRn
rn_warns <- FreeVars -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn)
rnSrcWarnDecls FreeVars
all_bndrs [LWarnDecls GhcPs]
warn_decls ;
([LocatedA (RuleDecls GhcRn)]
rn_rule_decls, FreeVars
src_fvs2) <- Extension
-> TcRnIf
TcGblEnv TcLclEnv ([LocatedA (RuleDecls GhcRn)], FreeVars)
-> TcRnIf
TcGblEnv TcLclEnv ([LocatedA (RuleDecls GhcRn)], FreeVars)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.ScopedTypeVariables (TcRnIf TcGblEnv TcLclEnv ([LocatedA (RuleDecls GhcRn)], FreeVars)
-> TcRnIf
TcGblEnv TcLclEnv ([LocatedA (RuleDecls GhcRn)], FreeVars))
-> TcRnIf
TcGblEnv TcLclEnv ([LocatedA (RuleDecls GhcRn)], FreeVars)
-> TcRnIf
TcGblEnv TcLclEnv ([LocatedA (RuleDecls GhcRn)], FreeVars)
forall a b. (a -> b) -> a -> b
$
(RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars))
-> [LocatedA (RuleDecls GhcPs)]
-> TcRnIf
TcGblEnv TcLclEnv ([LocatedA (RuleDecls GhcRn)], FreeVars)
forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
rnHsRuleDecls [LRuleDecls GhcPs]
[LocatedA (RuleDecls GhcPs)]
rule_decls ;
([LocatedA (ForeignDecl GhcRn)]
rn_foreign_decls, FreeVars
src_fvs3) <- (ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars))
-> [LocatedA (ForeignDecl GhcPs)]
-> RnM ([LocatedA (ForeignDecl GhcRn)], FreeVars)
forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
rnHsForeignDecl [LForeignDecl GhcPs]
[LocatedA (ForeignDecl GhcPs)]
foreign_decls ;
([LocatedA (AnnDecl GhcRn)]
rn_ann_decls, FreeVars
src_fvs4) <- (AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars))
-> [LocatedA (AnnDecl GhcPs)]
-> RnM ([LocatedA (AnnDecl GhcRn)], FreeVars)
forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl [LAnnDecl GhcPs]
[LocatedA (AnnDecl GhcPs)]
ann_decls ;
([LocatedA (DefaultDecl GhcRn)]
rn_default_decls, FreeVars
src_fvs5) <- (DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars))
-> [LocatedA (DefaultDecl GhcPs)]
-> RnM ([LocatedA (DefaultDecl GhcRn)], FreeVars)
forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
rnDefaultDecl [LDefaultDecl GhcPs]
[LocatedA (DefaultDecl GhcPs)]
default_decls ;
([LocatedA (DerivDecl GhcRn)]
rn_deriv_decls, FreeVars
src_fvs6) <- (DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars))
-> [LocatedA (DerivDecl GhcPs)]
-> RnM ([LocatedA (DerivDecl GhcRn)], FreeVars)
forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
rnSrcDerivDecl [LDerivDecl GhcPs]
[LocatedA (DerivDecl GhcPs)]
deriv_decls ;
([LocatedA (SpliceDecl GhcRn)]
rn_splice_decls, FreeVars
src_fvs7) <- (SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars))
-> [LocatedA (SpliceDecl GhcPs)]
-> RnM ([LocatedA (SpliceDecl GhcRn)], FreeVars)
forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
rnSpliceDecl [LSpliceDecl GhcPs]
[LocatedA (SpliceDecl GhcPs)]
splice_decls ;
[GenLocated SrcSpanAnnA (DocDecl GhcRn)]
rn_docs <- (GenLocated SrcSpanAnnA (DocDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (DocDecl GhcRn)))
-> [GenLocated SrcSpanAnnA (DocDecl GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnA (DocDecl GhcRn)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LDocDecl GhcPs -> RnM (LDocDecl GhcRn)
GenLocated SrcSpanAnnA (DocDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (DocDecl GhcRn))
rnLDocDecl [LDocDecl GhcPs]
[GenLocated SrcSpanAnnA (DocDecl GhcPs)]
docs ;
TcGblEnv
last_tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv ;
let {rn_group :: HsGroup GhcRn
rn_group = HsGroup { hs_ext :: XCHsGroup GhcRn
hs_ext = XCHsGroup GhcRn
NoExtField
noExtField,
hs_valds :: HsValBinds GhcRn
hs_valds = HsValBinds GhcRn
rn_val_decls,
hs_splcds :: [LSpliceDecl GhcRn]
hs_splcds = [LSpliceDecl GhcRn]
[LocatedA (SpliceDecl GhcRn)]
rn_splice_decls,
hs_tyclds :: [TyClGroup GhcRn]
hs_tyclds = [TyClGroup GhcRn]
rn_tycl_decls,
hs_derivds :: [LDerivDecl GhcRn]
hs_derivds = [LDerivDecl GhcRn]
[LocatedA (DerivDecl GhcRn)]
rn_deriv_decls,
hs_fixds :: [LFixitySig GhcRn]
hs_fixds = [LFixitySig GhcRn]
[GenLocated SrcSpanAnnA (FixitySig GhcRn)]
rn_fix_decls,
hs_warnds :: [LWarnDecls GhcRn]
hs_warnds = [],
hs_fords :: [LForeignDecl GhcRn]
hs_fords = [LForeignDecl GhcRn]
[LocatedA (ForeignDecl GhcRn)]
rn_foreign_decls,
hs_annds :: [LAnnDecl GhcRn]
hs_annds = [LAnnDecl GhcRn]
[LocatedA (AnnDecl GhcRn)]
rn_ann_decls,
hs_defds :: [LDefaultDecl GhcRn]
hs_defds = [LDefaultDecl GhcRn]
[LocatedA (DefaultDecl GhcRn)]
rn_default_decls,
hs_ruleds :: [LRuleDecls GhcRn]
hs_ruleds = [LRuleDecls GhcRn]
[LocatedA (RuleDecls GhcRn)]
rn_rule_decls,
hs_docs :: [LDocDecl GhcRn]
hs_docs = [LDocDecl GhcRn]
[GenLocated SrcSpanAnnA (DocDecl GhcRn)]
rn_docs } ;
tcf_bndrs :: [Name]
tcf_bndrs = [TyClGroup GhcRn] -> [LForeignDecl GhcRn] -> [Name]
hsTyClForeignBinders [TyClGroup GhcRn]
rn_tycl_decls [LForeignDecl GhcRn]
[LocatedA (ForeignDecl GhcRn)]
rn_foreign_decls ;
other_def :: (Maybe FreeVars, FreeVars)
other_def = (FreeVars -> Maybe FreeVars
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] ;
src_dus :: DefUses
src_dus = (Maybe FreeVars, FreeVars) -> DefUses
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 ;
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
TcGblEnv
tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
} ;
String -> SDoc -> TcRn ()
traceRn String
"finish rnSrc" (HsGroup GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsGroup GhcRn
rn_group) ;
String -> SDoc -> TcRn ()
traceRn String
"finish Dus" (DefUses -> SDoc
forall a. Outputable a => a -> SDoc
ppr DefUses
src_dus ) ;
(TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
final_tcg_env, HsGroup GhcRn
rn_group)
}}}}
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
addTcgDUs TcGblEnv
tcg_env DefUses
dus = TcGblEnv
tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` 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 = (LocatedA a -> RnM (LocatedA b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn ((a -> RnM (b, FreeVars))
-> LocatedA a -> RnM (LocatedA b, FreeVars)
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
rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn)
rnSrcWarnDecls :: FreeVars -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn)
rnSrcWarnDecls FreeVars
_ []
= Warnings GhcRn -> RnM (Warnings GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Warnings GhcRn
forall pass. Warnings pass
NoWarnings
rnSrcWarnDecls FreeVars
bndr_set [LWarnDecls GhcPs]
decls'
= do {
; (NonEmpty (GenLocated SrcSpanAnnN RdrName) -> TcRn ())
-> [NonEmpty (GenLocated SrcSpanAnnN RdrName)] -> TcRn ()
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':FreeKiTyVars
_)) = NonEmpty (GenLocated SrcSpanAnnN RdrName)
dups
in SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (SrcSpanAnnN -> SrcSpan
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 <- (GenLocated SrcSpanAnnA (WarnDecl GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt GhcRn)])
-> [GenLocated SrcSpanAnnA (WarnDecl GhcPs)]
-> IOEnv (Env TcGblEnv TcLclEnv) [[(OccName, WarningTxt GhcRn)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((WarnDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt GhcRn)])
-> GenLocated SrcSpanAnnA (WarnDecl GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt GhcRn)]
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
; Warnings GhcRn -> RnM (Warnings GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(OccName, WarningTxt GhcRn)] -> Warnings GhcRn
forall pass. [(OccName, WarningTxt pass)] -> Warnings pass
WarnSome (([[(OccName, WarningTxt GhcRn)]] -> [(OccName, WarningTxt GhcRn)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(OccName, WarningTxt GhcRn)]]
pairs_s))) }
where
decls :: [GenLocated SrcSpanAnnA (WarnDecl GhcPs)]
decls = (GenLocated SrcSpanAnnA (WarnDecls GhcPs)
-> [GenLocated SrcSpanAnnA (WarnDecl GhcPs)])
-> [GenLocated SrcSpanAnnA (WarnDecls GhcPs)]
-> [GenLocated SrcSpanAnnA (WarnDecl GhcPs)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (WarnDecls GhcPs -> [LWarnDecl GhcPs]
WarnDecls GhcPs -> [GenLocated SrcSpanAnnA (WarnDecl GhcPs)]
forall pass. WarnDecls pass -> [LWarnDecl pass]
wd_warnings (WarnDecls GhcPs -> [GenLocated SrcSpanAnnA (WarnDecl GhcPs)])
-> (GenLocated SrcSpanAnnA (WarnDecls GhcPs) -> WarnDecls GhcPs)
-> GenLocated SrcSpanAnnA (WarnDecls GhcPs)
-> [GenLocated SrcSpanAnnA (WarnDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (WarnDecls GhcPs) -> WarnDecls GhcPs
forall l e. GenLocated l e -> e
unLoc) [LWarnDecls GhcPs]
[GenLocated SrcSpanAnnA (WarnDecls 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)
= do { [(RdrName, Name)]
names <- (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)])
-> FreeKiTyVars -> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (HsSigCtxt
-> SDoc
-> RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)]
lookupLocalTcNames HsSigCtxt
sig_ctxt SDoc
what (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)])
-> (GenLocated SrcSpanAnnN RdrName -> RdrName)
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc)
[LIdP GhcPs]
FreeKiTyVars
rdr_names
; WarningTxt GhcRn
txt' <- WarningTxt GhcPs -> RnM (WarningTxt GhcRn)
rnWarningTxt WarningTxt GhcPs
txt
; [(OccName, WarningTxt GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt GhcRn)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
forall doc. IsLine doc => String -> doc
text String
"deprecation"
warn_rdr_dups :: [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
warn_rdr_dups = FreeKiTyVars -> [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
findDupRdrNames
(FreeKiTyVars -> [NonEmpty (GenLocated SrcSpanAnnN RdrName)])
-> FreeKiTyVars -> [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (WarnDecl GhcPs) -> FreeKiTyVars)
-> [GenLocated SrcSpanAnnA (WarnDecl GhcPs)] -> FreeKiTyVars
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(L SrcSpanAnnA
_ (Warning XWarning GhcPs
_ [LIdP GhcPs]
ns WarningTxt GhcPs
_)) -> [LIdP GhcPs]
FreeKiTyVars
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' <- (Located (WithHsDocIdentifiers StringLiteral GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn)))
-> [Located (WithHsDocIdentifiers StringLiteral GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((WithHsDocIdentifiers StringLiteral GhcPs
-> IOEnv
(Env TcGblEnv TcLclEnv) (WithHsDocIdentifiers StringLiteral GhcRn))
-> Located (WithHsDocIdentifiers StringLiteral GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenLocated SrcSpan a -> f (GenLocated SrcSpan b)
traverse WithHsDocIdentifiers StringLiteral GhcPs
-> IOEnv
(Env TcGblEnv TcLclEnv) (WithHsDocIdentifiers StringLiteral GhcRn)
forall a.
WithHsDocIdentifiers a GhcPs -> RnM (WithHsDocIdentifiers a GhcRn)
rnHsDoc) [Located (WithHsDocIdentifiers StringLiteral GhcPs)]
wst
WarningTxt GhcRn -> RnM (WarningTxt GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located SourceText
-> [GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn)]
-> WarningTxt GhcRn
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' <- (Located (WithHsDocIdentifiers StringLiteral GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn)))
-> [Located (WithHsDocIdentifiers StringLiteral GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((WithHsDocIdentifiers StringLiteral GhcPs
-> IOEnv
(Env TcGblEnv TcLclEnv) (WithHsDocIdentifiers StringLiteral GhcRn))
-> Located (WithHsDocIdentifiers StringLiteral GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenLocated SrcSpan a -> f (GenLocated SrcSpan b)
traverse WithHsDocIdentifiers StringLiteral GhcPs
-> IOEnv
(Env TcGblEnv TcLclEnv) (WithHsDocIdentifiers StringLiteral GhcRn)
forall a.
WithHsDocIdentifiers a GhcPs -> RnM (WithHsDocIdentifiers a GhcRn)
rnHsDoc) [Located (WithHsDocIdentifiers StringLiteral GhcPs)]
wst
WarningTxt GhcRn -> RnM (WarningTxt GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located SourceText
-> [GenLocated SrcSpan (WithHsDocIdentifiers StringLiteral GhcRn)]
-> WarningTxt GhcRn
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 :: FreeKiTyVars -> [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
findDupRdrNames = (GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnN RdrName -> Bool)
-> FreeKiTyVars -> [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (\ GenLocated SrcSpanAnnN RdrName
x -> \ GenLocated SrcSpanAnnN RdrName
y -> RdrName -> OccName
rdrNameOcc (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
x) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
y))
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl ann :: AnnDecl GhcPs
ann@(HsAnnotation (EpAnn AnnPragma
_, SourceText
s) AnnProvenance GhcPs
provenance XRec GhcPs (HsExpr GhcPs)
expr)
= SDoc
-> RnM (AnnDecl GhcRn, FreeVars) -> RnM (AnnDecl GhcRn, FreeVars)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (AnnDecl GhcPs -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
AnnDecl (GhcPass p) -> SDoc
annCtxt AnnDecl GhcPs
ann) (RnM (AnnDecl GhcRn, FreeVars) -> RnM (AnnDecl GhcRn, FreeVars))
-> RnM (AnnDecl GhcRn, FreeVars) -> RnM (AnnDecl GhcRn, FreeVars)
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) <- ThStage
-> TcM (LHsExpr GhcRn, FreeVars) -> TcM (LHsExpr GhcRn, FreeVars)
forall a. ThStage -> TcM a -> TcM a
setStage (SpliceType -> ThStage
Splice SpliceType
Untyped) (TcM (LHsExpr GhcRn, FreeVars) -> TcM (LHsExpr GhcRn, FreeVars))
-> TcM (LHsExpr GhcRn, FreeVars) -> TcM (LHsExpr GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
XRec GhcPs (HsExpr GhcPs) -> TcM (LHsExpr GhcRn, FreeVars)
rnLExpr XRec GhcPs (HsExpr GhcPs)
expr
; (AnnDecl GhcRn, FreeVars) -> RnM (AnnDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsAnnotation GhcRn
-> AnnProvenance GhcRn -> LHsExpr GhcRn -> AnnDecl GhcRn
forall pass.
XHsAnnotation pass
-> AnnProvenance pass -> XRec pass (HsExpr pass) -> AnnDecl pass
HsAnnotation (EpAnn AnnPragma
forall a. EpAnn a
noAnn, SourceText
s) AnnProvenance GhcRn
provenance' LHsExpr GhcRn
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 -> LIdP GhcRn -> AnnProvenance GhcRn
GenLocated SrcSpanAnnN Name -> AnnProvenance GhcRn
forall pass. LIdP pass -> AnnProvenance pass
ValueAnnProvenance
(GenLocated SrcSpanAnnN Name -> AnnProvenance GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (AnnProvenance GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
n
TypeAnnProvenance LIdP GhcPs
n -> LIdP GhcRn -> AnnProvenance GhcRn
GenLocated SrcSpanAnnN Name -> AnnProvenance GhcRn
forall pass. LIdP pass -> AnnProvenance pass
TypeAnnProvenance
(GenLocated SrcSpanAnnN Name -> AnnProvenance GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (AnnProvenance GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
n
AnnProvenance GhcPs
ModuleAnnProvenance -> AnnProvenance GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (AnnProvenance GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return AnnProvenance GhcRn
forall pass. AnnProvenance pass
ModuleAnnProvenance
(AnnProvenance GhcRn, FreeVars)
-> RnM (AnnProvenance GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnProvenance GhcRn
provenance', FreeVars -> (Name -> FreeVars) -> Maybe Name -> FreeVars
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FreeVars
emptyFVs Name -> FreeVars
unitFV (AnnProvenance GhcRn -> Maybe (IdP GhcRn)
forall p. UnXRec p => AnnProvenance p -> Maybe (IdP p)
annProvenanceName_maybe AnnProvenance GhcRn
provenance'))
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
; (DefaultDecl GhcRn, FreeVars) -> RnM (DefaultDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCDefaultDecl GhcRn -> [LHsType GhcRn] -> DefaultDecl GhcRn
forall pass.
XCDefaultDecl pass -> [LHsType pass] -> DefaultDecl pass
DefaultDecl XCDefaultDecl GhcRn
NoExtField
noExtField [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys', FreeVars
fvs) }
where
doc_str :: HsDocContext
doc_str = HsDocContext
DefaultDeclCtx
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 pass
fd_fi = ForeignImport GhcPs
spec })
= do { HscEnv
topEnv :: HscEnv <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; GenLocated SrcSpanAnnN RdrName -> TcRn ()
warnForallIdentifier LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name
; GenLocated SrcSpanAnnN Name
name' <- GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name
; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty', FreeVars
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType (GenLocated SrcSpanAnnN RdrName -> HsDocContext
ForeignDeclCtx LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name) TypeOrKind
TypeLevel LHsSigType GhcPs
ty
; let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
topEnv
spec' :: ForeignImport GhcRn
spec' = Unit -> ForeignImport GhcPs -> ForeignImport GhcRn
patchForeignImport (HomeUnit -> Unit
homeUnitAsUnit HomeUnit
home_unit) ForeignImport GhcPs
spec
; (ForeignDecl GhcRn, FreeVars) -> RnM (ForeignDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport { fd_i_ext :: XForeignImport GhcRn
fd_i_ext = XForeignImport GhcRn
NoExtField
noExtField
, fd_name :: LIdP GhcRn
fd_name = LIdP GhcRn
GenLocated SrcSpanAnnN Name
name', fd_sig_ty :: LHsSigType GhcRn
fd_sig_ty = LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty'
, fd_fi :: ForeignImport GhcRn
fd_fi = ForeignImport GhcRn
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 pass
fd_fe = ForeignExport GhcPs
spec })
= do { GenLocated SrcSpanAnnN Name
name' <- GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
forall ann.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupLocatedOccRn LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name
; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty', FreeVars
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType (GenLocated SrcSpanAnnN RdrName -> HsDocContext
ForeignDeclCtx LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name) TypeOrKind
TypeLevel LHsSigType GhcPs
ty
; (ForeignDecl GhcRn, FreeVars) -> RnM (ForeignDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignExport { fd_e_ext :: XForeignExport GhcRn
fd_e_ext = XForeignExport GhcRn
NoExtField
noExtField
, fd_name :: LIdP GhcRn
fd_name = LIdP GhcRn
GenLocated SrcSpanAnnN Name
name', fd_sig_ty :: LHsSigType GhcRn
fd_sig_ty = LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty'
, fd_fe :: ForeignExport GhcRn
fd_fe = (\(CExport XCExport GhcPs
x XRec GhcPs CExportSpec
c) -> XCExport GhcRn -> XRec GhcRn CExportSpec -> ForeignExport GhcRn
forall pass.
XCExport pass -> XRec pass CExportSpec -> ForeignExport pass
CExport XCExport GhcPs
XCExport GhcRn
x XRec GhcPs CExportSpec
XRec GhcRn CExportSpec
c) ForeignExport GhcPs
spec }
, FreeVars
fvs FreeVars -> Name -> FreeVars
`addOneFV` GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
name') }
patchForeignImport :: Unit -> (ForeignImport GhcPs) -> (ForeignImport GhcRn)
patchForeignImport :: Unit -> ForeignImport GhcPs -> ForeignImport GhcRn
patchForeignImport Unit
unit (CImport XCImport GhcPs
ext XRec GhcPs CCallConv
cconv XRec GhcPs Safety
safety Maybe Header
fs CImportSpec
spec)
= XCImport GhcRn
-> XRec GhcRn CCallConv
-> XRec GhcRn Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport GhcRn
forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcPs
XCImport GhcRn
ext XRec GhcPs CCallConv
XRec GhcRn CCallConv
cconv XRec GhcPs Safety
XRec GhcRn Safety
safety Maybe Header
fs (Unit -> CImportSpec -> CImportSpec
patchCImportSpec Unit
unit CImportSpec
spec)
patchCImportSpec :: Unit -> CImportSpec -> CImportSpec
patchCImportSpec :: Unit -> CImportSpec -> CImportSpec
patchCImportSpec Unit
unit CImportSpec
spec
= case CImportSpec
spec of
CFunction CCallTarget
callTarget -> CCallTarget -> CImportSpec
CFunction (CCallTarget -> CImportSpec) -> CCallTarget -> CImportSpec
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 (Unit -> Maybe Unit
forall a. a -> Maybe a
Just Unit
unit) Bool
isFun
CCallTarget
_ -> CCallTarget
callTarget
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
; (InstDecl GhcRn, FreeVars) -> RnM (InstDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyFamInstD { tfid_ext :: XTyFamInstD GhcRn
tfid_ext = XTyFamInstD GhcRn
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
; (InstDecl GhcRn, FreeVars) -> RnM (InstDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DataFamInstD { dfid_ext :: XDataFamInstD GhcRn
dfid_ext = XDataFamInstD GhcRn
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 {" (ClsInstDecl GhcPs -> SDoc
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
forall doc. IsOutput doc => doc
empty
; (InstDecl GhcRn, FreeVars) -> RnM (InstDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstD { cid_d_ext :: XClsInstD GhcRn
cid_d_ext = XClsInstD GhcRn
NoExtField
noExtField, cid_inst :: ClsInstDecl GhcRn
cid_inst = ClsInstDecl GhcRn
cid' }, FreeVars
fvs) }
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
WarningFlag -> TcRn () -> TcRn ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNonCanonicalMonadInstances
(TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> TcRn ()
checkCanonicalMonadInstances
String
"https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"
WarningFlag -> TcRn () -> TcRn ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNonCanonicalMonoidInstances
(TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> TcRn ()
checkCanonicalMonoidInstances
String
"https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"
where
checkCanonicalMonadInstances :: String -> TcRn ()
checkCanonicalMonadInstances String
refURL
| Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
applicativeClassName =
[GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds) ((GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ())
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
pureAName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Name
forall a. a -> Maybe a
Just Name
returnMName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"pure" String
"return"
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
thenAName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Name
forall a. a -> Maybe a
Just Name
thenMName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"(*>)" String
"(>>)"
HsBindLR GhcRn GhcRn
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
monadClassName =
[GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds) ((GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ())
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
returnMName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Maybe Name
forall a. a -> Maybe a
Just Name
pureAName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"return" String
"pure"
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
thenMName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Maybe Name
forall a. a -> Maybe a
Just Name
thenAName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"(>>)" String
"(*>)"
HsBindLR GhcRn GhcRn
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCanonicalMonoidInstances :: String -> TcRn ()
checkCanonicalMonoidInstances String
refURL
| Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
semigroupClassName =
[GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds) ((GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ())
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
sappendName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Name
forall a. a -> Maybe a
Just Name
mappendName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonoidInstances String
"(<>)" String
"mappend"
HsBindLR GhcRn GhcRn
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
monoidClassName =
[GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds) ((GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ())
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
mappendName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Maybe Name
forall a. a -> Maybe a
Just Name
sappendName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonoidInstances
String
"mappend" String
"(<>)"
HsBindLR GhcRn GhcRn
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 <- GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcRn)
body = Name -> Maybe Name
forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
lrhsName)
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
_ = Maybe Name
forall a. Maybe a
Nothing
addWarnNonCanonicalMethod1 :: String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL WarningFlag
flag String
lhs String
rhs = do
let dia :: TcRnMessage
dia = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
flag) [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Noncanonical" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
lhs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rhs)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"definition detected"
, LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
poly_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Move definition from" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
rhs) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"to" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
lhs)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"See also:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
refURL
]
TcRnMessage -> TcRn ()
addDiagnostic TcRnMessage
dia
addWarnNonCanonicalMethod2 :: String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL WarningFlag
flag String
lhs String
rhs = do
let dia :: TcRnMessage
dia = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
flag) [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Noncanonical" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
lhs) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"definition detected"
, LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
poly_ty
, SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
lhs) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"will eventually be removed in favour of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
rhs)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Either remove definition for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
lhs) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(recommended)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"or define as" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
lhs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rhs))
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"See also:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
refURL
]
TcRnMessage -> TcRn ()
addDiagnostic TcRnMessage
dia
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
hs_inst_ty
= SDoc -> SDoc
inst_decl_ctxt (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsSigType GhcRn -> LHsType GhcRn
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
forall doc. IsLine doc => String -> doc
text String
"in the instance declaration for")
Int
2 (SDoc -> SDoc
quotes SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
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 LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty'
mb_nested_msg :: Maybe (SrcSpan, TcRnMessage)
mb_nested_msg = SDoc -> LHsType GhcRn -> Maybe (SrcSpan, TcRnMessage)
noNestedForallsContextsErr
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Instance head") LHsType GhcRn
head_ty'
eith_cls :: Either (SrcSpan, TcRnMessage) Name
eith_cls = case LHsType GhcRn -> Maybe (LocatedN (IdP GhcRn))
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) -> Name -> Either (SrcSpan, TcRnMessage) Name
forall a b. b -> Either a b
Right IdP GhcRn
Name
cls
Maybe (LocatedN (IdP GhcRn))
Nothing -> (SrcSpan, TcRnMessage) -> Either (SrcSpan, TcRnMessage) Name
forall a b. a -> Either a b
Left
( GenLocated SrcSpanAnnA (HsType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
head_ty'
, DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Illegal head of an instance declaration:"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
head_ty'))
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Instance heads must be of the form"
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"C ty_1 ... ty_n"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"where" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'C')
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is a class"
])
)
; Name
cls <- case (Maybe (SrcSpan, TcRnMessage)
mb_nested_msg, Either (SrcSpan, TcRnMessage) Name
eith_cls) of
(Maybe (SrcSpan, TcRnMessage)
Nothing, Right Name
cls) -> Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
cls
(Just (SrcSpan, TcRnMessage)
err1, Either (SrcSpan, TcRnMessage) Name
_) -> (SrcSpan, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) Name
bail_out (SrcSpan, TcRnMessage)
err1
(Maybe (SrcSpan, TcRnMessage)
_, Left (SrcSpan, TcRnMessage)
err2) -> (SrcSpan, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) Name
bail_out (SrcSpan, TcRnMessage)
err2
; (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 LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty' LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds'
; String -> SDoc -> TcRn ()
traceRn String
"rnSrcInstDecl" (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty' SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
ktv_names)
; (([LocatedA (TyFamInstDecl GhcRn)]
ats', [LocatedA (DataFamInstDecl GhcRn)]
adts'), FreeVars
more_fvs)
<- [Name]
-> RnM
(([LocatedA (TyFamInstDecl GhcRn)],
[LocatedA (DataFamInstDecl GhcRn)]),
FreeVars)
-> RnM
(([LocatedA (TyFamInstDecl GhcRn)],
[LocatedA (DataFamInstDecl GhcRn)]),
FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
ktv_names (RnM
(([LocatedA (TyFamInstDecl GhcRn)],
[LocatedA (DataFamInstDecl GhcRn)]),
FreeVars)
-> RnM
(([LocatedA (TyFamInstDecl GhcRn)],
[LocatedA (DataFamInstDecl GhcRn)]),
FreeVars))
-> RnM
(([LocatedA (TyFamInstDecl GhcRn)],
[LocatedA (DataFamInstDecl GhcRn)]),
FreeVars)
-> RnM
(([LocatedA (TyFamInstDecl GhcRn)],
[LocatedA (DataFamInstDecl GhcRn)]),
FreeVars)
forall a b. (a -> b) -> a -> b
$
do { ([LocatedA (TyFamInstDecl GhcRn)]
ats', FreeVars
at_fvs) <- (AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars))
-> Name
-> [Name]
-> [LocatedA (TyFamInstDecl GhcPs)]
-> RnM ([LocatedA (TyFamInstDecl GhcRn)], FreeVars)
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]
[LocatedA (TyFamInstDecl GhcPs)]
ats
; ([LocatedA (DataFamInstDecl GhcRn)]
adts', FreeVars
adt_fvs) <- (AssocTyFamInfo
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, FreeVars))
-> Name
-> [Name]
-> [LocatedA (DataFamInstDecl GhcPs)]
-> RnM ([LocatedA (DataFamInstDecl GhcRn)], FreeVars)
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]
[LocatedA (DataFamInstDecl GhcPs)]
adts
; (([LocatedA (TyFamInstDecl GhcRn)],
[LocatedA (DataFamInstDecl GhcRn)]),
FreeVars)
-> RnM
(([LocatedA (TyFamInstDecl GhcRn)],
[LocatedA (DataFamInstDecl GhcRn)]),
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
; (ClsInstDecl GhcRn, FreeVars) -> RnM (ClsInstDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstDecl { cid_ext :: XCClsInstDecl GhcRn
cid_ext = XCClsInstDecl GhcRn
NoExtField
noExtField
, cid_poly_ty :: LHsSigType GhcRn
cid_poly_ty = LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty', cid_binds :: LHsBinds GhcRn
cid_binds = LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds'
, cid_sigs :: [LSig GhcRn]
cid_sigs = [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
uprags', cid_tyfam_insts :: [LTyFamInstDecl GhcRn]
cid_tyfam_insts = [LTyFamInstDecl GhcRn]
[LocatedA (TyFamInstDecl GhcRn)]
ats'
, cid_overlap_mode :: Maybe (XRec GhcRn OverlapMode)
cid_overlap_mode = Maybe (XRec GhcPs OverlapMode)
Maybe (XRec GhcRn OverlapMode)
oflag
, cid_datafam_insts :: [LDataFamInstDecl GhcRn]
cid_datafam_insts = [LDataFamInstDecl GhcRn]
[LocatedA (DataFamInstDecl GhcRn)]
adts' },
FreeVars
all_fvs) }
where
ctxt :: HsDocContext
ctxt = SDoc -> HsDocContext
GenericCtx (SDoc -> HsDocContext) -> SDoc -> HsDocContext
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an instance declaration"
inf_err :: Maybe SDoc
inf_err = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Inferred type variables are not allowed")
bail_out :: (SrcSpan, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) Name
bail_out (SrcSpan
l, TcRnMessage
err_msg) = do
SrcSpan -> TcRnMessage -> TcRn ()
addErrAt SrcSpan
l (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ HsDocContext -> TcRnMessage -> TcRnMessage
TcRnWithHsDocContext HsDocContext
ctxt TcRnMessage
err_msg
Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a b. (a -> b) -> a -> b
$ OccName -> Name
mkUnboundName (CLabelString -> OccName
mkTcOccFS (String -> CLabelString
fsLit String
"<class>"))
rnFamEqn :: HsDocContext
-> AssocTyFamInfo
-> FreeKiTyVars
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn :: forall rhs rhs'.
HsDocContext
-> AssocTyFamInfo
-> FreeKiTyVars
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn HsDocContext
doc AssocTyFamInfo
atfi FreeKiTyVars
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
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupFamInstName Maybe Name
mb_cls LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon
; FreeKiTyVars
all_imp_vars <- FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM (FreeKiTyVars -> RnM FreeKiTyVars)
-> FreeKiTyVars -> RnM FreeKiTyVars
forall a b. (a -> b) -> a -> b
$ FreeKiTyVars
pat_kity_vars FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall a. [a] -> [a] -> [a]
++ FreeKiTyVars
extra_kvars
; HsDocContext
-> Maybe Name
-> FreeKiTyVars
-> HsOuterFamEqnTyVarBndrs GhcPs
-> (HsOuterTyVarBndrs () GhcRn
-> RnM (FamEqn GhcRn rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
forall flag assoc a.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> Maybe assoc
-> FreeKiTyVars
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs HsDocContext
doc Maybe Name
mb_cls FreeKiTyVars
all_imp_vars HsOuterFamEqnTyVarBndrs GhcPs
outer_bndrs ((HsOuterTyVarBndrs () GhcRn -> RnM (FamEqn GhcRn rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars))
-> (HsOuterTyVarBndrs () GhcRn
-> RnM (FamEqn GhcRn rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
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
GenLocated SrcSpanAnnN RdrName
tycon) HsTyPats GhcPs
pats
; (rhs'
payload', FreeVars
rhs_fvs) <- HsDocContext -> rhs -> RnM (rhs', FreeVars)
rn_payload HsDocContext
doc rhs
payload
; let
rn_outer_bndrs' :: HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs' = (XHsOuterImplicit GhcRn -> XHsOuterImplicit GhcRn)
-> HsOuterTyVarBndrs () GhcRn -> HsOuterTyVarBndrs () GhcRn
forall pass flag.
(XHsOuterImplicit pass -> XHsOuterImplicit pass)
-> HsOuterTyVarBndrs flag pass -> HsOuterTyVarBndrs flag pass
mapHsOuterImplicit ((Name -> Name) -> [Name] -> [Name]
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 = (GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnN RdrName -> Ordering)
-> FreeKiTyVars -> [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnN RdrName -> Ordering
forall a l. Ord a => GenLocated l a -> GenLocated l a -> Ordering
cmpLocated FreeKiTyVars
pat_kity_vars
; [Name]
nms_dups <- (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> FreeKiTyVars -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupOccRn (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> (GenLocated SrcSpanAnnN RdrName -> RdrName)
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc) (FreeKiTyVars -> IOEnv (Env TcGblEnv TcLclEnv) [Name])
-> FreeKiTyVars -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall a b. (a -> b) -> a -> b
$
[ GenLocated SrcSpanAnnN RdrName
tv | (GenLocated SrcSpanAnnN RdrName
tv :| (GenLocated SrcSpanAnnN RdrName
_:FreeKiTyVars
_)) <- [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
groups ]
; let nms_used :: FreeVars
nms_used = FreeVars -> [Name] -> FreeVars
extendNameSetList FreeVars
rhs_fvs ([Name] -> FreeVars) -> [Name] -> FreeVars
forall a b. (a -> b) -> a -> b
$
[Name]
nms_dups [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
inst_head_tvs
all_nms :: [Name]
all_nms = HsOuterTyVarBndrs () GhcRn -> [Name]
forall flag. HsOuterTyVarBndrs flag GhcRn -> [Name]
hsOuterTyVarNames HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs'
; [Name] -> FreeVars -> TcRn ()
warnUnusedTypePatterns [Name]
all_nms FreeVars
nms_used
; [Name]
extra_kvar_nms <- (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Name))
-> FreeKiTyVars -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Name)
lookupLocalOccRn_maybe (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Name))
-> (GenLocated SrcSpanAnnN RdrName -> RdrName)
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc) FreeKiTyVars
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
Bool -> Bool -> Bool
&& Bool -> Bool
not (Name
cls_tkv Name -> FreeVars -> Bool
`elemNameSet` FreeVars
lhs_bound_vars)
bad_tvs :: [Name]
bad_tvs = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
improperly_scoped [Name]
inst_head_tvs
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Name] -> Bool
forall a. [a] -> Bool
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
all_fvs :: FreeVars
all_fvs = case AssocTyFamInfo
atfi of
NonAssocTyFamEqn ClosedTyFamInfo
ClosedTyFam
-> FreeVars
eqn_fvs
AssocTyFamInfo
_ -> FreeVars
eqn_fvs FreeVars -> Name -> FreeVars
`addOneFV` GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
tycon'
; (FamEqn GhcRn rhs', FreeVars) -> RnM (FamEqn GhcRn rhs', FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FamEqn { feqn_ext :: XCFamEqn GhcRn rhs'
feqn_ext = XCFamEqn GhcRn rhs'
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn
, feqn_tycon :: LIdP GhcRn
feqn_tycon = LIdP GhcRn
GenLocated SrcSpanAnnN Name
tycon'
, feqn_bndrs :: HsOuterTyVarBndrs () GhcRn
feqn_bndrs = HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs'
, feqn_pats :: [LHsTypeArg GhcRn]
feqn_pats = [LHsTypeArg GhcRn]
[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
mb_cls :: Maybe Name
mb_cls = case AssocTyFamInfo
atfi of
NonAssocTyFamEqn ClosedTyFamInfo
_ -> Maybe Name
forall a. Maybe a
Nothing
AssocTyFamDeflt Name
cls -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
cls
AssocTyFamInst Name
cls [Name]
_ -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
cls
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 :: FreeKiTyVars
pat_kity_vars = HsTyPats GhcPs -> FreeKiTyVars
extractHsTyArgRdrKiTyVars HsTyPats GhcPs
pats
lhs_loc :: SrcSpan
lhs_loc = case (HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> SrcSpan)
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map LHsTypeArg GhcPs -> SrcSpan
HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> SrcSpan
forall (pass :: Pass). LHsTypeArg (GhcPass pass) -> SrcSpan
lhsTypeArgSrcSpan HsTyPats GhcPs
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
pats [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ (GenLocated SrcSpanAnnN RdrName -> SrcSpan)
-> FreeKiTyVars -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN RdrName -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA FreeKiTyVars
extra_kvars of
[] -> String -> SrcSpan
forall a. HasCallStack => String -> a
panic String
"rnFamEqn.lhs_loc"
[SrcSpan
loc] -> SrcSpan
loc
(SrcSpan
loc:[SrcSpan]
locs) -> SrcSpan
loc SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` [SrcSpan] -> SrcSpan
forall a. HasCallStack => [a] -> a
last [SrcSpan]
locs
badAssocRhs :: [Name] -> RnM ()
badAssocRhs :: [Name] -> TcRn ()
badAssocRhs [Name]
ns
= TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
(SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The RHS of an associated type declaration mentions"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"out-of-scope variable" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Name] -> SDoc
forall a. [a] -> SDoc
plural [Name]
ns
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (Name -> SDoc) -> [Name] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (Name -> SDoc) -> Name -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [Name]
ns)
Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
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
; (TyFamInstDecl GhcRn, FreeVars)
-> RnM (TyFamInstDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl GhcRn
tfid_xtn = XCTyFamInstDecl GhcPs
XCTyFamInstDecl GhcRn
x, tfid_eqn :: TyFamInstEqn GhcRn
tfid_eqn = TyFamInstEqn GhcRn
FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
eqn' }, FreeVars
fvs) }
data AssocTyFamInfo
= NonAssocTyFamEqn
ClosedTyFamInfo
| AssocTyFamDeflt
Name
| AssocTyFamInst
Name
[Name]
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 })
= HsDocContext
-> AssocTyFamInfo
-> FreeKiTyVars
-> FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> (HsDocContext
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)), FreeVars)
forall rhs rhs'.
HsDocContext
-> AssocTyFamInfo
-> FreeKiTyVars
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn (GenLocated SrcSpanAnnN RdrName -> HsDocContext
TySynCtx LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon) AssocTyFamInfo
atfi FreeKiTyVars
extra_kvs TyFamInstEqn GhcPs
FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
eqn HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
HsDocContext
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars)
rnTySyn
where
extra_kvs :: FreeKiTyVars
extra_kvs = LHsType GhcPs -> FreeKiTyVars
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 :: FreeKiTyVars
extra_kvs = HsDataDefn GhcPs -> FreeKiTyVars
extractDataDefnKindVars HsDataDefn GhcPs
rhs
; (FamEqn GhcRn (HsDataDefn GhcRn)
eqn', FreeVars
fvs) <-
HsDocContext
-> AssocTyFamInfo
-> FreeKiTyVars
-> FamEqn GhcPs (HsDataDefn GhcPs)
-> (HsDocContext
-> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, FreeVars))
-> RnM (FamEqn GhcRn (HsDataDefn GhcRn), FreeVars)
forall rhs rhs'.
HsDocContext
-> AssocTyFamInfo
-> FreeKiTyVars
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn (GenLocated SrcSpanAnnN RdrName -> HsDocContext
TyDataCtx LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon) AssocTyFamInfo
atfi FreeKiTyVars
extra_kvs FamEqn GhcPs (HsDataDefn GhcPs)
eqn HsDocContext
-> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn
; (DataFamInstDecl GhcRn, FreeVars)
-> RnM (DataFamInstDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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) }
rnATDecls :: Name
-> [LFamilyDecl GhcPs]
-> RnM ([LFamilyDecl GhcRn], FreeVars)
rnATDecls :: Name -> [LFamilyDecl GhcPs] -> RnM ([LFamilyDecl GhcRn], FreeVars)
rnATDecls Name
cls [LFamilyDecl GhcPs]
at_decls
= (FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, FreeVars))
-> [LocatedA (FamilyDecl GhcPs)]
-> RnM ([LocatedA (FamilyDecl GhcRn)], FreeVars)
forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList (Maybe Name -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, FreeVars)
rnFamDecl (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
cls)) [LFamilyDecl GhcPs]
[LocatedA (FamilyDecl GhcPs)]
at_decls
rnATInstDecls :: (AssocTyFamInfo ->
decl GhcPs ->
RnM (decl GhcRn, FreeVars))
-> Name
-> [Name]
-> [LocatedA (decl GhcPs)]
-> RnM ([LocatedA (decl GhcRn)], FreeVars)
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
= (decl GhcPs -> RnM (decl GhcRn, FreeVars))
-> [LocatedA (decl GhcPs)]
-> RnM ([LocatedA (decl GhcRn)], FreeVars)
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
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 <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.StandaloneDeriving
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
standalone_deriv_ok (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) <- HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (LHsSigWcType GhcRn, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), LHsSigWcType GhcRn, FreeVars)
forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy HsDocContext
ctxt Maybe (LDerivStrategy GhcPs)
mds (RnM (LHsSigWcType GhcRn, FreeVars)
-> RnM
(Maybe (LDerivStrategy GhcRn), LHsSigWcType GhcRn, FreeVars))
-> RnM (LHsSigWcType GhcRn, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), LHsSigWcType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ HsDocContext
-> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType HsDocContext
ctxt LHsSigWcType GhcPs
ty
; HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
ctxt
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Standalone-derived instance head")
(LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead (LHsSigType GhcRn -> LHsType GhcRn)
-> LHsSigType GhcRn -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ LHsSigWcType GhcRn -> LHsSigType GhcRn
forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
ty')
; Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (LDerivStrategy GhcRn)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
mds' SrcSpan
loc
; (DerivDecl GhcRn, FreeVars) -> RnM (DerivDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCDerivDecl GhcRn
-> LHsSigWcType GhcRn
-> Maybe (LDerivStrategy GhcRn)
-> Maybe (XRec GhcRn OverlapMode)
-> DerivDecl GhcRn
forall pass.
XCDerivDecl pass
-> LHsSigWcType pass
-> Maybe (LDerivStrategy pass)
-> Maybe (XRec pass OverlapMode)
-> DerivDecl pass
DerivDecl XCDerivDecl GhcRn
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
ty' Maybe (LDerivStrategy GhcRn)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
mds' Maybe (XRec GhcPs OverlapMode)
Maybe (XRec GhcRn OverlapMode)
overlap, FreeVars
fvs) }
where
ctxt :: HsDocContext
ctxt = HsDocContext
DerivDeclCtx
inf_err :: Maybe SDoc
inf_err = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Inferred type variables are not allowed")
loc :: SrcSpan
loc = GenLocated SrcSpanAnnA (HsSigType GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
nowc_ty
nowc_ty :: LHsSigType GhcPs
nowc_ty = LHsSigWcType GhcPs -> LHsSigType GhcPs
forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType GhcPs
ty
standaloneDerivErr :: TcRnMessage
standaloneDerivErr :: TcRnMessage
standaloneDerivErr
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Illegal standalone deriving declaration")
Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Use StandaloneDeriving to enable this extension")
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
rnHsRuleDecls (HsRules { rds_ext :: forall pass. RuleDecls pass -> XCRuleDecls pass
rds_ext = (EpAnn [AddEpAnn]
_, SourceText
src)
, rds_rules :: forall pass. RuleDecls pass -> [LRuleDecl pass]
rds_rules = [LRuleDecl GhcPs]
rules })
= do { ([LocatedA (RuleDecl GhcRn)]
rn_rules,FreeVars
fvs) <- (RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars))
-> [LocatedA (RuleDecl GhcPs)]
-> RnM ([LocatedA (RuleDecl GhcRn)], FreeVars)
forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl [LRuleDecl GhcPs]
[LocatedA (RuleDecl GhcPs)]
rules
; (RuleDecls GhcRn, FreeVars) -> RnM (RuleDecls GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsRules { rds_ext :: XCRuleDecls GhcRn
rds_ext = XCRuleDecls GhcRn
SourceText
src
, rds_rules :: [LRuleDecl GhcRn]
rds_rules = [LRuleDecl GhcRn]
[LocatedA (RuleDecl GhcRn)]
rn_rules }, FreeVars
fvs) }
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl (HsRule { rd_ext :: forall pass. RuleDecl pass -> XHsRule pass
rd_ext = (EpAnn HsRuleAnn
_, SourceText
st)
, rd_name :: forall pass. RuleDecl pass -> XRec pass CLabelString
rd_name = XRec GhcPs 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 :: FreeKiTyVars
rdr_names_w_loc = (GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)
-> GenLocated SrcSpanAnnN RdrName)
-> [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)] -> FreeKiTyVars
forall a b. (a -> b) -> [a] -> [b]
map (RuleBndr GhcPs -> GenLocated SrcSpanAnnN RdrName
get_var (RuleBndr GhcPs -> GenLocated SrcSpanAnnN RdrName)
-> (GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)
-> RuleBndr GhcPs)
-> GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)
-> GenLocated SrcSpanAnnN RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs) -> RuleBndr GhcPs
forall l e. GenLocated l e -> e
unLoc) [LRuleBndr GhcPs]
[GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
tmvs
; (GenLocated SrcSpanAnnN RdrName -> TcRn ())
-> FreeKiTyVars -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GenLocated SrcSpanAnnN RdrName -> TcRn ()
warnForallIdentifier FreeKiTyVars
rdr_names_w_loc
; FreeKiTyVars -> TcRn ()
checkDupRdrNamesN FreeKiTyVars
rdr_names_w_loc
; FreeKiTyVars -> TcRn ()
checkShadowedRdrNames FreeKiTyVars
rdr_names_w_loc
; [Name]
names <- FreeKiTyVars -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
newLocalBndrsRn FreeKiTyVars
rdr_names_w_loc
; let doc :: HsDocContext
doc = CLabelString -> HsDocContext
RuleCtx (GenLocated (SrcAnn NoEpAnns) CLabelString -> CLabelString
forall l e. GenLocated l e -> e
unLoc XRec GhcPs CLabelString
GenLocated (SrcAnn NoEpAnns) CLabelString
rule_name)
; HsDocContext
-> Maybe [LHsTyVarBndr () GhcPs]
-> (Maybe [LHsTyVarBndr () GhcRn]
-> RnM (RuleDecl GhcRn, FreeVars))
-> RnM (RuleDecl GhcRn, FreeVars)
forall b.
HsDocContext
-> Maybe [LHsTyVarBndr () GhcPs]
-> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindRuleTyVars HsDocContext
doc Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
Maybe [LHsTyVarBndr () GhcPs]
tyvs ((Maybe [LHsTyVarBndr () GhcRn] -> RnM (RuleDecl GhcRn, FreeVars))
-> RnM (RuleDecl GhcRn, FreeVars))
-> (Maybe [LHsTyVarBndr () GhcRn]
-> RnM (RuleDecl GhcRn, FreeVars))
-> RnM (RuleDecl GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ Maybe [LHsTyVarBndr () GhcRn]
tyvs' ->
HsDocContext
-> Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (RuleDecl GhcRn, FreeVars))
-> RnM (RuleDecl GhcRn, FreeVars)
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]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
tyvs' [LRuleBndr GhcPs]
tmvs [Name]
names (([LRuleBndr GhcRn] -> RnM (RuleDecl GhcRn, FreeVars))
-> RnM (RuleDecl GhcRn, FreeVars))
-> ([LRuleBndr GhcRn] -> RnM (RuleDecl GhcRn, FreeVars))
-> RnM (RuleDecl GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [LRuleBndr GhcRn]
tmvs' ->
do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs', FreeVars
fv_lhs') <- XRec GhcPs (HsExpr GhcPs) -> TcM (LHsExpr GhcRn, FreeVars)
rnLExpr XRec GhcPs (HsExpr GhcPs)
lhs
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs', FreeVars
fv_rhs') <- XRec GhcPs (HsExpr GhcPs) -> TcM (LHsExpr GhcRn, FreeVars)
rnLExpr XRec GhcPs (HsExpr GhcPs)
rhs
; CLabelString -> [Name] -> LHsExpr GhcRn -> FreeVars -> TcRn ()
checkValidRule (GenLocated (SrcAnn NoEpAnns) CLabelString -> CLabelString
forall l e. GenLocated l e -> e
unLoc XRec GhcPs CLabelString
GenLocated (SrcAnn NoEpAnns) CLabelString
rule_name) [Name]
names LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs' FreeVars
fv_lhs'
; (RuleDecl GhcRn, FreeVars) -> RnM (RuleDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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', SourceText
st)
, rd_name :: XRec GhcRn CLabelString
rd_name = XRec GhcPs CLabelString
XRec GhcRn CLabelString
rule_name
, rd_act :: Activation
rd_act = Activation
act
, rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc GhcRn)]
rd_tyvs = Maybe [LHsTyVarBndr () (NoGhcTc GhcRn)]
Maybe [LHsTyVarBndr () GhcRn]
tyvs'
, rd_tmvs :: [LRuleBndr GhcRn]
rd_tmvs = [LRuleBndr GhcRn]
tmvs'
, rd_lhs :: LHsExpr GhcRn
rd_lhs = LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs'
, rd_rhs :: LHsExpr GhcRn
rd_rhs = LHsExpr GhcRn
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
GenLocated SrcSpanAnnN RdrName
v
get_var (RuleBndr XCRuleBndr GhcPs
_ LIdP GhcPs
v) = LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
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]
[GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
vars [Name]
names (([GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars))
-> ([GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
vars' ->
[Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
names ([LRuleBndr GhcRn] -> RnM (a, FreeVars)
thing_inside [LRuleBndr GhcRn]
[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 (([GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars))
-> ([GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
vars' ->
[GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars)
thing_inside (SrcAnn NoEpAnns
-> RuleBndr GhcRn -> GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
l (XCRuleBndr GhcRn -> LIdP GhcRn -> RuleBndr GhcRn
forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass
RuleBndr XCRuleBndr GhcRn
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
n)) GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)
-> [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
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
= HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a.
HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigType HsPatSigTypeScoping
bind_free_tvs HsDocContext
doc HsPatSigType GhcPs
bsig ((HsPatSigType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars))
-> (HsPatSigType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars)
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 (([GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars))
-> ([GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
vars' ->
[GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> RnM (a, FreeVars)
thing_inside (SrcAnn NoEpAnns
-> RuleBndr GhcRn -> GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
l (XRuleBndrSig GhcRn
-> LIdP GhcRn -> HsPatSigType GhcRn -> RuleBndr GhcRn
forall pass.
XRuleBndrSig pass
-> LIdP pass -> HsPatSigType pass -> RuleBndr pass
RuleBndrSig XRuleBndrSig GhcRn
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
n) HsPatSigType GhcRn
bsig') GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)
-> [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
-> [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcRn)]
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)
_ = String -> SDoc -> RnM (a, FreeVars)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"bindRuleVars" ([GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
vars SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Name] -> 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
= HsDocContext
-> WarnUnusedForalls
-> Maybe Any
-> [LHsTyVarBndr () GhcPs]
-> ([LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
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 Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr () GhcPs]
bndrs (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> RnM (b, FreeVars)
thing_inside (Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> RnM (b, FreeVars))
-> ([GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)])
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> RnM (b, FreeVars)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
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 Maybe [LHsTyVarBndr () GhcRn]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
forall a. Maybe a
Nothing
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 {
case ([Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
validRuleLhs [Name]
ids LHsExpr GhcRn
lhs') of
Maybe (HsExpr GhcRn)
Nothing -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just HsExpr GhcRn
bad -> TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (CLabelString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage
badRuleLhsErr CLabelString
rule_name LHsExpr GhcRn
lhs' HsExpr GhcRn
bad)
; let bad_vars :: [Name]
bad_vars = [Name
var | Name
var <- [Name]
ids, Bool -> Bool
not (Name
var Name -> FreeVars -> Bool
`elemNameSet` FreeVars
fv_lhs')]
; (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ())
-> (Name -> TcRnMessage) -> Name -> TcRn ()
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)
validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
validRuleLhs [Name]
foralls LHsExpr GhcRn
lhs
= GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs
where
checkl :: GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl = HsExpr GhcRn -> Maybe (HsExpr GhcRn)
check (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> Maybe (HsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
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
GenLocated SrcSpanAnnA (HsExpr GhcRn)
op Maybe (HsExpr GhcRn)
-> Maybe (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall {p} {a}. p -> Maybe a
checkl_e LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e1
Maybe (HsExpr GhcRn)
-> Maybe (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall {p} {a}. p -> Maybe a
checkl_e LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e2
check (HsApp XApp GhcRn
_ LHsExpr GhcRn
e1 LHsExpr GhcRn
e2) = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e1 Maybe (HsExpr GhcRn)
-> Maybe (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall {p} {a}. p -> Maybe a
checkl_e LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e2
check (HsAppType XAppTypeE GhcRn
_ LHsExpr GhcRn
e LHsToken "@" GhcRn
_ LHsWcType (NoGhcTc GhcRn)
_) = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e
check (HsVar XVar GhcRn
_ LIdP GhcRn
lv)
| (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
lv) Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
foralls = Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing
check HsExpr GhcRn
other = HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
other
checkl_e :: p -> Maybe a
checkl_e p
_ = Maybe a
forall a. Maybe a
Nothing
badRuleVar :: FastString -> Name -> TcRnMessage
badRuleVar :: CLabelString -> Name -> TcRnMessage
badRuleVar CLabelString
name Name
var
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Rule" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Forall'd variable" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
var) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
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
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Rule" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CLabelString -> SDoc
pprRuleName CLabelString
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon,
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc
err,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in left-hand side:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs])]
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
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
_ RdrName
uv ->
RdrName -> NotInScopeError -> SDoc
pprScopeError RdrName
uv (NotInScopeError -> SDoc) -> NotInScopeError -> SDoc
forall a b. (a -> b) -> a -> b
$ WhereLooking -> RdrName -> NotInScopeError
notInScopeErr WhereLooking
WL_Global RdrName
uv
HsExpr GhcRn
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Illegal expression:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
bad_e
rnTyClDecls :: [TyClGroup GhcPs]
-> RnM ([TyClGroup GhcRn], FreeVars)
rnTyClDecls :: [TyClGroup GhcPs] -> RnM ([TyClGroup GhcRn], FreeVars)
rnTyClDecls [TyClGroup GhcPs]
tycl_ds
= do {
; [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
tycls_w_fvs <- (GenLocated SrcSpanAnnA (TyClDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (TyClDecl GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((TyClDecl GhcPs -> TcM (TyClDecl GhcRn, FreeVars))
-> GenLocated SrcSpanAnnA (TyClDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA TyClDecl GhcPs -> TcM (TyClDecl GhcRn, FreeVars)
rnTyClDecl) ([TyClGroup GhcPs] -> [LTyClDecl GhcPs]
forall pass. [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls [TyClGroup GhcPs]
tycl_ds)
; let tc_names :: FreeVars
tc_names = [Name] -> FreeVars
mkNameSet (((GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars) -> Name)
-> [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyClDecl GhcRn -> IdP GhcRn
TyClDecl GhcRn -> Name
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (TyClDecl GhcRn -> Name)
-> ((GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)
-> TyClDecl GhcRn)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> ((GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn))
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)
-> TyClDecl GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
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 ([TyClGroup GhcPs] -> [LStandaloneKindSig GhcPs]
forall pass. [TyClGroup pass] -> [LStandaloneKindSig pass]
tyClGroupKindSigs [TyClGroup GhcPs]
tycl_ds)
; [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
instds_w_fvs <- (GenLocated SrcSpanAnnA (InstDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (InstDecl GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars))
-> GenLocated SrcSpanAnnA (InstDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)
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) ([TyClGroup GhcPs] -> [LInstDecl GhcPs]
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 ([TyClGroup GhcPs] -> [LRoleAnnotDecl GhcPs]
forall pass. [TyClGroup pass] -> [LRoleAnnotDecl pass]
tyClGroupRoleDecls [TyClGroup GhcPs]
tycl_ds)
; 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 [(LTyClDecl GhcRn, FreeVars)]
[(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
tycls_w_fvs
role_annot_env :: RoleAnnotEnv
role_annot_env = [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv
mkRoleAnnotEnv [LRoleAnnotDecl GhcRn]
[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 [(LStandaloneKindSig GhcRn, FreeVars)]
[(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 InstDeclFreeVarsMap
[(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
| [GenLocated SrcSpanAnnA (InstDecl GhcRn)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LInstDecl GhcRn]
[GenLocated SrcSpanAnnA (InstDecl GhcRn)]
init_inst_ds = []
| Bool
otherwise = [TyClGroup { group_ext :: XCTyClGroup GhcRn
group_ext = XCTyClGroup GhcRn
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)
= ([(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
-> SCC (GenLocated SrcSpanAnnA (TyClDecl GhcRn))
-> ([(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)],
TyClGroup GhcRn))
-> [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
-> [SCC (GenLocated SrcSpanAnnA (TyClDecl GhcRn))]
-> ([(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)],
[TyClGroup GhcRn])
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
[(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
rest_inst_ds [SCC (LTyClDecl GhcRn)]
[SCC (GenLocated SrcSpanAnnA (TyClDecl GhcRn))]
tycl_sccs
all_fvs :: FreeVars
all_fvs = ((GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)
-> FreeVars -> FreeVars)
-> FreeVars
-> [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
-> FreeVars
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
plusFV (FreeVars -> FreeVars -> FreeVars)
-> ((GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)
-> FreeVars)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)
-> FreeVars
-> FreeVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars) -> FreeVars
forall a b. (a, b) -> b
snd) FreeVars
emptyFVs [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
tycls_w_fvs FreeVars -> FreeVars -> FreeVars
`plusFV`
((GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)
-> FreeVars -> FreeVars)
-> FreeVars
-> [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
-> FreeVars
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
plusFV (FreeVars -> FreeVars -> FreeVars)
-> ((GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)
-> FreeVars)
-> (GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)
-> FreeVars
-> FreeVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars) -> FreeVars
forall a b. (a, b) -> b
snd) FreeVars
emptyFVs [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
instds_w_fvs FreeVars -> FreeVars -> FreeVars
`plusFV`
((GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> FreeVars -> FreeVars)
-> FreeVars
-> [(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)]
-> FreeVars
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
plusFV (FreeVars -> FreeVars -> FreeVars)
-> ((GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> FreeVars)
-> (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> FreeVars
-> FreeVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> FreeVars
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 [TyClGroup GhcRn] -> [TyClGroup GhcRn] -> [TyClGroup GhcRn]
forall a. [a] -> [a] -> [a]
++ [TyClGroup GhcRn]
groups
; Bool -> SDoc -> TcRn ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr ([(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
final_inst_ds)
([(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
instds_w_fvs
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstDeclFreeVarsMap
[(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
inst_ds_map
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [GenLocated SrcSpanAnnA (TyClDecl GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([SCC (GenLocated SrcSpanAnnA (TyClDecl GhcRn))]
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
forall a. [SCC a] -> [a]
flattenSCCs [SCC (LTyClDecl GhcRn)]
[SCC (GenLocated SrcSpanAnnA (TyClDecl GhcRn))]
tycl_sccs)
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)] -> 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" ([TyClGroup GhcRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyClGroup GhcRn]
all_groups)
; ([TyClGroup GhcRn], FreeVars) -> RnM ([TyClGroup GhcRn], FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 = SCC (GenLocated SrcSpanAnnA (TyClDecl GhcRn))
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
forall vertex. SCC vertex -> [vertex]
flattenSCC SCC (LTyClDecl GhcRn)
SCC (GenLocated SrcSpanAnnA (TyClDecl GhcRn))
scc
bndrs :: [Name]
bndrs = (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyClDecl GhcRn -> IdP GhcRn
TyClDecl GhcRn -> Name
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (TyClDecl GhcRn -> Name)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
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 = XCTyClGroup GhcRn
NoExtField
noExtField
, group_tyclds :: [LTyClDecl GhcRn]
group_tyclds = [LTyClDecl GhcRn]
[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 }
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
= FreeVars -> Maybe FreeVars -> FreeVars
forall a. a -> Maybe a -> a
fromMaybe FreeVars
emptyFVs (NameEnv FreeVars -> Name -> Maybe FreeVars
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv FreeVars
e Name
name)
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 = (KindSigEnv
NameEnv (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
kisig_env, KindSig_FV_Env
kisig_fv_env)
where
kisig_env :: NameEnv (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
kisig_env = ((GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
-> NameEnv
(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> NameEnv (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)
forall a b. (a, b) -> a
fst NameEnv (LStandaloneKindSig GhcRn, FreeVars)
NameEnv
(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
compound_env
kisig_fv_env :: KindSig_FV_Env
kisig_fv_env = NameEnv FreeVars -> KindSig_FV_Env
KindSig_FV_Env (((GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> FreeVars)
-> NameEnv
(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> NameEnv FreeVars
forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> FreeVars
forall a b. (a, b) -> b
snd NameEnv (LStandaloneKindSig GhcRn, FreeVars)
NameEnv
(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
compound_env)
NameEnv (LStandaloneKindSig GhcRn, FreeVars)
compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)
= ((GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> Name)
-> [(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)]
-> NameEnv
(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
forall a. (a -> Name) -> [a] -> NameEnv a
mkNameEnvWith (StandaloneKindSig GhcRn -> IdP GhcRn
StandaloneKindSig GhcRn -> Name
forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName (StandaloneKindSig GhcRn -> Name)
-> ((GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> StandaloneKindSig GhcRn)
-> (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)
-> StandaloneKindSig GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)
-> StandaloneKindSig GhcRn)
-> ((GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
-> (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> StandaloneKindSig GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)
forall a b. (a, b) -> a
fst) [(LStandaloneKindSig GhcRn, FreeVars)]
[(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)]
kisigs_w_fvs
getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
getKindSigs [Name]
bndrs KindSigEnv
kisig_env = (Name -> Maybe (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)))
-> [Name] -> [GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameEnv (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
-> Name -> Maybe (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv KindSigEnv
NameEnv (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
kisig_env) [Name]
bndrs
rnStandaloneKindSignatures
:: NameSet
-> [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) = (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) -> Ordering)
-> [GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)]
-> ([GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)],
[NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (RdrName -> RdrName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RdrName -> RdrName -> Ordering)
-> (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) -> RdrName)
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) -> RdrName
GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) -> IdGhcP 'Parsed
forall {l} {p :: Pass}.
GenLocated l (StandaloneKindSig (GhcPass p)) -> IdGhcP p
get_name) [LStandaloneKindSig GhcPs]
[GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)]
kisigs
get_name :: GenLocated l (StandaloneKindSig (GhcPass p)) -> IdGhcP p
get_name = StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
StandaloneKindSig (GhcPass p) -> IdGhcP p
forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName (StandaloneKindSig (GhcPass p) -> IdGhcP p)
-> (GenLocated l (StandaloneKindSig (GhcPass p))
-> StandaloneKindSig (GhcPass p))
-> GenLocated l (StandaloneKindSig (GhcPass p))
-> IdGhcP p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated l (StandaloneKindSig (GhcPass p))
-> StandaloneKindSig (GhcPass p)
forall l e. GenLocated l e -> e
unLoc
; (NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
-> TcRn ())
-> [NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))]
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (LStandaloneKindSig GhcPs) -> TcRn ()
NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
-> TcRn ()
dupKindSig_Err [NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))]
dup_kisigs
; (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((StandaloneKindSig GhcPs
-> TcM (StandaloneKindSig GhcRn, FreeVars))
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA (FreeVars
-> StandaloneKindSig GhcPs
-> TcM (StandaloneKindSig GhcRn, FreeVars)
rnStandaloneKindSignature FreeVars
tc_names)) [GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)]
no_dups
}
rnStandaloneKindSignature
:: NameSet
-> StandaloneKindSig GhcPs
-> RnM (StandaloneKindSig GhcRn, FreeVars)
rnStandaloneKindSignature :: FreeVars
-> StandaloneKindSig GhcPs
-> TcM (StandaloneKindSig GhcRn, FreeVars)
rnStandaloneKindSignature FreeVars
tc_names (StandaloneKindSig XStandaloneKindSig GhcPs
_ LIdP GhcPs
v LHsSigType GhcPs
ki)
= do { Bool
standalone_ki_sig_ok <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.StandaloneKindSignatures
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
standalone_ki_sig_ok (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addErr TcRnMessage
standaloneKiSigErr
; GenLocated SrcSpanAnnN Name
new_v <- HsSigCtxt
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupSigCtxtOccRnN (FreeVars -> HsSigCtxt
TopSigCtxt FreeVars
tc_names) (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"standalone kind signature") LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
v
; let doc :: HsDocContext
doc = SDoc -> HsDocContext
StandaloneKindSigCtx (GenLocated SrcSpanAnnN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
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
; (StandaloneKindSig GhcRn, FreeVars)
-> TcM (StandaloneKindSig GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XStandaloneKindSig GhcRn
-> LIdP GhcRn -> LHsSigType GhcRn -> StandaloneKindSig GhcRn
forall pass.
XStandaloneKindSig pass
-> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig XStandaloneKindSig GhcRn
NoExtField
noExtField LIdP GhcRn
GenLocated SrcSpanAnnN Name
new_v LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_ki, FreeVars
fvs)
}
where
standaloneKiSigErr :: TcRnMessage
standaloneKiSigErr :: TcRnMessage
standaloneKiSigErr = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Illegal standalone kind signature")
Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Did you mean to enable StandaloneKindSignatures?")
depAnalTyClDecls :: GlobalRdrEnv
-> KindSig_FV_Env
-> [(LTyClDecl GhcRn, FreeVars)]
-> [SCC (LTyClDecl GhcRn)]
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
= [Node Name (GenLocated SrcSpanAnnA (TyClDecl GhcRn))]
-> [SCC (GenLocated SrcSpanAnnA (TyClDecl GhcRn))]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Name (LTyClDecl GhcRn)]
[Node Name (GenLocated SrcSpanAnnA (TyClDecl GhcRn))]
edges
where
edges :: [ Node Name (LTyClDecl GhcRn) ]
edges :: [Node Name (LTyClDecl GhcRn)]
edges = [ GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> Name
-> [Name]
-> Node Name (GenLocated SrcSpanAnnA (TyClDecl GhcRn))
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d IdP GhcRn
Name
name ((Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (GlobalRdrEnv -> Name -> Name
getParent GlobalRdrEnv
rdr_env) (FreeVars -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet FreeVars
deps))
| (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d, FreeVars
fvs) <- [(LTyClDecl GhcRn, FreeVars)]
[(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
ds_w_fvs,
let { name :: IdP GhcRn
name = TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
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
name
; deps :: FreeVars
deps = FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
kisig_fvs
}
]
toParents :: GlobalRdrEnv -> NameSet -> NameSet
toParents :: GlobalRdrEnv -> FreeVars -> FreeVars
toParents GlobalRdrEnv
rdr_env FreeVars
ns
= (Name -> FreeVars -> FreeVars) -> FreeVars -> FreeVars -> FreeVars
forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet Name -> FreeVars -> FreeVars
add FreeVars
emptyNameSet FreeVars
ns
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
rnRoleAnnots :: NameSet
-> [LRoleAnnotDecl GhcPs]
-> RnM [LRoleAnnotDecl GhcRn]
rnRoleAnnots :: FreeVars -> [LRoleAnnotDecl GhcPs] -> RnM [LRoleAnnotDecl GhcRn]
rnRoleAnnots FreeVars
tc_names [LRoleAnnotDecl GhcPs]
role_annots
= do {
let ([GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)]
no_dups, [NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))]
dup_annots) = (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
-> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) -> Ordering)
-> [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)],
[NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (RdrName -> RdrName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RdrName -> RdrName -> Ordering)
-> (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) -> RdrName)
-> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
-> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) -> RdrName
GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) -> IdGhcP 'Parsed
forall {l} {p :: Pass}.
GenLocated l (RoleAnnotDecl (GhcPass p)) -> IdGhcP p
get_name) [LRoleAnnotDecl GhcPs]
[GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)]
role_annots
get_name :: GenLocated l (RoleAnnotDecl (GhcPass p)) -> IdGhcP p
get_name = RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
RoleAnnotDecl (GhcPass p) -> IdGhcP p
forall (p :: Pass). RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
roleAnnotDeclName (RoleAnnotDecl (GhcPass p) -> IdGhcP p)
-> (GenLocated l (RoleAnnotDecl (GhcPass p))
-> RoleAnnotDecl (GhcPass p))
-> GenLocated l (RoleAnnotDecl (GhcPass p))
-> IdGhcP p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated l (RoleAnnotDecl (GhcPass p))
-> RoleAnnotDecl (GhcPass p)
forall l e. GenLocated l e -> e
unLoc
; (NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
-> TcRn ())
-> [NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))]
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (LRoleAnnotDecl GhcPs) -> TcRn ()
NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)) -> TcRn ()
dupRoleAnnotErr [NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))]
dup_annots
; (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn)))
-> [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((RoleAnnotDecl GhcPs -> TcM (RoleAnnotDecl GhcRn))
-> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn))
forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA RoleAnnotDecl GhcPs -> TcM (RoleAnnotDecl GhcRn)
rn_role_annot1) [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)]
no_dups }
where
rn_role_annot1 :: RoleAnnotDecl GhcPs -> TcM (RoleAnnotDecl GhcRn)
rn_role_annot1 (RoleAnnotDecl XCRoleAnnotDecl GhcPs
_ LIdP GhcPs
tycon [XRec GhcPs (Maybe Role)]
roles)
= do {
GenLocated SrcSpanAnnN Name
tycon' <- HsSigCtxt
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupSigCtxtOccRnN (FreeVars -> HsSigCtxt
RoleAnnotCtxt FreeVars
tc_names)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"role annotation")
LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon
; RoleAnnotDecl GhcRn -> TcM (RoleAnnotDecl GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RoleAnnotDecl GhcRn -> TcM (RoleAnnotDecl GhcRn))
-> RoleAnnotDecl GhcRn -> TcM (RoleAnnotDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ XCRoleAnnotDecl GhcRn
-> LIdP GhcRn -> [XRec GhcRn (Maybe Role)] -> RoleAnnotDecl GhcRn
forall pass.
XCRoleAnnotDecl pass
-> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass
RoleAnnotDecl XCRoleAnnotDecl GhcRn
NoExtField
noExtField LIdP GhcRn
GenLocated SrcSpanAnnN Name
tycon' [XRec GhcPs (Maybe Role)]
[XRec GhcRn (Maybe Role)]
roles }
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> TcRn ()
dupRoleAnnotErr NonEmpty (LRoleAnnotDecl GhcPs)
list
= SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Duplicate role annotations for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RdrName -> SDoc) -> RdrName -> SDoc
forall a b. (a -> b) -> a -> b
$ RoleAnnotDecl GhcPs -> IdP GhcPs
forall (p :: Pass). RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
roleAnnotDeclName RoleAnnotDecl GhcPs
first_decl) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) -> SDoc)
-> [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) -> SDoc
forall {a} {a}.
Outputable a =>
GenLocated (SrcSpanAnn' a) a -> SDoc
pp_role_annot ([GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)] -> [SDoc])
-> [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
-> [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
sorted_list)
where
sorted_list :: NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
sorted_list = (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
-> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) -> Ordering)
-> NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
-> NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)
-> GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs) -> Ordering
forall {a} {e}.
GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e -> Ordering
cmp_loc NonEmpty (LRoleAnnotDecl GhcPs)
NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl 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 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
decl)
Int
4 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-- written at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpanAnn' a -> SrcSpan
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 (SrcSpan -> SrcSpan -> Ordering)
-> (GenLocated (SrcSpanAnn' a) e -> SrcSpan)
-> GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` GenLocated (SrcSpanAnn' a) e -> SrcSpan
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 (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Duplicate standalone kind signatures for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RdrName -> SDoc) -> RdrName -> SDoc
forall a b. (a -> b) -> a -> b
$ StandaloneKindSig GhcPs -> IdP GhcPs
forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName StandaloneKindSig GhcPs
first_decl) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) -> SDoc)
-> [GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) -> SDoc
forall {a} {a}.
Outputable a =>
GenLocated (SrcSpanAnn' a) a -> SDoc
pp_kisig ([GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)] -> [SDoc])
-> [GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
-> [GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
sorted_list)
where
sorted_list :: NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
sorted_list = (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) -> Ordering)
-> NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
-> NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)
-> GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs) -> Ordering
forall {a} {e}.
GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e -> Ordering
cmp_loc NonEmpty (LStandaloneKindSig GhcPs)
NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig 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 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
decl) Int
4 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-- written at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpanAnn' a -> SrcSpan
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 (SrcSpan -> SrcSpan -> Ordering)
-> (GenLocated (SrcSpanAnn' a) e -> SrcSpan)
-> GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` GenLocated (SrcSpanAnn' a) e -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA
type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]
mkInstDeclFreeVarsMap :: GlobalRdrEnv
-> NameSet
-> [(LInstDecl GhcRn, FreeVars)]
-> InstDeclFreeVarsMap
mkInstDeclFreeVarsMap :: GlobalRdrEnv
-> FreeVars -> InstDeclFreeVarsMap -> InstDeclFreeVarsMap
mkInstDeclFreeVarsMap GlobalRdrEnv
rdr_env FreeVars
tycl_bndrs InstDeclFreeVarsMap
inst_ds_fvs
= [ (LInstDecl GhcRn
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
[(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
inst_ds_fvs ]
getInsts :: [Name] -> InstDeclFreeVarsMap
-> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts :: [Name]
-> InstDeclFreeVarsMap -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts [Name]
bndrs InstDeclFreeVarsMap
inst_decl_map
= ((GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)
-> Either
(GenLocated SrcSpanAnnA (InstDecl GhcRn))
(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars))
-> [(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
-> ([GenLocated SrcSpanAnnA (InstDecl GhcRn)],
[(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (LInstDecl GhcRn, FreeVars)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)
-> Either
(GenLocated SrcSpanAnnA (InstDecl GhcRn))
(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)
pick_me InstDeclFreeVarsMap
[(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)]
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 = GenLocated SrcSpanAnnA (InstDecl GhcRn)
-> Either
(GenLocated SrcSpanAnnA (InstDecl GhcRn))
(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)
forall a b. a -> Either a b
Left LInstDecl GhcRn
GenLocated SrcSpanAnnA (InstDecl GhcRn)
decl
| Bool
otherwise = (GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)
-> Either
(GenLocated SrcSpanAnnA (InstDecl GhcRn))
(GenLocated SrcSpanAnnA (InstDecl GhcRn), FreeVars)
forall a b. b -> Either a b
Right (LInstDecl GhcRn
GenLocated SrcSpanAnnA (InstDecl GhcRn)
decl, FreeVars
depleted_fvs)
where
depleted_fvs :: FreeVars
depleted_fvs = [Name] -> FreeVars -> FreeVars
delFVs [Name]
bndrs FreeVars
fvs
rnTyClDecl :: TyClDecl GhcPs
-> RnM (TyClDecl GhcRn, FreeVars)
rnTyClDecl :: TyClDecl GhcPs -> TcM (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 Maybe Name
forall a. Maybe a
Nothing FamilyDecl GhcPs
fam
; (TyClDecl GhcRn, FreeVars) -> TcM (TyClDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XFamDecl GhcRn -> FamilyDecl GhcRn -> TyClDecl GhcRn
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl XFamDecl GhcRn
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
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon
; let kvs :: FreeKiTyVars
kvs = LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVarsKindVars LHsType GhcPs
rhs
doc :: HsDocContext
doc = GenLocated SrcSpanAnnN RdrName -> HsDocContext
TySynCtx LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon
; String -> SDoc -> TcRn ()
traceRn String
"rntycl-ty" (GenLocated SrcSpanAnnN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FreeKiTyVars -> SDoc
forall a. Outputable a => a -> SDoc
ppr FreeKiTyVars
kvs)
; HsDocContext
-> Maybe Any
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, FreeVars))
-> TcM (TyClDecl GhcRn, FreeVars)
forall a b.
HsDocContext
-> Maybe a
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc Maybe Any
forall a. Maybe a
Nothing FreeKiTyVars
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, FreeVars))
-> TcM (TyClDecl GhcRn, FreeVars))
-> (LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, FreeVars))
-> TcM (TyClDecl GhcRn, FreeVars)
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
; (TyClDecl GhcRn, FreeVars) -> TcM (TyClDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SynDecl { tcdLName :: LIdP GhcRn
tcdLName = LIdP GhcRn
GenLocated SrcSpanAnnN Name
tycon', tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars'
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdRhs :: LHsType GhcRn
tcdRhs = LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
rhs', tcdSExt :: XSynDecl GhcRn
tcdSExt = XSynDecl GhcRn
FreeVars
fvs }, FreeVars
fvs) } }
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_cons :: forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons = DataDefnCons (LConDecl GhcPs)
cons, dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsType GhcPs)
kind_sig} })
= do { GenLocated SrcSpanAnnN Name
tycon' <- GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon
; let kvs :: FreeKiTyVars
kvs = HsDataDefn GhcPs -> FreeKiTyVars
extractDataDefnKindVars HsDataDefn GhcPs
defn
doc :: HsDocContext
doc = GenLocated SrcSpanAnnN RdrName -> HsDocContext
TyDataCtx LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon
new_or_data :: NewOrData
new_or_data = DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs)) -> NewOrData
forall a. DataDefnCons a -> NewOrData
dataDefnConsNewOrData DataDefnCons (LConDecl GhcPs)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs))
cons
; String -> SDoc -> TcRn ()
traceRn String
"rntycl-data" (GenLocated SrcSpanAnnN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FreeKiTyVars -> SDoc
forall a. Outputable a => a -> SDoc
ppr FreeKiTyVars
kvs)
; HsDocContext
-> Maybe Any
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, FreeVars))
-> TcM (TyClDecl GhcRn, FreeVars)
forall a b.
HsDocContext
-> Maybe a
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc Maybe Any
forall a. Maybe a
Nothing FreeKiTyVars
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, FreeVars))
-> TcM (TyClDecl GhcRn, FreeVars))
-> (LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, FreeVars))
-> TcM (TyClDecl GhcRn, FreeVars)
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 <- LHsQTyVars GhcRn
-> NewOrData -> Bool -> Maybe (LHsType GhcPs) -> TcRn Bool
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" (GenLocated SrcSpanAnnN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
cusk SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
no_rhs_kvs)
; (TyClDecl GhcRn, FreeVars) -> TcM (TyClDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DataDecl { tcdLName :: LIdP GhcRn
tcdLName = LIdP GhcRn
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 = XDataDecl GhcRn
DataDeclRn
rn_info }, FreeVars
fvs) } }
rnTyClDecl (ClassDecl { tcdLayout :: forall pass. TyClDecl pass -> LayoutInfo pass
tcdLayout = LayoutInfo GhcPs
layout,
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
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
lcls
; let cls' :: Name
cls' = GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
lcls'
kvs :: [a]
kvs = []
; ((LHsQTyVars GhcRn
tyvars', Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', [GenLocated SrcSpanAnnA (FunDep GhcRn)]
fds', [LocatedA (FamilyDecl GhcRn)]
ats'), FreeVars
stuff_fvs)
<- HsDocContext
-> Maybe Any
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn,
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
[GenLocated SrcSpanAnnA (FunDep GhcRn)],
[LocatedA (FamilyDecl GhcRn)]),
FreeVars))
-> RnM
((LHsQTyVars GhcRn,
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
[GenLocated SrcSpanAnnA (FunDep GhcRn)],
[LocatedA (FamilyDecl GhcRn)]),
FreeVars)
forall a b.
HsDocContext
-> Maybe a
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
cls_doc Maybe Any
forall a. Maybe a
Nothing FreeKiTyVars
forall a. [a]
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn,
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
[GenLocated SrcSpanAnnA (FunDep GhcRn)],
[LocatedA (FamilyDecl GhcRn)]),
FreeVars))
-> RnM
((LHsQTyVars GhcRn,
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
[GenLocated SrcSpanAnnA (FunDep GhcRn)],
[LocatedA (FamilyDecl GhcRn)]),
FreeVars))
-> (LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn,
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
[GenLocated SrcSpanAnnA (FunDep GhcRn)],
[LocatedA (FamilyDecl GhcRn)]),
FreeVars))
-> RnM
((LHsQTyVars GhcRn,
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
[GenLocated SrcSpanAnnA (FunDep GhcRn)],
[LocatedA (FamilyDecl GhcRn)]),
FreeVars)
forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
_ -> do
{ (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
; ([LocatedA (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
; ((LHsQTyVars GhcRn,
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
[GenLocated SrcSpanAnnA (FunDep GhcRn)],
[LocatedA (FamilyDecl GhcRn)]),
FreeVars)
-> RnM
((LHsQTyVars GhcRn,
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
[GenLocated SrcSpanAnnA (FunDep GhcRn)],
[LocatedA (FamilyDecl GhcRn)]),
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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', [LocatedA (FamilyDecl GhcRn)]
ats'), FreeVars
fvs) }
; ([LocatedA (TyFamInstDecl GhcRn)]
at_defs', FreeVars
fv_at_defs) <- (TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars))
-> [LocatedA (TyFamInstDecl GhcPs)]
-> RnM ([LocatedA (TyFamInstDecl GhcRn)], FreeVars)
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]
[LocatedA (TyFamInstDecl GhcPs)]
at_defs
; let sig_rdr_names_w_locs :: FreeKiTyVars
sig_rdr_names_w_locs =
[GenLocated SrcSpanAnnN RdrName
op | L SrcSpanAnnA
_ (ClassOpSig XClassOpSig GhcPs
_ Bool
False [LIdP GhcPs]
ops LHsSigType GhcPs
_) <- [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs
, GenLocated SrcSpanAnnN RdrName
op <- [LIdP GhcPs]
FreeKiTyVars
ops]
; FreeKiTyVars -> TcRn ()
checkDupRdrNamesN FreeKiTyVars
sig_rdr_names_w_locs
; (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
; 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' <- (GenLocated SrcSpanAnnA (DocDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (DocDecl GhcRn)))
-> [GenLocated SrcSpanAnnA (DocDecl GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnA (DocDecl GhcRn)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LDocDecl GhcPs -> RnM (LDocDecl GhcRn)
GenLocated SrcSpanAnnA (DocDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (DocDecl GhcRn))
rnLDocDecl [LDocDecl GhcPs]
[GenLocated SrcSpanAnnA (DocDecl GhcPs)]
docs
; (TyClDecl GhcRn, FreeVars) -> TcM (TyClDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassDecl { tcdLayout :: LayoutInfo GhcRn
tcdLayout = LayoutInfo GhcPs -> LayoutInfo GhcRn
rnLayoutInfo LayoutInfo GhcPs
layout,
tcdCtxt :: Maybe (LHsContext GhcRn)
tcdCtxt = Maybe (LHsContext GhcRn)
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', tcdLName :: LIdP GhcRn
tcdLName = LIdP GhcRn
GenLocated SrcSpanAnnN Name
lcls',
tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars', tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity,
tcdFDs :: [LHsFunDep GhcRn]
tcdFDs = [LHsFunDep GhcRn]
[GenLocated SrcSpanAnnA (FunDep GhcRn)]
fds', tcdSigs :: [LSig GhcRn]
tcdSigs = [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs',
tcdMeths :: LHsBinds GhcRn
tcdMeths = LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds', tcdATs :: [LFamilyDecl GhcRn]
tcdATs = [LFamilyDecl GhcRn]
[LocatedA (FamilyDecl GhcRn)]
ats', tcdATDefs :: [LTyFamInstDecl GhcRn]
tcdATDefs = [LTyFamInstDecl GhcRn]
[LocatedA (TyFamInstDecl GhcRn)]
at_defs',
tcdDocs :: [LDocDecl GhcRn]
tcdDocs = [LDocDecl GhcRn]
[GenLocated SrcSpanAnnA (DocDecl GhcRn)]
docs', tcdCExt :: XClassDecl GhcRn
tcdCExt = XClassDecl GhcRn
FreeVars
all_fvs },
FreeVars
all_fvs ) }
where
cls_doc :: HsDocContext
cls_doc = GenLocated SrcSpanAnnN RdrName -> HsDocContext
ClassDeclCtx LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
lcls
rnLayoutInfo :: LayoutInfo GhcPs -> LayoutInfo GhcRn
rnLayoutInfo :: LayoutInfo GhcPs -> LayoutInfo GhcRn
rnLayoutInfo (ExplicitBraces LHsToken "{" GhcPs
ob LHsToken "}" GhcPs
cb) = LHsToken "{" GhcRn -> LHsToken "}" GhcRn -> LayoutInfo GhcRn
forall pass.
LHsToken "{" pass -> LHsToken "}" pass -> LayoutInfo pass
ExplicitBraces LHsToken "{" GhcPs
LHsToken "{" GhcRn
ob LHsToken "}" GhcPs
LHsToken "}" GhcRn
cb
rnLayoutInfo (VirtualBraces Int
n) = Int -> LayoutInfo GhcRn
forall pass. Int -> LayoutInfo pass
VirtualBraces Int
n
rnLayoutInfo LayoutInfo GhcPs
NoLayoutInfo = LayoutInfo GhcRn
forall pass. LayoutInfo pass
NoLayoutInfo
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
{
; Bool
unlifted_newtypes <- Extension -> TcRn Bool
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
&& Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass p'))) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (LHsKind (GhcPass p'))
Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass p')))
kind_sig
| Bool
otherwise = Bool
False
; Bool -> TcRn Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> TcRn Bool) -> Bool -> TcRn Bool
forall a b. (a -> b) -> a -> b
$ LHsQTyVars (GhcPass p) -> Bool
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
}
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_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 -> DataDefnCons (LConDecl pass)
dd_cons = DataDefnCons (LConDecl GhcPs)
condecls
, dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsType GhcPs)
m_sig, dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcPs
derivs })
= do {
Bool -> TcRnMessage -> TcRn ()
checkTc (Bool
h98_style Bool -> Bool -> Bool
|| [GenLocated SrcSpanAnnA (HsType GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Maybe (LHsContext GhcPs) -> [LHsType GhcPs]
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcPs)
context))
(HsDocContext -> TcRnMessage
badGadtStupidTheta HsDocContext
doc)
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs)) -> Bool
forall a. DataDefnCons a -> Bool
isTypeDataDefnCons DataDefnCons (LConDecl GhcPs)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs))
condecls) TcRn ()
check_type_data
; (Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
m_sig', FreeVars
sig_fvs) <- case Maybe (LHsType GhcPs)
m_sig of
Just LHsType GhcPs
sig -> (GenLocated SrcSpanAnnA (HsType GhcRn)
-> Maybe (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars)
-> (Maybe (GenLocated SrcSpanAnnA (HsType GhcRn)), FreeVars)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first GenLocated SrcSpanAnnA (HsType GhcRn)
-> Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
forall a. a -> Maybe a
Just ((GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars)
-> (Maybe (GenLocated SrcSpanAnnA (HsType GhcRn)), FreeVars))
-> RnM (GenLocated SrcSpanAnnA (HsType GhcRn), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (GenLocated SrcSpanAnnA (HsType GhcRn)), FreeVars)
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 -> (Maybe (GenLocated SrcSpanAnnA (HsType GhcRn)), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (GenLocated SrcSpanAnnA (HsType GhcRn)), FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
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
[GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
derivs
; let { zap_lcl_env :: RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
-> RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
zap_lcl_env | Bool
h98_style = \ RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
thing -> RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
thing
| Bool
otherwise = LocalRdrEnv
-> RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
-> RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
emptyLocalRdrEnv }
; (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
condecls', FreeVars
con_fvs) <- RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
-> RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
zap_lcl_env (RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
-> RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars))
-> RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
-> RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
forall a b. (a -> b) -> a -> b
$ DataDefnCons (LConDecl GhcPs)
-> RnM (DataDefnCons (LConDecl GhcRn), FreeVars)
rnConDecls DataDefnCons (LConDecl GhcPs)
condecls
; 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
; (HsDataDefn GhcRn, FreeVars) -> RnM (HsDataDefn GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsDataDefn { dd_ext :: XCHsDataDefn GhcRn
dd_ext = XCHsDataDefn GhcRn
NoExtField
noExtField, dd_cType :: Maybe (XRec GhcRn CType)
dd_cType = Maybe (XRec GhcPs CType)
Maybe (XRec GhcRn CType)
cType
, dd_ctxt :: Maybe (LHsContext GhcRn)
dd_ctxt = Maybe (LHsContext GhcRn)
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', dd_kindSig :: Maybe (LHsType GhcRn)
dd_kindSig = Maybe (LHsType GhcRn)
Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
m_sig'
, dd_cons :: DataDefnCons (LConDecl GhcRn)
dd_cons = DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
condecls'
, dd_derivs :: HsDeriving GhcRn
dd_derivs = HsDeriving GhcRn
[GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)]
derivs' }
, FreeVars
all_fvs )
}
where
h98_style :: Bool
h98_style = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs)) -> Bool
forall (f :: * -> *) l pass.
Foldable f =>
f (GenLocated l (ConDecl pass)) -> Bool
anyLConIsGadt DataDefnCons (LConDecl GhcPs)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs))
condecls
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 <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DerivingStrategies
; Bool -> TcRnMessage -> TcRn ()
failIfTc ([GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
-> Int -> Bool
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) <- (GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)
-> RnM
(GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn), FreeVars))
-> [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (HsDocContext
-> LHsDerivingClause GhcPs
-> RnM (LHsDerivingClause GhcRn, FreeVars)
rnLHsDerivingClause HsDocContext
doc) [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
ds
; ([GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)], FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)], FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)]
ds', FreeVars
fvs) }
check_type_data :: TcRn ()
check_type_data
= do { Extension -> TcRn () -> TcRn ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.TypeData (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWith TcRnMessage
TcRnIllegalTypeData
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenLocated SrcSpanAnnA (HsType GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Maybe (LHsContext GhcPs) -> [LHsType GhcPs]
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcPs)
context)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWith (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TypeDataForbids -> TcRnMessage
TcRnTypeDataForbids TypeDataForbids
TypeDataForbidsDatatypeContexts
; (GenLocated SrcSpanAnnA (ConDecl GhcPs) -> TcRn ())
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs)) -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ConDecl GhcPs -> TcRn ())
-> GenLocated SrcSpanAnnA (ConDecl GhcPs) -> TcRn ()
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA ConDecl GhcPs -> TcRn ()
check_type_data_condecl) DataDefnCons (LConDecl GhcPs)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs))
condecls
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null HsDeriving GhcPs
[GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
derivs) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWith (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TypeDataForbids -> TcRnMessage
TcRnTypeDataForbids TypeDataForbids
TypeDataForbidsDerivingClauses
}
check_type_data_condecl :: ConDecl GhcPs -> RnM ()
check_type_data_condecl :: ConDecl GhcPs -> TcRn ()
check_type_data_condecl ConDecl GhcPs
condecl
= do {
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConDecl GhcPs -> Bool
forall {pass} {l}.
(XRec pass [XRec pass (ConDeclField pass)]
~ GenLocated l [XRec pass (ConDeclField pass)]) =>
ConDecl pass -> Bool
has_labelled_fields ConDecl GhcPs
condecl) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWith (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TypeDataForbids -> TcRnMessage
TcRnTypeDataForbids TypeDataForbids
TypeDataForbidsLabelledFields
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConDecl GhcPs -> Bool
forall {p :: Pass}. ConDecl (GhcPass p) -> Bool
has_strictness_flags ConDecl GhcPs
condecl) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWith (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TypeDataForbids -> TcRnMessage
TcRnTypeDataForbids TypeDataForbids
TypeDataForbidsStrictnessAnnotations
}
has_labelled_fields :: ConDecl pass -> Bool
has_labelled_fields (ConDeclGADT { con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = RecConGADT XRec pass [XRec pass (ConDeclField pass)]
_ LHsUniToken "->" "\8594" pass
_ }) = Bool
True
has_labelled_fields (ConDeclH98 { con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = RecCon XRec pass [XRec pass (ConDeclField pass)]
rec })
= Bool -> Bool
not ([XRec pass (ConDeclField pass)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (GenLocated l [XRec pass (ConDeclField pass)]
-> [XRec pass (ConDeclField pass)]
forall l e. GenLocated l e -> e
unLoc XRec pass [XRec pass (ConDeclField pass)]
GenLocated l [XRec pass (ConDeclField pass)]
rec))
has_labelled_fields ConDecl pass
_ = Bool
False
has_strictness_flags :: ConDecl (GhcPass p) -> Bool
has_strictness_flags ConDecl (GhcPass p)
condecl
= (HsScaled (GhcPass p) (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
-> Bool)
-> [HsScaled
(GhcPass p) (GenLocated SrcSpanAnnA (HsType (GhcPass p)))]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HsSrcBang -> Bool
is_strict (HsSrcBang -> Bool)
-> (HsScaled
(GhcPass p) (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
-> HsSrcBang)
-> HsScaled
(GhcPass p) (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType (GhcPass p) -> HsSrcBang
GenLocated SrcSpanAnnA (HsType (GhcPass p)) -> HsSrcBang
forall (p :: Pass). LHsType (GhcPass p) -> HsSrcBang
getBangStrictness (GenLocated SrcSpanAnnA (HsType (GhcPass p)) -> HsSrcBang)
-> (HsScaled
(GhcPass p) (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
-> GenLocated SrcSpanAnnA (HsType (GhcPass p)))
-> HsScaled
(GhcPass p) (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
-> HsSrcBang
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsScaled (GhcPass p) (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
-> GenLocated SrcSpanAnnA (HsType (GhcPass p))
forall pass a. HsScaled pass a -> a
hsScaledThing) (ConDecl (GhcPass p) -> [HsScaled (GhcPass p) (LHsType (GhcPass p))]
forall {pass}.
ConDecl pass -> [HsScaled pass (XRec pass (BangType pass))]
con_args ConDecl (GhcPass p)
condecl)
is_strict :: HsSrcBang -> Bool
is_strict (HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
s) = SrcStrictness -> Bool
isSrcStrict SrcStrictness
s
con_args :: ConDecl pass -> [HsScaled pass (XRec pass (BangType pass))]
con_args (ConDeclGADT { con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = PrefixConGADT [HsScaled pass (XRec pass (BangType pass))]
args }) = [HsScaled pass (XRec pass (BangType pass))]
args
con_args (ConDeclH98 { con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = PrefixCon [Void]
_ [HsScaled pass (XRec pass (BangType pass))]
args }) = [HsScaled pass (XRec pass (BangType pass))]
args
con_args (ConDeclH98 { con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = InfixCon HsScaled pass (XRec pass (BangType pass))
arg1 HsScaled pass (XRec pass (BangType pass))
arg2 }) = [HsScaled pass (XRec pass (BangType pass))
arg1, HsScaled pass (XRec pass (BangType pass))
arg2]
con_args ConDecl pass
_ = []
warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
-> SrcSpan
-> RnM ()
warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (LDerivStrategy GhcRn)
mds SrcSpan
loc
= do { DynFlags
dyn_flags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; case Maybe (LDerivStrategy GhcRn)
mds of
Maybe (LDerivStrategy GhcRn)
Nothing ->
let dia :: TcRnMessage
dia = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingDerivingStrategies) [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
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)
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
}
where
no_strat_warning :: SDoc
no_strat_warning :: SDoc
no_strat_warning = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"No deriving strategy specified. Did you want stock"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
", newtype, or anyclass?"
deriv_strat_nenabled :: SDoc
deriv_strat_nenabled :: SDoc
deriv_strat_nenabled = String -> SDoc
forall doc. IsLine doc => String -> doc
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)
<- HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (LDerivClauseTys GhcRn, FreeVars)
-> RnM
(Maybe (LDerivStrategy GhcRn), LDerivClauseTys GhcRn, FreeVars)
forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy HsDocContext
doc Maybe (LDerivStrategy GhcPs)
dcs (RnM (LDerivClauseTys GhcRn, FreeVars)
-> RnM
(Maybe (LDerivStrategy GhcRn), LDerivClauseTys GhcRn, FreeVars))
-> RnM (LDerivClauseTys GhcRn, FreeVars)
-> RnM
(Maybe (LDerivStrategy GhcRn), LDerivClauseTys GhcRn, FreeVars)
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 (LDerivStrategy GhcRn)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
dcs' (SrcAnn NoEpAnns -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcAnn NoEpAnns
loc)
; (GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn), FreeVars)
-> RnM
(GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn), FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( SrcAnn NoEpAnns
-> HsDerivingClause GhcRn
-> GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
loc (HsDerivingClause { deriv_clause_ext :: XCHsDerivingClause GhcRn
deriv_clause_ext = XCHsDerivingClause GhcPs
XCHsDerivingClause GhcRn
noExtField
, deriv_clause_strategy :: Maybe (LDerivStrategy GhcRn)
deriv_clause_strategy = Maybe (LDerivStrategy GhcRn)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
dcs'
, deriv_clause_tys :: LDerivClauseTys GhcRn
deriv_clause_tys = LDerivClauseTys GhcRn
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
(GenLocated SrcSpanAnnC (DerivClauseTys GhcRn), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnC (DerivClauseTys GhcRn), FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpanAnnC
-> DerivClauseTys GhcRn
-> GenLocated SrcSpanAnnC (DerivClauseTys GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
l (XDctSingle GhcRn -> LHsSigType GhcRn -> DerivClauseTys GhcRn
forall pass.
XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass
DctSingle XDctSingle GhcPs
XDctSingle GhcRn
x LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty'), FreeVars
fvs)
DctMulti XDctMulti GhcPs
x [LHsSigType GhcPs]
tys -> do
([GenLocated SrcSpanAnnA (HsSigType GhcRn)]
tys', FreeVars
fvs) <- (GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsSigType GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
-> RnM ([GenLocated SrcSpanAnnA (HsSigType GhcRn)], FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsSigType GhcRn), FreeVars)
rn_clause_pred [LHsSigType GhcPs]
[GenLocated SrcSpanAnnA (HsSigType GhcPs)]
tys
(GenLocated SrcSpanAnnC (DerivClauseTys GhcRn), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnC (DerivClauseTys GhcRn), FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpanAnnC
-> DerivClauseTys GhcRn
-> GenLocated SrcSpanAnnC (DerivClauseTys GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
l (XDctMulti GhcRn -> [LHsSigType GhcRn] -> DerivClauseTys GhcRn
forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti XDctMulti GhcPs
XDctMulti GhcRn
x [LHsSigType GhcRn]
[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 = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
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
HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
doc (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Derived class type")
(LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
pred_ty')
(GenLocated SrcSpanAnnA (HsSigType GhcRn), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsSigType GhcRn), FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 -> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
-> RnM
(Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn)), a,
FreeVars)
forall ds. ds -> RnM (ds, a, FreeVars)
boring_case Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
forall a. Maybe a
Nothing
Just (L SrcAnn NoEpAnns
loc DerivStrategy GhcPs
ds) ->
SrcAnn NoEpAnns
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcAnn NoEpAnns
loc (RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars))
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
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
(Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn)), a,
FreeVars)
-> RnM
(Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn)), a,
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn)
-> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
forall a. a -> Maybe a
Just (SrcAnn NoEpAnns
-> DerivStrategy GhcRn
-> GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn)
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
Extension -> TcRn () -> TcRn ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
extNeeded (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWith (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DerivStrategy GhcPs -> TcRnMessage
illegalDerivStrategyErr DerivStrategy GhcPs
ds
case DerivStrategy GhcPs
ds of
StockStrategy XStockStrategy GhcPs
_ -> DerivStrategy GhcRn -> RnM (DerivStrategy GhcRn, a, FreeVars)
forall ds. ds -> RnM (ds, a, FreeVars)
boring_case (XStockStrategy GhcRn -> DerivStrategy GhcRn
forall pass. XStockStrategy pass -> DerivStrategy pass
StockStrategy XStockStrategy GhcRn
NoExtField
noExtField)
AnyclassStrategy XAnyClassStrategy GhcPs
_ -> DerivStrategy GhcRn -> RnM (DerivStrategy GhcRn, a, FreeVars)
forall ds. ds -> RnM (ds, a, FreeVars)
boring_case (XAnyClassStrategy GhcRn -> DerivStrategy GhcRn
forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy XAnyClassStrategy GhcRn
NoExtField
noExtField)
NewtypeStrategy XNewtypeStrategy GhcPs
_ -> DerivStrategy GhcRn -> RnM (DerivStrategy GhcRn, a, FreeVars)
forall ds. ds -> RnM (ds, a, FreeVars)
boring_case (XNewtypeStrategy GhcRn -> DerivStrategy GhcRn
forall pass. XNewtypeStrategy pass -> DerivStrategy pass
NewtypeStrategy XNewtypeStrategy GhcRn
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 } = GenLocated SrcSpanAnnA (HsSigType GhcRn) -> HsSigType GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsSigType GhcRn)
via_ty'
via_tvs :: [Name]
via_tvs = HsOuterTyVarBndrs Specificity GhcRn -> [Name]
forall flag. HsOuterTyVarBndrs flag GhcRn -> [Name]
hsOuterTyVarNames HsOuterTyVarBndrs Specificity GhcRn
via_outer_bndrs
HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
doc
(SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"via") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"type") LHsType GhcRn
via_body
(a
thing, FreeVars
fvs2) <- [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
via_tvs RnM (a, FreeVars)
thing_inside
(DerivStrategy GhcRn, a, FreeVars)
-> RnM (DerivStrategy GhcRn, a, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XViaStrategy GhcRn -> DerivStrategy GhcRn
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy XViaStrategy GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
via_ty', a
thing, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2)
inf_err :: Maybe SDoc
inf_err = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
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
(ds, a, FreeVars) -> RnM (ds, a, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ds
ds, a
thing, FreeVars
fvs)
badGadtStupidTheta :: HsDocContext -> TcRnMessage
badGadtStupidTheta :: HsDocContext -> TcRnMessage
badGadtStupidTheta HsDocContext
_
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"No context is allowed on a GADT-style data declaration",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(You can put a context on each constructor, though.)"]
illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage
illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage
illegalDerivStrategyErr DerivStrategy GhcPs
ds
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Illegal deriving strategy" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DerivStrategy GhcPs -> SDoc
forall a. DerivStrategy a -> SDoc
derivStrategyName DerivStrategy GhcPs
ds
, String -> SDoc
forall doc. IsLine doc => String -> doc
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
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Illegal use of multiple, consecutive deriving clauses"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Use DerivingStrategies to allow this" ]
rnFamDecl :: Maybe Name
-> 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
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
tycon
; ((LHsQTyVars GhcRn
tyvars', GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn)
res_sig', Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
injectivity'), FreeVars
fv1) <-
HsDocContext
-> Maybe Name
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn,
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn),
Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))),
FreeVars))
-> RnM
((LHsQTyVars GhcRn,
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn),
Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))),
FreeVars)
forall a b.
HsDocContext
-> Maybe a
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc Maybe Name
mb_cls FreeKiTyVars
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn,
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn),
Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))),
FreeVars))
-> RnM
((LHsQTyVars GhcRn,
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn),
Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))),
FreeVars))
-> (LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn,
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn),
Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))),
FreeVars))
-> RnM
((LHsQTyVars GhcRn,
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn),
Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))),
FreeVars)
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) <- (FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, FreeVars))
-> GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcPs)
-> TcM
(GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn), FreeVars)
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
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcPs)
res_sig
; Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
injectivity' <- (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)))
-> Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (LHsQTyVars GhcRn
-> LFamilyResultSig GhcRn
-> LInjectivityAnn GhcPs
-> RnM (LInjectivityAnn GhcRn)
rnInjectivityAnn LHsQTyVars GhcRn
tyvars' LFamilyResultSig GhcRn
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn)
res_sig')
Maybe (LInjectivityAnn GhcPs)
Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcPs))
injectivity
; ((LHsQTyVars GhcRn,
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn),
Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))),
FreeVars)
-> RnM
((LHsQTyVars GhcRn,
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn),
Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))),
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
; (FamilyDecl GhcRn, FreeVars) -> RnM (FamilyDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FamilyDecl { fdExt :: XCFamilyDecl GhcRn
fdExt = XCFamilyDecl GhcRn
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn
, fdLName :: LIdP GhcRn
fdLName = LIdP GhcRn
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 = LFamilyResultSig GhcRn
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcRn)
res_sig'
, fdInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcRn)
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
GenLocated SrcSpanAnnN RdrName
tycon
kvs :: FreeKiTyVars
kvs = LFamilyResultSig GhcPs -> FreeKiTyVars
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)
<- (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)), FreeVars))
-> [LocatedA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
-> RnM
([LocatedA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))],
FreeVars)
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]
[LocatedA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
eqns
; (FamilyInfo GhcRn, FreeVars) -> RnM (FamilyInfo GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily ([LocatedA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
-> Maybe
[LocatedA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
forall a. a -> Maybe a
Just [LocatedA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
eqns'), FreeVars
fvs) }
rn_info (ClosedTypeFamily Maybe [LTyFamInstEqn GhcPs]
Nothing)
= (FamilyInfo GhcRn, FreeVars) -> RnM (FamilyInfo GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily Maybe [LTyFamInstEqn GhcRn]
Maybe
[LocatedA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
forall a. Maybe a
Nothing, FreeVars
emptyFVs)
rn_info FamilyInfo GhcPs
OpenTypeFamily = (FamilyInfo GhcRn, FreeVars) -> RnM (FamilyInfo GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FamilyInfo GhcRn
forall pass. FamilyInfo pass
OpenTypeFamily, FreeVars
emptyFVs)
rn_info FamilyInfo GhcPs
DataFamily = (FamilyInfo GhcRn, FreeVars) -> RnM (FamilyInfo GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FamilyInfo GhcRn
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
_)
= (FamilyResultSig GhcRn, FreeVars)
-> RnM (FamilyResultSig GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XNoSig GhcRn -> FamilyResultSig GhcRn
forall pass. XNoSig pass -> FamilyResultSig pass
NoSig XNoSig GhcRn
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
; (FamilyResultSig GhcRn, FreeVars)
-> RnM (FamilyResultSig GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCKindSig GhcRn -> LHsType GhcRn -> FamilyResultSig GhcRn
forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
KindSig XCKindSig GhcRn
NoExtField
noExtField LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
rndKind, FreeVars
ftvs) }
rnFamResultSig HsDocContext
doc (TyVarSig XTyVarSig GhcPs
_ LHsTyVarBndr () GhcPs
tvbndr)
= do {
LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
; let resName :: IdP GhcPs
resName = LHsTyVarBndr () GhcPs -> IdP GhcPs
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcPs
tvbndr
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IdP GhcPs
RdrName
resName RdrName -> LocalRdrEnv -> Bool
`elemLocalRdrEnv` LocalRdrEnv
rdr_env) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsTyVarBndr () GhcPs
GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
tvbndr) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Type variable", SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdP GhcPs
RdrName
resName) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"naming a type family result,"
] SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"shadows an already bound type variable")
; HsDocContext
-> Maybe Any
-> LHsTyVarBndr () GhcPs
-> (LHsTyVarBndr () GhcRn -> RnM (FamilyResultSig GhcRn, FreeVars))
-> RnM (FamilyResultSig GhcRn, FreeVars)
forall a flag b.
HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr HsDocContext
doc Maybe Any
forall a. Maybe a
Nothing
LHsTyVarBndr () GhcPs
tvbndr ((LHsTyVarBndr () GhcRn -> RnM (FamilyResultSig GhcRn, FreeVars))
-> RnM (FamilyResultSig GhcRn, FreeVars))
-> (LHsTyVarBndr () GhcRn -> RnM (FamilyResultSig GhcRn, FreeVars))
-> RnM (FamilyResultSig GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ LHsTyVarBndr () GhcRn
tvbndr' ->
(FamilyResultSig GhcRn, FreeVars)
-> RnM (FamilyResultSig GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XTyVarSig GhcRn -> LHsTyVarBndr () GhcRn -> FamilyResultSig GhcRn
forall pass.
XTyVarSig pass -> LHsTyVarBndr () pass -> FamilyResultSig pass
TyVarSig XTyVarSig GhcRn
NoExtField
noExtField LHsTyVarBndr () GhcRn
tvbndr', Name -> FreeVars
unitFV (LHsTyVarBndr () GhcRn -> IdP GhcRn
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
tvbndr')) }
rnInjectivityAnn :: LHsQTyVars GhcRn
-> LFamilyResultSig GhcRn
-> LInjectivityAnn GhcPs
-> 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)
<- IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
-> TcRn (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn), Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs (IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
-> TcRn
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn), Bool))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
-> TcRn (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn), Bool)
forall a b. (a -> b) -> a -> b
$
[Name]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [LHsTyVarBndr () GhcRn -> IdP GhcRn
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
resTv] (IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
forall a b. (a -> b) -> a -> b
$
do { GenLocated SrcSpanAnnN Name
injFrom' <- GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
rnLTyVar LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
injFrom
; [GenLocated SrcSpanAnnN Name]
injTo' <- (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name))
-> FreeKiTyVars
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
rnLTyVar [LIdP GhcPs]
FreeKiTyVars
injTo
; GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)))
-> GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
forall a b. (a -> b) -> a -> b
$ SrcAnn NoEpAnns
-> InjectivityAnn GhcRn
-> GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcAnn NoEpAnns -> SrcAnn NoEpAnns
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NoEpAnns
srcSpan) (XCInjectivityAnn GhcRn
-> LIdP GhcRn -> [LIdP GhcRn] -> InjectivityAnn GhcRn
forall pass.
XCInjectivityAnn pass
-> LIdP pass -> [LIdP pass] -> InjectivityAnn pass
InjectivityAnn XCInjectivityAnn GhcPs
XCInjectivityAnn GhcRn
x LIdP GhcRn
GenLocated SrcSpanAnnN Name
injFrom' [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
injTo') }
; let tvNames :: Set Name
tvNames = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ LHsQTyVars GhcRn -> [Name]
hsAllLTyVarNames LHsQTyVars GhcRn
tvBndrs
resName :: IdP GhcRn
resName = LHsTyVarBndr () GhcRn -> IdP GhcRn
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
resTv
lhsValid :: Bool
lhsValid = Ordering
EQ Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== (Name -> Name -> Ordering
stableNameCmp IdP GhcRn
Name
resName (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
injFrom'))
rhsValid :: Set Name
rhsValid = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ((GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
injTo') Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Name
tvNames
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
noRnErrors Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
lhsValid) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (GenLocated SrcSpanAnnN RdrName -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
injFrom) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
( [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"Incorrect type variable on the LHS of "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"injectivity condition"
, Int -> SDoc -> SDoc
nest Int
5
( [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Expected :" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdP GhcRn
Name
resName
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Actual :" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
injFrom ])])
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
noRnErrors Bool -> Bool -> Bool
&& Bool -> Bool
not (Set Name -> Bool
forall a. Set a -> Bool
Set.null Set Name
rhsValid)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { let errorVars :: [Name]
errorVars = Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Set Name
rhsValid
; SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (SrcAnn NoEpAnns -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcAnn NoEpAnns
srcSpan) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
( [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unknown type variable" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Name] -> SDoc
forall a. [a] -> SDoc
plural [Name]
errorVars
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"on the RHS of injectivity condition:"
, [Name] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [Name]
errorVars ] ) }
; GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
injDecl' }
rnInjectivityAnn LHsQTyVars GhcRn
_ LFamilyResultSig GhcRn
_ (L SrcAnn NoEpAnns
srcSpan (InjectivityAnn XCInjectivityAnn GhcPs
x LIdP GhcPs
injFrom [LIdP GhcPs]
injTo)) =
SrcAnn NoEpAnns
-> RnM (LInjectivityAnn GhcRn) -> RnM (LInjectivityAnn GhcRn)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcAnn NoEpAnns
srcSpan (RnM (LInjectivityAnn GhcRn) -> RnM (LInjectivityAnn GhcRn))
-> RnM (LInjectivityAnn GhcRn) -> RnM (LInjectivityAnn GhcRn)
forall a b. (a -> b) -> a -> b
$ do
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
injDecl', Bool
_) <- IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
-> TcRn (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn), Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs (IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
-> TcRn
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn), Bool))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
-> TcRn (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn), Bool)
forall a b. (a -> b) -> a -> b
$ do
GenLocated SrcSpanAnnN Name
injFrom' <- GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
rnLTyVar LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
injFrom
[GenLocated SrcSpanAnnN Name]
injTo' <- (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name))
-> FreeKiTyVars
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
rnLTyVar [LIdP GhcPs]
FreeKiTyVars
injTo
GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)))
-> GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
forall a b. (a -> b) -> a -> b
$ SrcAnn NoEpAnns
-> InjectivityAnn GhcRn
-> GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
srcSpan (XCInjectivityAnn GhcRn
-> LIdP GhcRn -> [LIdP GhcRn] -> InjectivityAnn GhcRn
forall pass.
XCInjectivityAnn pass
-> LIdP pass -> [LIdP pass] -> InjectivityAnn pass
InjectivityAnn XCInjectivityAnn GhcPs
XCInjectivityAnn GhcRn
x LIdP GhcRn
GenLocated SrcSpanAnnN Name
injFrom' [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
injTo')
GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)))
-> GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn))
forall a b. (a -> b) -> a -> b
$ GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcRn)
injDecl'
rnConDecls :: DataDefnCons (LConDecl GhcPs) -> RnM (DataDefnCons (LConDecl GhcRn), FreeVars)
rnConDecls :: DataDefnCons (LConDecl GhcPs)
-> RnM (DataDefnCons (LConDecl GhcRn), FreeVars)
rnConDecls = (GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> RnM (GenLocated SrcSpanAnnA (ConDecl GhcRn), FreeVars))
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs))
-> RnM
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)), FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn ((ConDecl GhcPs -> TcM (ConDecl GhcRn, FreeVars))
-> GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> RnM (GenLocated SrcSpanAnnA (ConDecl GhcRn), FreeVars)
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA ConDecl GhcPs -> TcM (ConDecl GhcRn, FreeVars)
rnConDecl)
rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl :: ConDecl GhcPs -> TcM (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 { ()
_ <- (RdrName -> TcRn ()) -> GenLocated SrcSpanAnnN RdrName -> TcRn ()
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA RdrName -> TcRn ()
checkConName LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name
; GenLocated SrcSpanAnnN Name
new_name <- GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name
; let ctxt :: HsDocContext
ctxt = [GenLocated SrcSpanAnnN Name] -> HsDocContext
ConDeclCtx [GenLocated SrcSpanAnnN Name
new_name]
; HsDocContext
-> WarnUnusedForalls
-> Maybe Any
-> [LHsTyVarBndr Specificity GhcPs]
-> ([LHsTyVarBndr Specificity GhcRn]
-> TcM (ConDecl GhcRn, FreeVars))
-> TcM (ConDecl GhcRn, FreeVars)
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
Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr Specificity GhcPs]
ex_tvs (([LHsTyVarBndr Specificity GhcRn]
-> TcM (ConDecl GhcRn, FreeVars))
-> TcM (ConDecl GhcRn, FreeVars))
-> ([LHsTyVarBndr Specificity GhcRn]
-> TcM (ConDecl GhcRn, FreeVars))
-> TcM (ConDecl GhcRn, FreeVars)
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 (GenLocated SrcSpanAnnN Name -> Name
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)" (GenLocated SrcSpanAnnN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ex_tvs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr Specificity GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
ex_tvs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"new_ex_dqtvs':" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr Specificity GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
new_ex_tvs ])
; Maybe (LHsDoc GhcRn)
mb_doc' <- (LHsDoc GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) (LHsDoc GhcRn))
-> Maybe (LHsDoc GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsDoc GhcRn))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse LHsDoc GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) (LHsDoc GhcRn)
rnLHsDoc Maybe (LHsDoc GhcPs)
mb_doc
; (ConDecl GhcRn, FreeVars) -> TcM (ConDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConDecl GhcPs
decl { con_ext = noAnn
, con_name = new_name, con_ex_tvs = new_ex_tvs
, con_mb_cxt = new_context, con_args = new_args
, con_doc = mb_doc'
, con_forall = forall_ },
FreeVars
all_fvs) }}
rnConDecl (ConDeclGADT { con_names :: forall pass. ConDecl pass -> NonEmpty (LIdP pass)
con_names = NonEmpty (LIdP GhcPs)
names
, con_dcolon :: forall pass. ConDecl pass -> LHsUniToken "::" "\8759" pass
con_dcolon = LHsUniToken "::" "\8759" GhcPs
dcol
, 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 { (GenLocated SrcSpanAnnN RdrName -> TcRn ())
-> NonEmpty (GenLocated SrcSpanAnnN RdrName) -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((RdrName -> TcRn ()) -> GenLocated SrcSpanAnnN RdrName -> TcRn ()
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA RdrName -> TcRn ()
checkConName) NonEmpty (LIdP GhcPs)
NonEmpty (GenLocated SrcSpanAnnN RdrName)
names
; NonEmpty (GenLocated SrcSpanAnnN Name)
new_names <- (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name))
-> NonEmpty (GenLocated SrcSpanAnnN RdrName)
-> IOEnv
(Env TcGblEnv TcLclEnv) (NonEmpty (GenLocated SrcSpanAnnN Name))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
lookupLocatedTopConstructorRnN) NonEmpty (LIdP GhcPs)
NonEmpty (GenLocated SrcSpanAnnN RdrName)
names
; let
implicit_bndrs :: FreeKiTyVars
implicit_bndrs =
HsOuterSigTyVarBndrs GhcPs -> FreeKiTyVars -> FreeKiTyVars
forall flag.
HsOuterTyVarBndrs flag GhcPs -> FreeKiTyVars -> FreeKiTyVars
extractHsOuterTvBndrs HsOuterSigTyVarBndrs GhcPs
outer_bndrs (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
[LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extractHsTysRdrTyVars (Maybe (LHsContext GhcPs) -> [LHsType GhcPs]
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
hsConDeclTheta Maybe (LHsContext GhcPs)
mcxt) (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars
extractConDeclGADTDetailsTyVars HsConDeclGADTDetails GhcPs
args (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
[LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extractHsTysRdrTyVars [LHsType GhcPs
res_ty] []
; let ctxt :: HsDocContext
ctxt = [GenLocated SrcSpanAnnN Name] -> HsDocContext
ConDeclCtx (NonEmpty (GenLocated SrcSpanAnnN Name)
-> [GenLocated SrcSpanAnnN Name]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (GenLocated SrcSpanAnnN Name)
new_names)
; HsDocContext
-> Maybe Any
-> FreeKiTyVars
-> HsOuterSigTyVarBndrs GhcPs
-> (HsOuterTyVarBndrs Specificity GhcRn
-> TcM (ConDecl GhcRn, FreeVars))
-> TcM (ConDecl GhcRn, FreeVars)
forall flag assoc a.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> Maybe assoc
-> FreeKiTyVars
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs HsDocContext
ctxt Maybe Any
forall a. Maybe a
Nothing FreeKiTyVars
implicit_bndrs HsOuterSigTyVarBndrs GhcPs
outer_bndrs ((HsOuterTyVarBndrs Specificity GhcRn
-> TcM (ConDecl GhcRn, FreeVars))
-> TcM (ConDecl GhcRn, FreeVars))
-> (HsOuterTyVarBndrs Specificity GhcRn
-> TcM (ConDecl GhcRn, FreeVars))
-> TcM (ConDecl GhcRn, FreeVars)
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 (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (NonEmpty (GenLocated SrcSpanAnnN Name)
-> GenLocated SrcSpanAnnN Name
forall a. NonEmpty a -> a
head NonEmpty (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
; HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
ctxt
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GADT constructor type signature") LHsType GhcRn
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)"
(NonEmpty (GenLocated SrcSpanAnnN RdrName) -> SDoc
forall a. Outputable a => a -> SDoc
ppr NonEmpty (LIdP GhcPs)
NonEmpty (GenLocated SrcSpanAnnN RdrName)
names SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ HsOuterTyVarBndrs Specificity GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs')
; Maybe (LHsDoc GhcRn)
new_mb_doc <- (LHsDoc GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) (LHsDoc GhcRn))
-> Maybe (LHsDoc GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsDoc GhcRn))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse LHsDoc GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) (LHsDoc GhcRn)
rnLHsDoc Maybe (LHsDoc GhcPs)
mb_doc
; (ConDecl GhcRn, FreeVars) -> TcM (ConDecl GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConDeclGADT { con_g_ext :: XConDeclGADT GhcRn
con_g_ext = XConDeclGADT GhcRn
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn, con_names :: NonEmpty (LIdP GhcRn)
con_names = NonEmpty (LIdP GhcRn)
NonEmpty (GenLocated SrcSpanAnnN Name)
new_names
, con_dcolon :: LHsUniToken "::" "\8759" GhcRn
con_dcolon = LHsUniToken "::" "\8759" GhcPs
LHsUniToken "::" "\8759" GhcRn
dcol
, con_bndrs :: XRec GhcRn (HsOuterTyVarBndrs Specificity GhcRn)
con_bndrs = SrcSpanAnnA
-> HsOuterTyVarBndrs Specificity GhcRn
-> GenLocated SrcSpanAnnA (HsOuterTyVarBndrs Specificity GhcRn)
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 (LHsContext GhcRn)
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 = LHsType GhcRn
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 = (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
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
; (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]),
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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) <- (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> RnM
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)), FreeVars))
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> RnM
([HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))],
FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc) [HsScaled GhcPs (LHsType GhcPs)]
[HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys
; (HsConDetails
Void
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsConDetails
Void
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]),
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Void]
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> HsConDetails
Void
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
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
; (HsConDetails
Void
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsConDetails
Void
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]),
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsConDetails
Void
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
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 [XRec GhcPs (ConDeclField GhcPs)]
flds)
= do { (GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_flds, FreeVars
fvs) <- Name
-> HsDocContext
-> GenLocated SrcSpanAnnL [XRec GhcPs (ConDeclField GhcPs)]
-> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields Name
con HsDocContext
doc XRec GhcPs [XRec GhcPs (ConDeclField GhcPs)]
GenLocated SrcSpanAnnL [XRec GhcPs (ConDeclField GhcPs)]
flds
; (HsConDetails
Void
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsConDetails
Void
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]),
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> HsConDetails
Void
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
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) <- (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> RnM
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)), FreeVars))
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> RnM
([HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))],
FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc) [HsScaled GhcPs (LHsType GhcPs)]
[HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys
; (HsConDeclGADTDetails GhcRn, FreeVars)
-> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsScaled GhcRn (LHsType GhcRn)] -> HsConDeclGADTDetails GhcRn
forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT [HsScaled GhcRn (LHsType GhcRn)]
[HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
new_tys, FreeVars
fvs) }
rnConDeclGADTDetails Name
con HsDocContext
doc (RecConGADT XRec GhcPs [XRec GhcPs (ConDeclField GhcPs)]
flds LHsUniToken "->" "\8594" GhcPs
arr)
= do { (GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_flds, FreeVars
fvs) <- Name
-> HsDocContext
-> GenLocated SrcSpanAnnL [XRec GhcPs (ConDeclField GhcPs)]
-> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields Name
con HsDocContext
doc XRec GhcPs [XRec GhcPs (ConDeclField GhcPs)]
GenLocated SrcSpanAnnL [XRec GhcPs (ConDeclField GhcPs)]
flds
; (HsConDeclGADTDetails GhcRn, FreeVars)
-> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XRec GhcRn [LConDeclField GhcRn]
-> LHsUniToken "->" "\8594" GhcRn -> HsConDeclGADTDetails GhcRn
forall pass.
XRec pass [LConDeclField pass]
-> LHsUniToken "->" "\8594" pass -> HsConDeclGADTDetails pass
RecConGADT XRec GhcRn [LConDeclField GhcRn]
GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_flds LHsUniToken "->" "\8594" GhcPs
LHsUniToken "->" "\8594" GhcRn
arr, FreeVars
fvs) }
rnRecConDeclFields ::
Name
-> HsDocContext
-> LocatedL [LConDeclField GhcPs]
-> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields :: Name
-> HsDocContext
-> GenLocated SrcSpanAnnL [XRec GhcPs (ConDeclField GhcPs)]
-> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields Name
con HsDocContext
doc (L SrcSpanAnnL
l [XRec GhcPs (ConDeclField GhcPs)]
fields)
= do { [FieldLabel]
fls <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
con
; ([GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_fields, FreeVars
fvs) <- HsDocContext
-> [FieldLabel]
-> [XRec GhcPs (ConDeclField GhcPs)]
-> RnM ([LConDeclField GhcRn], FreeVars)
rnConDeclFields HsDocContext
doc [FieldLabel]
fls [XRec GhcPs (ConDeclField GhcPs)]
fields
; (GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)],
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)],
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpanAnnL
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_fields, FreeVars
fvs) }
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 = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Name
nameName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector [FieldLabel]
fields
| (Name
name, [FieldLabel]
fields) <- [(Name, [FieldLabel])]
names_with_fls ]
; let avails :: [AvailInfo]
avails = (Name -> AvailInfo) -> [Name] -> [AvailInfo]
forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail (((Name, [FieldLabel]) -> Name) -> [(Name, [FieldLabel])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [FieldLabel]) -> Name
forall a b. (a, b) -> a
fst [(Name, [FieldLabel])]
names_with_fls)
[AvailInfo] -> [AvailInfo] -> [AvailInfo]
forall a. [a] -> [a] -> [a]
++ (FieldLabel -> AvailInfo) -> [FieldLabel] -> [AvailInfo]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> AvailInfo
availField (((Name, [FieldLabel]) -> [FieldLabel])
-> [(Name, [FieldLabel])] -> [FieldLabel]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, [FieldLabel]) -> [FieldLabel]
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' = NameEnv [FieldLabel]
-> [(Name, [FieldLabel])] -> NameEnv [FieldLabel]
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcGblEnv -> NameEnv [FieldLabel]
tcg_field_env TcGblEnv
gbl_env) [(Name, [FieldLabel])]
names_with_fls
final_gbl_env :: TcGblEnv
final_gbl_env = TcGblEnv
gbl_env { tcg_field_env = field_env' }
; (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
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]
_) = (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])])
-> [(Name, [FieldLabel])]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
-> TcM [(Name, [FieldLabel])]
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])]
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
new_ps' [] LHsBinds GhcPs
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds
new_ps HsValBinds GhcPs
_ = String -> TcM [(Name, [FieldLabel])]
forall a. HasCallStack => 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 (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnN
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnA
bind_loc) RdrName
n)
let field_occs :: [GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)]
field_occs = (RecordPatSynField GhcPs
-> GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
-> [RecordPatSynField GhcPs]
-> [GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ((\ FieldOcc GhcPs
f -> SrcAnn NoEpAnns
-> FieldOcc GhcPs -> GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn NoEpAnns
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan (SrcSpan -> SrcAnn NoEpAnns) -> SrcSpan -> SrcAnn NoEpAnns
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (FieldOcc GhcPs -> XRec GhcPs RdrName
forall pass. FieldOcc pass -> XRec pass RdrName
foLabel FieldOcc GhcPs
f)) FieldOcc GhcPs
f) (FieldOcc GhcPs -> GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
-> (RecordPatSynField GhcPs -> FieldOcc GhcPs)
-> RecordPatSynField GhcPs
-> GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordPatSynField GhcPs -> FieldOcc GhcPs
forall pass. RecordPatSynField pass -> FieldOcc pass
recordPatSynField) [RecordPatSynField GhcPs]
as
[FieldLabel]
flds <- (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) FieldLabel)
-> [GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)]
-> RnM [FieldLabel]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (DuplicateRecordFields
-> FieldSelectors
-> [Name]
-> LFieldOcc GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) FieldLabel
newRecordSelector DuplicateRecordFields
dup_fields_ok FieldSelectors
has_sel [Name
bnd_name]) [GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)]
field_occs
[(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
bnd_name, [FieldLabel]
flds)(Name, [FieldLabel])
-> [(Name, [FieldLabel])] -> [(Name, [FieldLabel])]
forall a. a -> [a] -> [a]
: [(Name, [FieldLabel])]
names)
| 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 (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnN
forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
bind_loc) RdrName
n)
[(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
bnd_name, [])(Name, [FieldLabel])
-> [(Name, [FieldLabel])] -> [(Name, [FieldLabel])]
forall a. a -> [a] -> [a]
: [(Name, [FieldLabel])]
names)
| Bool
otherwise
= [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name, [FieldLabel])]
names
rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds [LHsFunDep GhcPs]
fds
= (GenLocated SrcSpanAnnA (FunDep GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (FunDep GhcRn)))
-> [GenLocated SrcSpanAnnA (FunDep GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnA (FunDep GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((FunDep GhcPs -> TcM (FunDep GhcRn))
-> GenLocated SrcSpanAnnA (FunDep GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (FunDep GhcRn))
forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA FunDep GhcPs -> TcM (FunDep GhcRn)
rn_fds) [LHsFunDep GhcPs]
[GenLocated SrcSpanAnnA (FunDep GhcPs)]
fds
where
rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn)
rn_fds :: FunDep GhcPs -> TcM (FunDep GhcRn)
rn_fds (FunDep XCFunDep GhcPs
x [LIdP GhcPs]
tys1 [LIdP GhcPs]
tys2)
= do { [GenLocated SrcSpanAnnN Name]
tys1' <- FreeKiTyVars
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
rnHsTyVars [LIdP GhcPs]
FreeKiTyVars
tys1
; [GenLocated SrcSpanAnnN Name]
tys2' <- FreeKiTyVars
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
rnHsTyVars [LIdP GhcPs]
FreeKiTyVars
tys2
; FunDep GhcRn -> TcM (FunDep GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCFunDep GhcRn -> [LIdP GhcRn] -> [LIdP GhcRn] -> FunDep GhcRn
forall pass.
XCFunDep pass -> [LIdP pass] -> [LIdP pass] -> FunDep pass
FunDep XCFunDep GhcPs
XCFunDep GhcRn
x [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
tys1' [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
tys2') }
rnHsTyVars :: [LocatedN RdrName] -> RnM [LocatedN Name]
rnHsTyVars :: FreeKiTyVars
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
rnHsTyVars FreeKiTyVars
tvs = (GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name))
-> FreeKiTyVars
-> IOEnv (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnN Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
rnHsTyVar FreeKiTyVars
tvs
rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name)
rnHsTyVar :: GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
rnHsTyVar (L SrcSpanAnnN
l RdrName
tyvar) = do
Name
tyvar' <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupOccRn RdrName
tyvar
GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnN Name)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l Name
tyvar')
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 HsGroup GhcPs
forall (p :: Pass). HsGroup (GhcPass p)
emptyRdrGroup [LHsDecl GhcPs]
ds
addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl :: HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl HsGroup GhcPs
gp [] = (HsGroup GhcPs,
Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsGroup GhcPs,
Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsGroup GhcPs
gp, Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
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]))
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 :: HsUntypedSplice GhcPs
qq@HsQuasiQuote{}) SpliceDecoration
_)) [LHsDecl GhcPs]
ds
= do { ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds', FreeVars
_) <- HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls HsUntypedSplice GhcPs
qq
; HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl HsGroup GhcPs
gp ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds' [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds)
}
add HsGroup GhcPs
gp SrcSpanAnnA
loc (SpliceD XSpliceD GhcPs
_ splice :: SpliceDecl GhcPs
splice@(SpliceDecl XSpliceDecl GhcPs
_ XRec GhcPs (HsUntypedSplice GhcPs)
_ SpliceDecoration
flag)) [LHsDecl GhcPs]
ds
= do {
case SpliceDecoration
flag of
SpliceDecoration
DollarSplice -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
SpliceDecoration
BareSplice -> do { Bool
th_on <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TemplateHaskell
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
th_on (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWith TcRnMessage
badImplicitSplice }
; (HsGroup GhcPs,
Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsGroup GhcPs,
Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsGroup GhcPs
gp, (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> Maybe
(SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall a. a -> Maybe a
Just (SpliceDecl GhcPs
splice, [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds)) }
where
badImplicitSplice :: TcRnMessage
badImplicitSplice :: TcRnMessage
badImplicitSplice = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Parse error: module header, import declaration"
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"or top-level declaration expected."
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 = add_tycld (L l d) ts }) [LHsDecl GhcPs]
ds
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 = L l f : ts}) [LHsDecl GhcPs]
ds
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 = add_kisig (L l s) 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 = add_sig (L l d) 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 (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 = add_bind (L l d) ts }) [LHsDecl GhcPs]
ds
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 = add_role_annot (L l d) ts }) [LHsDecl GhcPs]
ds
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 = add_instd (L l d) ts }) [LHsDecl GhcPs]
ds
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 = L l d : 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 = L l d : 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 = L l d : 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 = L l d : 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 = L l d : 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 = L l d : 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 = (L l d) : (hs_docs 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 = XCTyClGroup (GhcPass p)
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 = d : tyclds } TyClGroup (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
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 = XCTyClGroup (GhcPass p)
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 = d : instds } TyClGroup (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
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 = XCTyClGroup (GhcPass p)
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 = d : roles } TyClGroup (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
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 = XCTyClGroup (GhcPass p)
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 = d : kisigs } TyClGroup (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
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) = XValBinds a a -> LHsBindsLR a a -> [LSig a] -> HsValBindsLR a a
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds a a
x (LHsBindsLR a a
bs LHsBindsLR a a -> LHsBind a -> LHsBindsLR a a
forall a. Bag a -> a -> Bag a
`snocBag` LHsBind a
b) [LSig a]
sigs
add_bind LHsBind a
_ (XValBindsLR {}) = String -> HsValBindsLR a a
forall a. HasCallStack => 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) = XValBinds (GhcPass a) (GhcPass a)
-> LHsBindsLR (GhcPass a) (GhcPass a)
-> [LSig (GhcPass a)]
-> HsValBindsLR (GhcPass a) (GhcPass a)
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds (GhcPass a) (GhcPass a)
x LHsBindsLR (GhcPass a) (GhcPass a)
bs (LSig (GhcPass a)
GenLocated SrcSpanAnnA (Sig (GhcPass a))
sGenLocated SrcSpanAnnA (Sig (GhcPass a))
-> [GenLocated SrcSpanAnnA (Sig (GhcPass a))]
-> [GenLocated SrcSpanAnnA (Sig (GhcPass a))]
forall a. a -> [a] -> [a]
:[LSig (GhcPass a)]
[GenLocated SrcSpanAnnA (Sig (GhcPass a))]
sigs)
add_sig LSig (GhcPass a)
_ (XValBindsLR {}) = String -> HsValBindsLR (GhcPass a) (GhcPass a)
forall a. HasCallStack => String -> a
panic String
"GHC.Rename.Module.add_sig"