{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Rename.Module (
rnSrcDecls, addTcgDUs, findSplice
) where
#include "HsVersions.h"
import GHC.Prelude
import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )
import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )
import GHC.Hs
import GHC.Types.FieldLabel
import GHC.Types.Name.Reader
import GHC.Rename.HsType
import GHC.Rename.Bind
import GHC.Rename.Env
import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames
, checkDupRdrNamesN, bindLocalNamesFV
, checkShadowedRdrNames, warnUnusedTypePatterns
, newLocalBndrsRn
, withHsDocContext, noNestedForallsContextsErr
, addNoNestedForallsContextsErr, checkInferredVars )
import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr )
import GHC.Rename.Names
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 ( debugIsOn, lengthExceeds, partitionWith )
import GHC.Utils.Panic
import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses )
import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
, stronglyConnCompFromEdgedVerticesUniq )
import GHC.Types.Unique.Set
import GHC.Data.OrdList
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Control.Arrow ( first )
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe ( isNothing, fromMaybe, mapMaybe )
import qualified Data.Set as Set ( difference, fromList, toList, null )
import Data.Function ( on )
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 forall a b. (a -> b) -> a -> b
$ 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 ;
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
tc_envs forall a b. (a -> b) -> a -> b
$ do {
TcRn ()
failIfErrsM ;
DuplicateRecordFields
dup_fields_ok <- DynFlags -> DuplicateRecordFields
xopt_DuplicateRecordFields forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags ;
FieldSelectors
has_sel <- DynFlags -> FieldSelectors
xopt_FieldSelectors forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags ;
forall a.
DuplicateRecordFields
-> FieldSelectors
-> HsValBinds GhcPs
-> MiniFixityEnv
-> ([Name] -> TcRnIf TcGblEnv TcLclEnv a)
-> TcRnIf TcGblEnv TcLclEnv a
extendPatSynEnv DuplicateRecordFields
dup_fields_ok FieldSelectors
has_sel HsValBinds GhcPs
val_decls MiniFixityEnv
local_fix_env forall a b. (a -> b) -> a -> b
$ \[Name]
pat_syn_bndrs -> do {
HsValBindsLR GhcRn GhcPs
new_lhs <- MiniFixityEnv -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnTopBindsLHS MiniFixityEnv
local_fix_env HsValBinds GhcPs
val_decls ;
let { id_bndrs :: [IdP GhcRn]
id_bndrs = forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectHsIdBinders forall p. CollectFlag p
CollNoDictBinders HsValBindsLR GhcRn GhcPs
new_lhs } ;
String -> SDoc -> TcRn ()
traceRn String
"rnSrcDecls" (forall a. Outputable a => a -> SDoc
ppr [IdP GhcRn]
id_bndrs) ;
(TcGblEnv, TcLclEnv)
tc_envs <- [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn (forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail [IdP GhcRn]
id_bndrs) MiniFixityEnv
local_fix_env ;
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
tc_envs forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> TcRn ()
traceRn String
"Start rnTyClDecls" (forall a. Outputable a => a -> SDoc
ppr [TyClGroup GhcPs]
tycl_decls) ;
([TyClGroup GhcRn]
rn_tycl_decls, FreeVars
src_fvs1) <- [TyClGroup GhcPs] -> RnM ([TyClGroup GhcRn], FreeVars)
rnTyClDecls [TyClGroup GhcPs]
tycl_decls ;
String -> SDoc -> TcRn ()
traceRn String
"Start rnmono" SDoc
empty ;
let { val_bndr_set :: FreeVars
val_bndr_set = [Name] -> FreeVars
mkNameSet [IdP GhcRn]
id_bndrs FreeVars -> FreeVars -> FreeVars
`unionNameSet` [Name] -> FreeVars
mkNameSet [Name]
pat_syn_bndrs } ;
Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig ;
(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" (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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
rnSrcFixityDecl (FreeVars -> HsSigCtxt
TopSigCtxt FreeVars
all_bndrs)))
[LFixitySig GhcPs]
fix_decls ;
Warnings
rn_warns <- FreeVars -> [LWarnDecls GhcPs] -> RnM Warnings
rnSrcWarnDecls FreeVars
all_bndrs [LWarnDecls GhcPs]
warn_decls ;
([LocatedA (RuleDecls GhcRn)]
rn_rule_decls, FreeVars
src_fvs2) <- forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.ScopedTypeVariables forall a b. (a -> b) -> a -> b
$
forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
rnHsRuleDecls [LRuleDecls GhcPs]
rule_decls ;
([LocatedA (ForeignDecl GhcRn)]
rn_foreign_decls, FreeVars
src_fvs3) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
rnHsForeignDecl [LForeignDecl GhcPs]
foreign_decls ;
([LocatedA (AnnDecl GhcRn)]
rn_ann_decls, FreeVars
src_fvs4) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl [LAnnDecl GhcPs]
ann_decls ;
([LocatedA (DefaultDecl GhcRn)]
rn_default_decls, FreeVars
src_fvs5) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
rnDefaultDecl [LDefaultDecl GhcPs]
default_decls ;
([LocatedA (DerivDecl GhcRn)]
rn_deriv_decls, FreeVars
src_fvs6) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
rnSrcDerivDecl [LDerivDecl GhcPs]
deriv_decls ;
([LocatedA (SpliceDecl GhcRn)]
rn_splice_decls, FreeVars
src_fvs7) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
rnSpliceDecl [LSpliceDecl GhcPs]
splice_decls ;
TcGblEnv
last_tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv ;
let {rn_group :: HsGroup GhcRn
rn_group = HsGroup { hs_ext :: XCHsGroup GhcRn
hs_ext = NoExtField
noExtField,
hs_valds :: HsValBinds GhcRn
hs_valds = HsValBinds GhcRn
rn_val_decls,
hs_splcds :: [LSpliceDecl GhcRn]
hs_splcds = [LocatedA (SpliceDecl GhcRn)]
rn_splice_decls,
hs_tyclds :: [TyClGroup GhcRn]
hs_tyclds = [TyClGroup GhcRn]
rn_tycl_decls,
hs_derivds :: [LDerivDecl GhcRn]
hs_derivds = [LocatedA (DerivDecl GhcRn)]
rn_deriv_decls,
hs_fixds :: [LFixitySig GhcRn]
hs_fixds = [GenLocated SrcSpanAnnA (FixitySig GhcRn)]
rn_fix_decls,
hs_warnds :: [LWarnDecls GhcRn]
hs_warnds = [],
hs_fords :: [LForeignDecl GhcRn]
hs_fords = [LocatedA (ForeignDecl GhcRn)]
rn_foreign_decls,
hs_annds :: [LAnnDecl GhcRn]
hs_annds = [LocatedA (AnnDecl GhcRn)]
rn_ann_decls,
hs_defds :: [LDefaultDecl GhcRn]
hs_defds = [LocatedA (DefaultDecl GhcRn)]
rn_default_decls,
hs_ruleds :: [LRuleDecls GhcRn]
hs_ruleds = [LocatedA (RuleDecls GhcRn)]
rn_rule_decls,
hs_docs :: [LDocDecl GhcRn]
hs_docs = [LDocDecl GhcPs]
docs } ;
tcf_bndrs :: [Name]
tcf_bndrs = [TyClGroup GhcRn] -> [LForeignDecl GhcRn] -> [Name]
hsTyClForeignBinders [TyClGroup GhcRn]
rn_tycl_decls [LocatedA (ForeignDecl GhcRn)]
rn_foreign_decls ;
other_def :: (Maybe FreeVars, FreeVars)
other_def = (forall a. a -> Maybe a
Just ([Name] -> FreeVars
mkNameSet [Name]
tcf_bndrs), FreeVars
emptyNameSet) ;
other_fvs :: FreeVars
other_fvs = [FreeVars] -> FreeVars
plusFVs [FreeVars
src_fvs1, FreeVars
src_fvs2, FreeVars
src_fvs3, FreeVars
src_fvs4,
FreeVars
src_fvs5, FreeVars
src_fvs6, FreeVars
src_fvs7] ;
src_dus :: DefUses
src_dus = forall a. a -> OrdList a
unitOL (Maybe FreeVars, FreeVars)
other_def DefUses -> DefUses -> DefUses
`plusDU` DefUses
bind_dus DefUses -> DefUses -> DefUses
`plusDU` FreeVars -> DefUses
usesOnly FreeVars
other_fvs ;
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 :: Warnings
tcg_warns = TcGblEnv -> Warnings
tcg_warns TcGblEnv
tcg_env' Warnings -> Warnings -> Warnings
`plusWarns` Warnings
rn_warns };
} ;
String -> SDoc -> TcRn ()
traceRn String
"finish rnSrc" (forall a. Outputable a => a -> SDoc
ppr HsGroup GhcRn
rn_group) ;
String -> SDoc -> TcRn ()
traceRn String
"finish Dus" (forall a. Outputable a => a -> SDoc
ppr DefUses
src_dus ) ;
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
final_tcg_env, HsGroup GhcRn
rn_group)
}}}}
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
addTcgDUs TcGblEnv
tcg_env DefUses
dus = TcGblEnv
tcg_env { tcg_dus :: DefUses
tcg_dus = TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env DefUses -> DefUses -> DefUses
`plusDU` DefUses
dus }
rnList :: (a -> RnM (b, FreeVars)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList :: forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList a -> RnM (b, FreeVars)
f [LocatedA a]
xs = forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA a -> RnM (b, FreeVars)
f) [LocatedA a]
xs
rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
rnSrcWarnDecls :: FreeVars -> [LWarnDecls GhcPs] -> RnM Warnings
rnSrcWarnDecls FreeVars
_ []
= forall (m :: * -> *) a. Monad m => a -> m a
return Warnings
NoWarnings
rnSrcWarnDecls FreeVars
bndr_set [LWarnDecls GhcPs]
decls'
= do {
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ NonEmpty (GenLocated SrcSpanAnnN RdrName)
dups -> let ((L SrcSpanAnnN
loc RdrName
rdr) :| (GenLocated SrcSpanAnnN RdrName
lrdr':[GenLocated SrcSpanAnnN RdrName]
_)) = NonEmpty (GenLocated SrcSpanAnnN RdrName)
dups
in SrcSpan -> SDoc -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc) (GenLocated SrcSpanAnnN RdrName -> RdrName -> SDoc
dupWarnDecl GenLocated SrcSpanAnnN RdrName
lrdr' RdrName
rdr))
[NonEmpty (GenLocated SrcSpanAnnN RdrName)]
warn_rdr_dups
; [[(OccName, WarningTxt)]]
pairs_s <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA WarnDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
rn_deprec) [GenLocated SrcSpanAnnA (WarnDecl GhcPs)]
decls
; forall (m :: * -> *) a. Monad m => a -> m a
return ([(OccName, WarningTxt)] -> Warnings
WarnSome ((forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(OccName, WarningTxt)]]
pairs_s))) }
where
decls :: [GenLocated SrcSpanAnnA (WarnDecl GhcPs)]
decls = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall pass. WarnDecls pass -> [LWarnDecl pass]
wd_warnings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LWarnDecls GhcPs]
decls'
sig_ctxt :: HsSigCtxt
sig_ctxt = FreeVars -> HsSigCtxt
TopSigCtxt FreeVars
bndr_set
rn_deprec :: WarnDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
rn_deprec (Warning XWarning GhcPs
_ [LIdP GhcPs]
rdr_names WarningTxt
txt)
= do { [(RdrName, Name)]
names <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (HsSigCtxt
-> SDoc
-> RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)]
lookupLocalTcNames HsSigCtxt
sig_ctxt SDoc
what forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
[LIdP GhcPs]
rdr_names
; forall (m :: * -> *) a. Monad m => a -> m a
return [(RdrName -> OccName
rdrNameOcc RdrName
rdr, WarningTxt
txt) | (RdrName
rdr, Name
_) <- [(RdrName, Name)]
names] }
what :: SDoc
what = String -> SDoc
text String
"deprecation"
warn_rdr_dups :: [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
warn_rdr_dups = [GenLocated SrcSpanAnnN RdrName]
-> [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
findDupRdrNames
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(L SrcSpanAnnA
_ (Warning XWarning GhcPs
_ [LIdP GhcPs]
ns WarningTxt
_)) -> [LIdP GhcPs]
ns) [GenLocated SrcSpanAnnA (WarnDecl GhcPs)]
decls
findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)]
findDupRdrNames :: [GenLocated SrcSpanAnnN RdrName]
-> [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
findDupRdrNames = forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (\ GenLocated SrcSpanAnnN RdrName
x -> \ GenLocated SrcSpanAnnN RdrName
y -> RdrName -> OccName
rdrNameOcc (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
x) forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
y))
dupWarnDecl :: LocatedN RdrName -> RdrName -> SDoc
dupWarnDecl :: GenLocated SrcSpanAnnN RdrName -> RdrName -> SDoc
dupWarnDecl GenLocated SrcSpanAnnN RdrName
d RdrName
rdr_name
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Multiple warning declarations for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name),
String -> SDoc
text String
"also at " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnN RdrName
d)]
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl ann :: AnnDecl GhcPs
ann@(HsAnnotation XHsAnnotation GhcPs
_ SourceText
s AnnProvenance GhcPs
provenance XRec GhcPs (HsExpr GhcPs)
expr)
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (forall (p :: Pass).
OutputableBndrId p =>
AnnDecl (GhcPass p) -> SDoc
annCtxt AnnDecl GhcPs
ann) forall a b. (a -> b) -> a -> b
$
do { (AnnProvenance GhcRn
provenance', FreeVars
provenance_fvs) <- AnnProvenance GhcPs -> RnM (AnnProvenance GhcRn, FreeVars)
rnAnnProvenance AnnProvenance GhcPs
provenance
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
expr_fvs) <- forall a. ThStage -> TcM a -> TcM a
setStage (SpliceType -> ThStage
Splice SpliceType
Untyped) forall a b. (a -> b) -> a -> b
$
XRec GhcPs (HsExpr GhcPs) -> TcRn (LHsExpr GhcRn, FreeVars)
rnLExpr XRec GhcPs (HsExpr GhcPs)
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XHsAnnotation pass
-> SourceText
-> AnnProvenance pass
-> XRec pass (HsExpr pass)
-> AnnDecl pass
HsAnnotation forall a. EpAnn a
noAnn SourceText
s AnnProvenance GhcRn
provenance' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr',
FreeVars
provenance_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
expr_fvs) }
rnAnnProvenance :: AnnProvenance GhcPs
-> RnM (AnnProvenance GhcRn, FreeVars)
rnAnnProvenance :: AnnProvenance GhcPs -> RnM (AnnProvenance GhcRn, FreeVars)
rnAnnProvenance AnnProvenance GhcPs
provenance = do
AnnProvenance GhcRn
provenance' <- case AnnProvenance GhcPs
provenance of
ValueAnnProvenance LIdP GhcPs
n -> forall pass. LIdP pass -> AnnProvenance pass
ValueAnnProvenance forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
n
TypeAnnProvenance LIdP GhcPs
n -> forall pass. LIdP pass -> AnnProvenance pass
TypeAnnProvenance forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
n
AnnProvenance GhcPs
ModuleAnnProvenance -> forall (m :: * -> *) a. Monad m => a -> m a
return forall pass. AnnProvenance pass
ModuleAnnProvenance
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnProvenance GhcRn
provenance', forall b a. b -> (a -> b) -> Maybe a -> b
maybe FreeVars
emptyFVs Name -> FreeVars
unitFV (forall p. UnXRec p => AnnProvenance p -> Maybe (IdP p)
annProvenanceName_maybe AnnProvenance GhcRn
provenance'))
rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
rnDefaultDecl (DefaultDecl XCDefaultDecl GhcPs
_ [LHsType GhcPs]
tys)
= do { ([GenLocated SrcSpanAnnA (HsType GhcRn)]
tys', FreeVars
fvs) <- HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes HsDocContext
doc_str [LHsType GhcPs]
tys
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCDefaultDecl pass -> [LHsType pass] -> DefaultDecl pass
DefaultDecl NoExtField
noExtField [GenLocated SrcSpanAnnA (HsType GhcRn)]
tys', FreeVars
fvs) }
where
doc_str :: HsDocContext
doc_str = HsDocContext
DefaultDeclCtx
rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
rnHsForeignDecl (ForeignImport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = LIdP GhcPs
name, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcPs
ty, fd_fi :: forall pass. ForeignDecl pass -> ForeignImport
fd_fi = ForeignImport
spec })
= do { HscEnv
topEnv :: HscEnv <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; GenLocated SrcSpanAnnN Name
name' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
name
; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty', FreeVars
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType (GenLocated SrcSpanAnnN RdrName -> HsDocContext
ForeignDeclCtx LIdP GhcPs
name) TypeOrKind
TypeLevel LHsSigType GhcPs
ty
; let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
topEnv
spec' :: ForeignImport
spec' = Unit -> ForeignImport -> ForeignImport
patchForeignImport (HomeUnit -> Unit
homeUnitAsUnit HomeUnit
home_unit) ForeignImport
spec
; forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport { fd_i_ext :: XForeignImport GhcRn
fd_i_ext = NoExtField
noExtField
, fd_name :: LIdP GhcRn
fd_name = GenLocated SrcSpanAnnN Name
name', fd_sig_ty :: LHsSigType GhcRn
fd_sig_ty = GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty'
, fd_fi :: ForeignImport
fd_fi = ForeignImport
spec' }, FreeVars
fvs) }
rnHsForeignDecl (ForeignExport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = LIdP GhcPs
name, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcPs
ty, fd_fe :: forall pass. ForeignDecl pass -> ForeignExport
fd_fe = ForeignExport
spec })
= do { GenLocated SrcSpanAnnN Name
name' <- forall ann.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupLocatedOccRn LIdP GhcPs
name
; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty', FreeVars
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType (GenLocated SrcSpanAnnN RdrName -> HsDocContext
ForeignDeclCtx LIdP GhcPs
name) TypeOrKind
TypeLevel LHsSigType GhcPs
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignExport { fd_e_ext :: XForeignExport GhcRn
fd_e_ext = NoExtField
noExtField
, fd_name :: LIdP GhcRn
fd_name = GenLocated SrcSpanAnnN Name
name', fd_sig_ty :: LHsSigType GhcRn
fd_sig_ty = GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty'
, fd_fe :: ForeignExport
fd_fe = ForeignExport
spec }
, FreeVars
fvs FreeVars -> Name -> FreeVars
`addOneFV` forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
name') }
patchForeignImport :: Unit -> ForeignImport -> ForeignImport
patchForeignImport :: Unit -> ForeignImport -> ForeignImport
patchForeignImport Unit
unit (CImport Located CCallConv
cconv Located Safety
safety Maybe Header
fs CImportSpec
spec Located SourceText
src)
= Located CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport Located CCallConv
cconv Located Safety
safety Maybe Header
fs (Unit -> CImportSpec -> CImportSpec
patchCImportSpec Unit
unit CImportSpec
spec) Located SourceText
src
patchCImportSpec :: Unit -> CImportSpec -> CImportSpec
patchCImportSpec :: Unit -> CImportSpec -> CImportSpec
patchCImportSpec Unit
unit CImportSpec
spec
= case CImportSpec
spec of
CFunction CCallTarget
callTarget -> CCallTarget -> CImportSpec
CFunction forall a b. (a -> b) -> a -> b
$ Unit -> CCallTarget -> CCallTarget
patchCCallTarget Unit
unit CCallTarget
callTarget
CImportSpec
_ -> CImportSpec
spec
patchCCallTarget :: Unit -> CCallTarget -> CCallTarget
patchCCallTarget :: Unit -> CCallTarget -> CCallTarget
patchCCallTarget Unit
unit CCallTarget
callTarget =
case CCallTarget
callTarget of
StaticTarget SourceText
src CLabelString
label Maybe Unit
Nothing Bool
isFun
-> SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
src CLabelString
label (forall a. a -> Maybe a
Just Unit
unit) Bool
isFun
CCallTarget
_ -> CCallTarget
callTarget
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl (TyFamInstD { tfid_inst :: forall pass. InstDecl pass -> TyFamInstDecl pass
tfid_inst = TyFamInstDecl GhcPs
tfi })
= do { (TyFamInstDecl GhcRn
tfi', FreeVars
fvs) <- AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl (ClosedTyFamInfo -> AssocTyFamInfo
NonAssocTyFamEqn ClosedTyFamInfo
NotClosedTyFam) TyFamInstDecl GhcPs
tfi
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyFamInstD { tfid_ext :: XTyFamInstD GhcRn
tfid_ext = NoExtField
noExtField, tfid_inst :: TyFamInstDecl GhcRn
tfid_inst = TyFamInstDecl GhcRn
tfi' }, FreeVars
fvs) }
rnSrcInstDecl (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl GhcPs
dfi })
= do { (DataFamInstDecl GhcRn
dfi', FreeVars
fvs) <- AssocTyFamInfo
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl (ClosedTyFamInfo -> AssocTyFamInfo
NonAssocTyFamEqn ClosedTyFamInfo
NotClosedTyFam) DataFamInstDecl GhcPs
dfi
; forall (m :: * -> *) a. Monad m => a -> m a
return (DataFamInstD { dfid_ext :: XDataFamInstD GhcRn
dfid_ext = NoExtField
noExtField, dfid_inst :: DataFamInstDecl GhcRn
dfid_inst = DataFamInstDecl GhcRn
dfi' }, FreeVars
fvs) }
rnSrcInstDecl (ClsInstD { cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst = ClsInstDecl GhcPs
cid })
= do { String -> SDoc -> TcRn ()
traceRn String
"rnSrcIstDecl {" (forall a. Outputable a => a -> SDoc
ppr ClsInstDecl GhcPs
cid)
; (ClsInstDecl GhcRn
cid', FreeVars
fvs) <- ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
rnClsInstDecl ClsInstDecl GhcPs
cid
; String -> SDoc -> TcRn ()
traceRn String
"rnSrcIstDecl end }" SDoc
empty
; forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstD { cid_d_ext :: XClsInstD GhcRn
cid_d_ext = NoExtField
noExtField, cid_inst :: ClsInstDecl GhcRn
cid_inst = ClsInstDecl GhcRn
cid' }, FreeVars
fvs) }
checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> TcRn ()
checkCanonicalInstances Name
cls LHsSigType GhcRn
poly_ty LHsBinds GhcRn
mbinds = do
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNonCanonicalMonadInstances
forall a b. (a -> b) -> a -> b
$ String -> TcRn ()
checkCanonicalMonadInstances
String
"https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNonCanonicalMonoidInstances
forall a b. (a -> b) -> a -> b
$ String -> TcRn ()
checkCanonicalMonoidInstances
String
"https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"
where
checkCanonicalMonadInstances :: String -> TcRn ()
checkCanonicalMonadInstances String
refURL
| Name
cls forall a. Eq a => a -> a -> Bool
== Name
applicativeClassName =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
case HsBindLR GhcRn GhcRn
mbind of
FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Name
name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
| Name
name forall a. Eq a => a -> a -> Bool
== Name
pureAName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Name
returnMName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"pure" String
"return"
| Name
name forall a. Eq a => a -> a -> Bool
== Name
thenAName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Name
thenMName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"(*>)" String
"(>>)"
HsBindLR GhcRn GhcRn
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Name
cls forall a. Eq a => a -> a -> Bool
== Name
monadClassName =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
case HsBindLR GhcRn GhcRn
mbind of
FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Name
name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
| Name
name forall a. Eq a => a -> a -> Bool
== Name
returnMName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Name
pureAName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"return" String
"pure"
| Name
name forall a. Eq a => a -> a -> Bool
== Name
thenMName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Name
thenAName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"(>>)" String
"(*>)"
HsBindLR GhcRn GhcRn
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCanonicalMonoidInstances :: String -> TcRn ()
checkCanonicalMonoidInstances String
refURL
| Name
cls forall a. Eq a => a -> a -> Bool
== Name
semigroupClassName =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
case HsBindLR GhcRn GhcRn
mbind of
FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Name
name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
| Name
name forall a. Eq a => a -> a -> Bool
== Name
sappendName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Name
mappendName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonoidInstances String
"(<>)" String
"mappend"
HsBindLR GhcRn GhcRn
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Name
cls forall a. Eq a => a -> a -> Bool
== Name
monoidClassName =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
mbinds) forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
loc HsBindLR GhcRn GhcRn
mbind) -> forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
case HsBindLR GhcRn GhcRn
mbind of
FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Name
name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
| Name
name forall a. Eq a => a -> a -> Bool
== Name
mappendName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Name
sappendName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonoidInstances
String
"mappend" String
"(<>)"
HsBindLR GhcRn GhcRn
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 SrcSpan
_ (GRHS XCGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ [] GenLocated SrcSpanAnnA (HsExpr GhcRn)
body)] HsLocalBinds GhcRn
lbinds <- GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
grhss
, EmptyLocalBinds XEmptyLocalBinds GhcRn GhcRn
_ <- HsLocalBinds GhcRn
lbinds
, HsVar XVar GhcRn
_ LIdP GhcRn
lrhsName <- forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcRn)
body = forall a. a -> Maybe a
Just (forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
lrhsName)
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
_ = forall a. Maybe a
Nothing
addWarnNonCanonicalMethod1 :: String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL WarningFlag
flag String
lhs String
rhs =
WarnReason -> SDoc -> TcRn ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
flag) forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"Noncanonical" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (String -> SDoc
text (String
lhs forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ String
rhs)) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"definition detected"
, LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
poly_ty
, String -> SDoc
text String
"Move definition from" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (String -> SDoc
text String
rhs) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"to" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
lhs)
, String -> SDoc
text String
"See also:" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
refURL
]
addWarnNonCanonicalMethod2 :: String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL WarningFlag
flag String
lhs String
rhs =
WarnReason -> SDoc -> TcRn ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
flag) forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"Noncanonical" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (String -> SDoc
text String
lhs) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"definition detected"
, LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
poly_ty
, SDoc -> SDoc
quotes (String -> SDoc
text String
lhs) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"will eventually be removed in favour of" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (String -> SDoc
text String
rhs)
, String -> SDoc
text String
"Either remove definition for" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (String -> SDoc
text String
lhs) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"(recommended)" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"or define as" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (String -> SDoc
text (String
lhs forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ String
rhs))
, String -> SDoc
text String
"See also:" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
refURL
]
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
hs_inst_ty
= SDoc -> SDoc
inst_decl_ctxt (forall a. Outputable a => a -> SDoc
ppr (forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType GhcRn
hs_inst_ty))
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"in the instance declaration for")
Int
2 (SDoc -> SDoc
quotes SDoc
doc SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
".")
rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
rnClsInstDecl (ClsInstDecl { cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_poly_ty = LHsSigType GhcPs
inst_ty, cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds = LHsBinds GhcPs
mbinds
, cid_sigs :: forall pass. ClsInstDecl pass -> [LSig pass]
cid_sigs = [LSig GhcPs]
uprags, cid_tyfam_insts :: forall pass. ClsInstDecl pass -> [LTyFamInstDecl pass]
cid_tyfam_insts = [LTyFamInstDecl GhcPs]
ats
, cid_overlap_mode :: forall pass. ClsInstDecl pass -> Maybe (XRec pass OverlapMode)
cid_overlap_mode = Maybe (XRec GhcPs OverlapMode)
oflag
, cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_datafam_insts = [LDataFamInstDecl GhcPs]
adts })
= do { HsDocContext -> Maybe SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
ctxt Maybe SDoc
inf_err LHsSigType GhcPs
inst_ty
; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty', FreeVars
inst_fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType HsDocContext
ctxt TypeOrKind
TypeLevel LHsSigType GhcPs
inst_ty
; let ([Name]
ktv_names, Maybe (LHsContext GhcRn)
_, LHsType GhcRn
head_ty') = LHsSigType GhcRn
-> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)
splitLHsInstDeclTy GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty'
mb_nested_msg :: Maybe (SrcSpan, SDoc)
mb_nested_msg = SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc)
noNestedForallsContextsErr
(String -> SDoc
text String
"Instance head") LHsType GhcRn
head_ty'
eith_cls :: Either (SrcSpan, SDoc) Name
eith_cls = case forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
LHsType (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p)))
hsTyGetAppHead_maybe LHsType GhcRn
head_ty' of
Just (L SrcSpanAnnN
_ IdP GhcRn
cls) -> forall a b. b -> Either a b
Right IdP GhcRn
cls
Maybe (LocatedN (IdP GhcRn))
Nothing -> forall a b. a -> Either a b
Left
( forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsType GhcRn
head_ty'
, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal head of an instance declaration:"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr LHsType GhcRn
head_ty'))
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Instance heads must be of the form"
, Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"C ty_1 ... ty_n"
, String -> SDoc
text String
"where" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Char -> SDoc
char Char
'C')
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is a class"
])
)
; Name
cls <- case (Maybe (SrcSpan, SDoc)
mb_nested_msg, Either (SrcSpan, SDoc) Name
eith_cls) of
(Maybe (SrcSpan, SDoc)
Nothing, Right Name
cls) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
cls
(Just (SrcSpan, SDoc)
err1, Either (SrcSpan, SDoc) Name
_) -> (SrcSpan, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) Name
bail_out (SrcSpan, SDoc)
err1
(Maybe (SrcSpan, SDoc)
_, Left (SrcSpan, SDoc)
err2) -> (SrcSpan, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) Name
bail_out (SrcSpan, SDoc)
err2
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds', [GenLocated SrcSpanAnnA (Sig GhcRn)]
uprags', FreeVars
meth_fvs) <- Bool
-> Name
-> [Name]
-> LHsBinds GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)
rnMethodBinds Bool
False Name
cls [Name]
ktv_names LHsBinds GhcPs
mbinds [LSig GhcPs]
uprags
; Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> TcRn ()
checkCanonicalInstances Name
cls GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty' Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds'
; String -> SDoc -> TcRn ()
traceRn String
"rnSrcInstDecl" (forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty' SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [Name]
ktv_names)
; (([LocatedA (TyFamInstDecl GhcRn)]
ats', [LocatedA (DataFamInstDecl GhcRn)]
adts'), FreeVars
more_fvs)
<- forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
ktv_names forall a b. (a -> b) -> a -> b
$
do { ([LocatedA (TyFamInstDecl GhcRn)]
ats', FreeVars
at_fvs) <- forall (decl :: * -> *).
(AssocTyFamInfo -> decl GhcPs -> RnM (decl GhcRn, FreeVars))
-> Name
-> [Name]
-> [LocatedA (decl GhcPs)]
-> RnM ([LocatedA (decl GhcRn)], FreeVars)
rnATInstDecls AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl Name
cls [Name]
ktv_names [LTyFamInstDecl GhcPs]
ats
; ([LocatedA (DataFamInstDecl GhcRn)]
adts', FreeVars
adt_fvs) <- forall (decl :: * -> *).
(AssocTyFamInfo -> decl GhcPs -> RnM (decl GhcRn, FreeVars))
-> Name
-> [Name]
-> [LocatedA (decl GhcPs)]
-> RnM ([LocatedA (decl GhcRn)], FreeVars)
rnATInstDecls AssocTyFamInfo
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl Name
cls [Name]
ktv_names [LDataFamInstDecl GhcPs]
adts
; forall (m :: * -> *) a. Monad m => a -> m a
return ( ([LocatedA (TyFamInstDecl GhcRn)]
ats', [LocatedA (DataFamInstDecl GhcRn)]
adts'), FreeVars
at_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
adt_fvs) }
; let all_fvs :: FreeVars
all_fvs = FreeVars
meth_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
more_fvs
FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
inst_fvs
; forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstDecl { cid_ext :: XCClsInstDecl GhcRn
cid_ext = NoExtField
noExtField
, cid_poly_ty :: LHsSigType GhcRn
cid_poly_ty = GenLocated SrcSpanAnnA (HsSigType GhcRn)
inst_ty', cid_binds :: LHsBinds GhcRn
cid_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds'
, cid_sigs :: [LSig GhcRn]
cid_sigs = [GenLocated SrcSpanAnnA (Sig GhcRn)]
uprags', cid_tyfam_insts :: [LTyFamInstDecl GhcRn]
cid_tyfam_insts = [LocatedA (TyFamInstDecl GhcRn)]
ats'
, cid_overlap_mode :: Maybe (XRec GhcRn OverlapMode)
cid_overlap_mode = Maybe (XRec GhcPs OverlapMode)
oflag
, cid_datafam_insts :: [LDataFamInstDecl GhcRn]
cid_datafam_insts = [LocatedA (DataFamInstDecl GhcRn)]
adts' },
FreeVars
all_fvs) }
where
ctxt :: HsDocContext
ctxt = SDoc -> HsDocContext
GenericCtx forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"an instance declaration"
inf_err :: Maybe SDoc
inf_err = forall a. a -> Maybe a
Just (String -> SDoc
text String
"Inferred type variables are not allowed")
bail_out :: (SrcSpan, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) Name
bail_out (SrcSpan
l, SDoc
err_msg) = do
SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
l forall a b. (a -> b) -> a -> b
$ HsDocContext -> SDoc -> SDoc
withHsDocContext HsDocContext
ctxt SDoc
err_msg
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ OccName -> Name
mkUnboundName (CLabelString -> OccName
mkTcOccFS (String -> CLabelString
fsLit String
"<class>"))
rnFamEqn :: HsDocContext
-> AssocTyFamInfo
-> FreeKiTyVars
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn :: forall rhs rhs'.
HsDocContext
-> AssocTyFamInfo
-> [GenLocated SrcSpanAnnN RdrName]
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn HsDocContext
doc AssocTyFamInfo
atfi [GenLocated SrcSpanAnnN RdrName]
extra_kvars
(FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = LIdP GhcPs
tycon
, feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcPs
outer_bndrs
, feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_pats = HsTyPats GhcPs
pats
, feqn_fixity :: forall pass rhs. FamEqn pass rhs -> LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = rhs
payload }) HsDocContext -> rhs -> RnM (rhs', FreeVars)
rn_payload
= do { GenLocated SrcSpanAnnN Name
tycon' <- Maybe Name
-> GenLocated SrcSpanAnnN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupFamInstName Maybe Name
mb_cls LIdP GhcPs
tycon
; let all_imp_vars :: [GenLocated SrcSpanAnnN RdrName]
all_imp_vars = [GenLocated SrcSpanAnnN RdrName]
pat_kity_vars forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnN RdrName]
extra_kvars
; forall flag assoc a.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> Maybe assoc
-> [GenLocated SrcSpanAnnN RdrName]
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs HsDocContext
doc Maybe Name
mb_cls [GenLocated SrcSpanAnnN RdrName]
all_imp_vars HsOuterFamEqnTyVarBndrs GhcPs
outer_bndrs forall a b. (a -> b) -> a -> b
$ \HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs ->
do { ([HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
pats', FreeVars
pat_fvs) <- HsDocContext
-> HsTyPats GhcPs -> RnM ([LHsTypeArg GhcRn], FreeVars)
rnLHsTypeArgs (GenLocated SrcSpanAnnN RdrName -> HsDocContext
FamPatCtx LIdP GhcPs
tycon) HsTyPats GhcPs
pats
; (rhs'
payload', FreeVars
rhs_fvs) <- HsDocContext -> rhs -> RnM (rhs', FreeVars)
rn_payload HsDocContext
doc rhs
payload
; let
rn_outer_bndrs' :: HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs' = forall pass flag.
(XHsOuterImplicit pass -> XHsOuterImplicit pass)
-> HsOuterTyVarBndrs flag pass -> HsOuterTyVarBndrs flag pass
mapHsOuterImplicit (forall a b. (a -> b) -> [a] -> [b]
map (Name -> SrcSpan -> Name
`setNameLoc` SrcSpan
lhs_loc))
HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs
groups :: [NonEmpty (LocatedN RdrName)]
groups :: [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
groups = forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses forall a l. Ord a => GenLocated l a -> GenLocated l a -> Ordering
cmpLocated [GenLocated SrcSpanAnnN RdrName]
pat_kity_vars
; [Name]
nms_dups <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupOccRn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) forall a b. (a -> b) -> a -> b
$
[ GenLocated SrcSpanAnnN RdrName
tv | (GenLocated SrcSpanAnnN RdrName
tv :| (GenLocated SrcSpanAnnN RdrName
_:[GenLocated SrcSpanAnnN RdrName]
_)) <- [NonEmpty (GenLocated SrcSpanAnnN RdrName)]
groups ]
; let nms_used :: FreeVars
nms_used = FreeVars -> [Name] -> FreeVars
extendNameSetList FreeVars
rhs_fvs forall a b. (a -> b) -> a -> b
$
[Name]
nms_dups forall a. [a] -> [a] -> [a]
++ [Name]
inst_head_tvs
all_nms :: [Name]
all_nms = forall flag. HsOuterTyVarBndrs flag GhcRn -> [Name]
hsOuterTyVarNames HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs'
; [Name] -> FreeVars -> TcRn ()
warnUnusedTypePatterns [Name]
all_nms FreeVars
nms_used
; let lhs_bound_vars :: FreeVars
lhs_bound_vars = FreeVars -> [Name] -> FreeVars
extendNameSetList FreeVars
pat_fvs [Name]
all_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 = forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
improperly_scoped [Name]
inst_head_tvs
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
bad_tvs) ([Name] -> TcRn ()
badAssocRhs [Name]
bad_tvs)
; let eqn_fvs :: FreeVars
eqn_fvs = FreeVars
rhs_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
pat_fvs
all_fvs :: FreeVars
all_fvs = case AssocTyFamInfo
atfi of
NonAssocTyFamEqn ClosedTyFamInfo
ClosedTyFam
-> FreeVars
eqn_fvs
AssocTyFamInfo
_ -> FreeVars
eqn_fvs FreeVars -> Name -> FreeVars
`addOneFV` forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
tycon'
; forall (m :: * -> *) a. Monad m => a -> m a
return (FamEqn { feqn_ext :: XCFamEqn GhcRn rhs'
feqn_ext = forall a. EpAnn a
noAnn
, feqn_tycon :: LIdP GhcRn
feqn_tycon = GenLocated SrcSpanAnnN Name
tycon'
, feqn_bndrs :: HsOuterTyVarBndrs () GhcRn
feqn_bndrs = HsOuterTyVarBndrs () GhcRn
rn_outer_bndrs'
, feqn_pats :: [LHsTypeArg GhcRn]
feqn_pats = [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
pats'
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: rhs'
feqn_rhs = rhs'
payload' },
FreeVars
all_fvs) } }
where
mb_cls :: Maybe Name
mb_cls = case AssocTyFamInfo
atfi of
NonAssocTyFamEqn ClosedTyFamInfo
_ -> forall a. Maybe a
Nothing
AssocTyFamDeflt Name
cls -> forall a. a -> Maybe a
Just Name
cls
AssocTyFamInst Name
cls [Name]
_ -> forall a. a -> Maybe a
Just Name
cls
inst_head_tvs :: [Name]
inst_head_tvs = case AssocTyFamInfo
atfi of
NonAssocTyFamEqn ClosedTyFamInfo
_ -> []
AssocTyFamDeflt Name
_ -> []
AssocTyFamInst Name
_ [Name]
inst_head_tvs -> [Name]
inst_head_tvs
pat_kity_vars :: [GenLocated SrcSpanAnnN RdrName]
pat_kity_vars = HsTyPats GhcPs -> [GenLocated SrcSpanAnnN RdrName]
extractHsTyArgRdrKiTyVars HsTyPats GhcPs
pats
lhs_loc :: SrcSpan
lhs_loc = case forall a b. (a -> b) -> [a] -> [b]
map forall (pass :: Pass). LHsTypeArg (GhcPass pass) -> SrcSpan
lhsTypeArgSrcSpan HsTyPats GhcPs
pats forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA [GenLocated SrcSpanAnnN RdrName]
extra_kvars of
[] -> forall a. String -> a
panic String
"rnFamEqn.lhs_loc"
[SrcSpan
loc] -> SrcSpan
loc
(SrcSpan
loc:[SrcSpan]
locs) -> SrcSpan
loc SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` forall a. [a] -> a
last [SrcSpan]
locs
badAssocRhs :: [Name] -> RnM ()
badAssocRhs :: [Name] -> TcRn ()
badAssocRhs [Name]
ns
= SDoc -> TcRn ()
addErr (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"The RHS of an associated type declaration mentions"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"out-of-scope variable" SDoc -> SDoc -> SDoc
<> forall a. [a] -> SDoc
plural [Name]
ns
SDoc -> SDoc -> SDoc
<+> forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (SDoc -> SDoc
quotes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr) [Name]
ns)
Int
2 (String -> SDoc
text String
"All such variables must be bound on the LHS"))
rnTyFamInstDecl :: AssocTyFamInfo
-> TyFamInstDecl GhcPs
-> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl :: AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl AssocTyFamInfo
atfi (TyFamInstDecl { tfid_xtn :: forall pass. TyFamInstDecl pass -> XCTyFamInstDecl pass
tfid_xtn = XCTyFamInstDecl GhcPs
x, tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn = TyFamInstEqn GhcPs
eqn })
= do { (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
eqn', FreeVars
fvs) <- AssocTyFamInfo
-> TyFamInstEqn GhcPs -> RnM (TyFamInstEqn GhcRn, FreeVars)
rnTyFamInstEqn AssocTyFamInfo
atfi TyFamInstEqn GhcPs
eqn
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl GhcRn
tfid_xtn = XCTyFamInstDecl GhcPs
x, tfid_eqn :: TyFamInstEqn GhcRn
tfid_eqn = FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
eqn' }, FreeVars
fvs) }
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 })
= forall rhs rhs'.
HsDocContext
-> AssocTyFamInfo
-> [GenLocated SrcSpanAnnN RdrName]
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn (GenLocated SrcSpanAnnN RdrName -> HsDocContext
TySynCtx LIdP GhcPs
tycon) AssocTyFamInfo
atfi [GenLocated SrcSpanAnnN RdrName]
extra_kvs TyFamInstEqn GhcPs
eqn HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnTySyn
where
extra_kvs :: [GenLocated SrcSpanAnnN RdrName]
extra_kvs = LHsType GhcPs -> [GenLocated SrcSpanAnnN RdrName]
extractHsTyRdrTyVarsKindVars LHsType GhcPs
rhs
rnTyFamDefltDecl :: Name
-> TyFamDefltDecl GhcPs
-> RnM (TyFamDefltDecl GhcRn, FreeVars)
rnTyFamDefltDecl :: Name -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamDefltDecl Name
cls = AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl (Name -> AssocTyFamInfo
AssocTyFamDeflt Name
cls)
rnDataFamInstDecl :: AssocTyFamInfo
-> DataFamInstDecl GhcPs
-> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl :: AssocTyFamInfo
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl AssocTyFamInfo
atfi (DataFamInstDecl { dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn =
eqn :: FamEqn GhcPs (HsDataDefn GhcPs)
eqn@(FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = LIdP GhcPs
tycon
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = HsDataDefn GhcPs
rhs })})
= do { let extra_kvs :: [GenLocated SrcSpanAnnN RdrName]
extra_kvs = HsDataDefn GhcPs -> [GenLocated SrcSpanAnnN RdrName]
extractDataDefnKindVars HsDataDefn GhcPs
rhs
; (FamEqn GhcRn (HsDataDefn GhcRn)
eqn', FreeVars
fvs) <-
forall rhs rhs'.
HsDocContext
-> AssocTyFamInfo
-> [GenLocated SrcSpanAnnN RdrName]
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn (GenLocated SrcSpanAnnN RdrName -> HsDocContext
TyDataCtx LIdP GhcPs
tycon) AssocTyFamInfo
atfi [GenLocated SrcSpanAnnN RdrName]
extra_kvs FamEqn GhcPs (HsDataDefn GhcPs)
eqn HsDocContext
-> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn
; forall (m :: * -> *) a. Monad m => a -> m a
return (DataFamInstDecl { dfid_eqn :: FamEqn GhcRn (HsDataDefn GhcRn)
dfid_eqn = FamEqn GhcRn (HsDataDefn GhcRn)
eqn' }, FreeVars
fvs) }
rnATDecls :: Name
-> [LFamilyDecl GhcPs]
-> RnM ([LFamilyDecl GhcRn], FreeVars)
rnATDecls :: Name -> [LFamilyDecl GhcPs] -> RnM ([LFamilyDecl GhcRn], FreeVars)
rnATDecls Name
cls [LFamilyDecl GhcPs]
at_decls
= forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList (Maybe Name -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, FreeVars)
rnFamDecl (forall a. a -> Maybe a
Just Name
cls)) [LFamilyDecl GhcPs]
at_decls
rnATInstDecls :: (AssocTyFamInfo ->
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
= 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 <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.StandaloneDeriving
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
standalone_deriv_ok (SDoc -> TcRn ()
addErr SDoc
standaloneDerivErr)
; HsDocContext -> Maybe SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
ctxt Maybe SDoc
inf_err LHsSigType GhcPs
nowc_ty
; (Maybe (GenLocated SrcSpan (DerivStrategy GhcRn))
mds', HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
ty', FreeVars
fvs) <- forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy HsDocContext
ctxt Maybe (LDerivStrategy GhcPs)
mds forall a b. (a -> b) -> a -> b
$ HsDocContext
-> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType HsDocContext
ctxt LHsSigWcType GhcPs
ty
; HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
ctxt
(String -> SDoc
text String
"Standalone-derived instance head")
(forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead forall a b. (a -> b) -> a -> b
$ forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
ty')
; Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (GenLocated SrcSpan (DerivStrategy GhcRn))
mds' SrcSpan
loc
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCDerivDecl pass
-> LHsSigWcType pass
-> Maybe (LDerivStrategy pass)
-> Maybe (XRec pass OverlapMode)
-> DerivDecl pass
DerivDecl forall a. EpAnn a
noAnn HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
ty' Maybe (GenLocated SrcSpan (DerivStrategy GhcRn))
mds' Maybe (XRec GhcPs OverlapMode)
overlap, FreeVars
fvs) }
where
ctxt :: HsDocContext
ctxt = HsDocContext
DerivDeclCtx
inf_err :: Maybe SDoc
inf_err = forall a. a -> Maybe a
Just (String -> SDoc
text String
"Inferred type variables are not allowed")
loc :: SrcSpan
loc = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType GhcPs
nowc_ty
nowc_ty :: LHsSigType GhcPs
nowc_ty = forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType GhcPs
ty
standaloneDerivErr :: SDoc
standaloneDerivErr :: SDoc
standaloneDerivErr
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal standalone deriving declaration")
Int
2 (String -> SDoc
text String
"Use StandaloneDeriving to enable this extension")
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
rnHsRuleDecls (HsRules { rds_src :: forall pass. RuleDecls pass -> SourceText
rds_src = SourceText
src
, rds_rules :: forall pass. RuleDecls pass -> [LRuleDecl pass]
rds_rules = [LRuleDecl GhcPs]
rules })
= do { ([LocatedA (RuleDecl GhcRn)]
rn_rules,FreeVars
fvs) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl [LRuleDecl GhcPs]
rules
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsRules { rds_ext :: XCRuleDecls GhcRn
rds_ext = NoExtField
noExtField
, rds_src :: SourceText
rds_src = SourceText
src
, rds_rules :: [LRuleDecl GhcRn]
rds_rules = [LocatedA (RuleDecl GhcRn)]
rn_rules }, FreeVars
fvs) }
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl (HsRule { rd_name :: forall pass. RuleDecl pass -> XRec pass (SourceText, CLabelString)
rd_name = XRec GhcPs (SourceText, CLabelString)
rule_name
, rd_act :: forall pass. RuleDecl pass -> Activation
rd_act = Activation
act
, rd_tyvs :: forall pass.
RuleDecl pass -> Maybe [LHsTyVarBndr () (NoGhcTc pass)]
rd_tyvs = Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
tyvs
, rd_tmvs :: forall pass. RuleDecl pass -> [LRuleBndr pass]
rd_tmvs = [LRuleBndr GhcPs]
tmvs
, rd_lhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
rd_lhs = XRec GhcPs (HsExpr GhcPs)
lhs
, rd_rhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
rd_rhs = XRec GhcPs (HsExpr GhcPs)
rhs })
= do { let rdr_names_w_loc :: [GenLocated SrcSpanAnnN RdrName]
rdr_names_w_loc = forall a b. (a -> b) -> [a] -> [b]
map (RuleBndr GhcPs -> GenLocated SrcSpanAnnN RdrName
get_var forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LRuleBndr GhcPs]
tmvs
; [GenLocated SrcSpanAnnN RdrName] -> TcRn ()
checkDupRdrNamesN [GenLocated SrcSpanAnnN RdrName]
rdr_names_w_loc
; [GenLocated SrcSpanAnnN RdrName] -> TcRn ()
checkShadowedRdrNames [GenLocated SrcSpanAnnN RdrName]
rdr_names_w_loc
; [Name]
names <- [GenLocated SrcSpanAnnN RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Name]
newLocalBndrsRn [GenLocated SrcSpanAnnN RdrName]
rdr_names_w_loc
; let doc :: HsDocContext
doc = CLabelString -> HsDocContext
RuleCtx (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (SourceText, CLabelString)
rule_name)
; forall b.
HsDocContext
-> Maybe [LHsTyVarBndr () GhcPs]
-> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindRuleTyVars HsDocContext
doc Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
tyvs forall a b. (a -> b) -> a -> b
$ \ Maybe [LHsTyVarBndr () GhcRn]
tyvs' ->
forall ty_bndrs a.
HsDocContext
-> Maybe ty_bndrs
-> [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindRuleTmVars HsDocContext
doc Maybe [LHsTyVarBndr () GhcRn]
tyvs' [LRuleBndr GhcPs]
tmvs [Name]
names forall a b. (a -> b) -> a -> b
$ \ [LRuleBndr GhcRn]
tmvs' ->
do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs', FreeVars
fv_lhs') <- XRec GhcPs (HsExpr GhcPs) -> TcRn (LHsExpr GhcRn, FreeVars)
rnLExpr XRec GhcPs (HsExpr GhcPs)
lhs
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs', FreeVars
fv_rhs') <- XRec GhcPs (HsExpr GhcPs) -> TcRn (LHsExpr GhcRn, FreeVars)
rnLExpr XRec GhcPs (HsExpr GhcPs)
rhs
; CLabelString -> [Name] -> LHsExpr GhcRn -> FreeVars -> TcRn ()
checkValidRule (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (SourceText, CLabelString)
rule_name) [Name]
names GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs' FreeVars
fv_lhs'
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsRule { rd_ext :: XHsRule GhcRn
rd_ext = FreeVars -> FreeVars -> HsRuleRn
HsRuleRn FreeVars
fv_lhs' FreeVars
fv_rhs'
, rd_name :: XRec GhcRn (SourceText, CLabelString)
rd_name = XRec GhcPs (SourceText, CLabelString)
rule_name
, rd_act :: Activation
rd_act = Activation
act
, rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc GhcRn)]
rd_tyvs = Maybe [LHsTyVarBndr () GhcRn]
tyvs'
, rd_tmvs :: [LRuleBndr GhcRn]
rd_tmvs = [LRuleBndr GhcRn]
tmvs'
, rd_lhs :: LHsExpr GhcRn
rd_lhs = GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs'
, rd_rhs :: LHsExpr GhcRn
rd_rhs = GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs' }, FreeVars
fv_lhs' FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_rhs') } }
where
get_var :: RuleBndr GhcPs -> LocatedN RdrName
get_var :: RuleBndr GhcPs -> GenLocated SrcSpanAnnN RdrName
get_var (RuleBndrSig XRuleBndrSig GhcPs
_ LIdP GhcPs
v HsPatSigType GhcPs
_) = LIdP GhcPs
v
get_var (RuleBndr XCRuleBndr GhcPs
_ LIdP GhcPs
v) = LIdP GhcPs
v
bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
-> [LRuleBndr GhcPs] -> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindRuleTmVars :: forall ty_bndrs a.
HsDocContext
-> Maybe ty_bndrs
-> [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindRuleTmVars HsDocContext
doc Maybe ty_bndrs
tyvs [LRuleBndr GhcPs]
vars [Name]
names [LRuleBndr GhcRn] -> RnM (a, FreeVars)
thing_inside
= [GenLocated SrcSpan (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
go [LRuleBndr GhcPs]
vars [Name]
names forall a b. (a -> b) -> a -> b
$ \ [GenLocated SrcSpan (RuleBndr GhcRn)]
vars' ->
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
names ([LRuleBndr GhcRn] -> RnM (a, FreeVars)
thing_inside [GenLocated SrcSpan (RuleBndr GhcRn)]
vars')
where
go :: [GenLocated SrcSpan (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
go ((L SrcSpan
l (RuleBndr XCRuleBndr GhcPs
_ (L SrcSpanAnnN
loc RdrName
_))) : [GenLocated SrcSpan (RuleBndr GhcPs)]
vars) (Name
n : [Name]
ns) [GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, FreeVars)
thing_inside
= [GenLocated SrcSpan (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
go [GenLocated SrcSpan (RuleBndr GhcPs)]
vars [Name]
ns forall a b. (a -> b) -> a -> b
$ \ [GenLocated SrcSpan (RuleBndr GhcRn)]
vars' ->
[GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, FreeVars)
thing_inside (forall l e. l -> e -> GenLocated l e
L SrcSpan
l (forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass
RuleBndr forall a. EpAnn a
noAnn (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
n)) forall a. a -> [a] -> [a]
: [GenLocated SrcSpan (RuleBndr GhcRn)]
vars')
go ((L SrcSpan
l (RuleBndrSig XRuleBndrSig GhcPs
_ (L SrcSpanAnnN
loc RdrName
_) HsPatSigType GhcPs
bsig)) : [GenLocated SrcSpan (RuleBndr GhcPs)]
vars)
(Name
n : [Name]
ns) [GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, FreeVars)
thing_inside
= forall a.
HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigType HsPatSigTypeScoping
bind_free_tvs HsDocContext
doc HsPatSigType GhcPs
bsig forall a b. (a -> b) -> a -> b
$ \ HsPatSigType GhcRn
bsig' ->
[GenLocated SrcSpan (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
go [GenLocated SrcSpan (RuleBndr GhcPs)]
vars [Name]
ns forall a b. (a -> b) -> a -> b
$ \ [GenLocated SrcSpan (RuleBndr GhcRn)]
vars' ->
[GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, FreeVars)
thing_inside (forall l e. l -> e -> GenLocated l e
L SrcSpan
l (forall pass.
XRuleBndrSig pass
-> LIdP pass -> HsPatSigType pass -> RuleBndr pass
RuleBndrSig forall a. EpAnn a
noAnn (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Name
n) HsPatSigType GhcRn
bsig') forall a. a -> [a] -> [a]
: [GenLocated SrcSpan (RuleBndr GhcRn)]
vars')
go [] [] [GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, FreeVars)
thing_inside = [GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, FreeVars)
thing_inside []
go [GenLocated SrcSpan (RuleBndr GhcPs)]
vars [Name]
names [GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, FreeVars)
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"bindRuleVars" (forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan (RuleBndr GhcPs)]
vars SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [Name]
names)
bind_free_tvs :: HsPatSigTypeScoping
bind_free_tvs = case Maybe ty_bndrs
tyvs of Maybe ty_bndrs
Nothing -> HsPatSigTypeScoping
AlwaysBind
Just ty_bndrs
_ -> HsPatSigTypeScoping
NeverBind
bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs]
-> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindRuleTyVars :: forall b.
HsDocContext
-> Maybe [LHsTyVarBndr () GhcPs]
-> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindRuleTyVars HsDocContext
doc (Just [LHsTyVarBndr () GhcPs]
bndrs) Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)
thing_inside
= forall flag a b.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls forall a. Maybe a
Nothing [LHsTyVarBndr () GhcPs]
bndrs (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)
thing_inside forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)
bindRuleTyVars HsDocContext
_ Maybe [LHsTyVarBndr () GhcPs]
_ Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)
thing_inside = Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)
thing_inside forall a. Maybe a
Nothing
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just HsExpr GhcRn
bad -> forall a. SDoc -> TcM a
failWithTc (CLabelString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
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')]
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> TcRn ()
addErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLabelString -> Name -> SDoc
badRuleVar CLabelString
rule_name) [Name]
bad_vars }
validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
validRuleLhs [Name]
foralls LHsExpr GhcRn
lhs
= GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
lhs
where
checkl :: GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl = HsExpr GhcRn -> Maybe (HsExpr GhcRn)
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
check :: HsExpr GhcRn -> Maybe (HsExpr GhcRn)
check (OpApp XOpApp GhcRn
_ LHsExpr GhcRn
e1 LHsExpr GhcRn
op LHsExpr GhcRn
e2) = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
op forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall {p} {a}. p -> Maybe a
checkl_e LHsExpr GhcRn
e1
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall {p} {a}. p -> Maybe a
checkl_e LHsExpr GhcRn
e2
check (HsApp XApp GhcRn
_ LHsExpr GhcRn
e1 LHsExpr GhcRn
e2) = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
e1 forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall {p} {a}. p -> Maybe a
checkl_e LHsExpr GhcRn
e2
check (HsAppType XAppTypeE GhcRn
_ LHsExpr GhcRn
e LHsWcType (NoGhcTc GhcRn)
_) = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl LHsExpr GhcRn
e
check (HsVar XVar GhcRn
_ LIdP GhcRn
lv)
| (forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
lv) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
foralls = forall a. Maybe a
Nothing
check HsExpr GhcRn
other = forall a. a -> Maybe a
Just HsExpr GhcRn
other
checkl_e :: p -> Maybe a
checkl_e p
_ = forall a. Maybe a
Nothing
badRuleVar :: FastString -> Name -> SDoc
badRuleVar :: CLabelString -> Name -> SDoc
badRuleVar CLabelString
name Name
var
= [SDoc] -> SDoc
sep [String -> SDoc
text String
"Rule" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (CLabelString -> SDoc
ftext CLabelString
name) SDoc -> SDoc -> SDoc
<> SDoc
colon,
String -> SDoc
text String
"Forall'd variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
var) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"does not appear on left hand side"]
badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
badRuleLhsErr :: CLabelString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
badRuleLhsErr CLabelString
name LHsExpr GhcRn
lhs HsExpr GhcRn
bad_e
= [SDoc] -> SDoc
sep [String -> SDoc
text String
"Rule" SDoc -> SDoc -> SDoc
<+> CLabelString -> SDoc
pprRuleName CLabelString
name SDoc -> SDoc -> SDoc
<> SDoc
colon,
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat [SDoc
err,
String -> SDoc
text String
"in left-hand side:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
lhs])]
SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"LHS must be of form (f e1 .. en) where f is not forall'd"
where
err :: SDoc
err = case HsExpr GhcRn
bad_e of
HsUnboundVar XUnboundVar GhcRn
_ OccName
uv -> RdrName -> SDoc
notInScopeErr (OccName -> RdrName
mkRdrUnqual OccName
uv)
HsExpr GhcRn
_ -> String -> SDoc
text String
"Illegal expression:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
bad_e
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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA TyClDecl GhcPs -> RnM (TyClDecl GhcRn, FreeVars)
rnTyClDecl) (forall pass. [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls [TyClGroup GhcPs]
tycl_ds)
; let tc_names :: FreeVars
tc_names = [Name] -> FreeVars
mkNameSet (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
tycls_w_fvs)
; [(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)]
kisigs_w_fvs <- FreeVars
-> [LStandaloneKindSig GhcPs]
-> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
rnStandaloneKindSignatures FreeVars
tc_names (forall pass. [TyClGroup pass] -> [LStandaloneKindSig pass]
tyClGroupKindSigs [TyClGroup GhcPs]
tycl_ds)
; [(LocatedA (InstDecl GhcRn), FreeVars)]
instds_w_fvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl) (forall pass. [TyClGroup pass] -> [LInstDecl pass]
tyClGroupInstDecls [TyClGroup GhcPs]
tycl_ds)
; [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn)]
role_annots <- FreeVars -> [LRoleAnnotDecl GhcPs] -> RnM [LRoleAnnotDecl GhcRn]
rnRoleAnnots FreeVars
tc_names (forall pass. [TyClGroup pass] -> [LRoleAnnotDecl pass]
tyClGroupRoleDecls [TyClGroup GhcPs]
tycl_ds)
; GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; let tycl_sccs :: [SCC (LTyClDecl GhcRn)]
tycl_sccs = GlobalRdrEnv
-> KindSig_FV_Env
-> [(LTyClDecl GhcRn, FreeVars)]
-> [SCC (LTyClDecl GhcRn)]
depAnalTyClDecls GlobalRdrEnv
rdr_env KindSig_FV_Env
kisig_fv_env [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
tycls_w_fvs
role_annot_env :: RoleAnnotEnv
role_annot_env = [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv
mkRoleAnnotEnv [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn)]
role_annots
(KindSigEnv
kisig_env, KindSig_FV_Env
kisig_fv_env) = [(LStandaloneKindSig GhcRn, FreeVars)]
-> (KindSigEnv, KindSig_FV_Env)
mkKindSig_fv_env [(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)]
kisigs_w_fvs
inst_ds_map :: InstDeclFreeVarsMap
inst_ds_map = GlobalRdrEnv
-> FreeVars -> InstDeclFreeVarsMap -> InstDeclFreeVarsMap
mkInstDeclFreeVarsMap GlobalRdrEnv
rdr_env FreeVars
tc_names [(LocatedA (InstDecl GhcRn), FreeVars)]
instds_w_fvs
([LInstDecl GhcRn]
init_inst_ds, InstDeclFreeVarsMap
rest_inst_ds) = [Name]
-> InstDeclFreeVarsMap -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts [] InstDeclFreeVarsMap
inst_ds_map
first_group :: [TyClGroup GhcRn]
first_group
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LInstDecl GhcRn]
init_inst_ds = []
| Bool
otherwise = [TyClGroup { group_ext :: XCTyClGroup GhcRn
group_ext = NoExtField
noExtField
, group_tyclds :: [LTyClDecl GhcRn]
group_tyclds = []
, group_kisigs :: [LStandaloneKindSig GhcRn]
group_kisigs = []
, group_roles :: [LRoleAnnotDecl GhcRn]
group_roles = []
, group_instds :: [LInstDecl GhcRn]
group_instds = [LInstDecl GhcRn]
init_inst_ds }]
([(LocatedA (InstDecl GhcRn), FreeVars)]
final_inst_ds, [TyClGroup GhcRn]
groups)
= forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (RoleAnnotEnv
-> KindSigEnv
-> InstDeclFreeVarsMap
-> SCC (LTyClDecl GhcRn)
-> (InstDeclFreeVarsMap, TyClGroup GhcRn)
mk_group RoleAnnotEnv
role_annot_env KindSigEnv
kisig_env) InstDeclFreeVarsMap
rest_inst_ds [SCC (LTyClDecl GhcRn)]
tycl_sccs
all_fvs :: FreeVars
all_fvs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
plusFV forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) FreeVars
emptyFVs [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), FreeVars)]
tycls_w_fvs FreeVars -> FreeVars -> FreeVars
`plusFV`
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
plusFV forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) FreeVars
emptyFVs [(LocatedA (InstDecl GhcRn), FreeVars)]
instds_w_fvs FreeVars -> FreeVars -> FreeVars
`plusFV`
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
plusFV forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) FreeVars
emptyFVs [(GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn), FreeVars)]
kisigs_w_fvs
all_groups :: [TyClGroup GhcRn]
all_groups = [TyClGroup GhcRn]
first_group forall a. [a] -> [a] -> [a]
++ [TyClGroup GhcRn]
groups
; MASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map
$$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds )
; String -> SDoc -> TcRn ()
traceRn String
"rnTycl dependency analysis made groups" (forall a. Outputable a => a -> SDoc
ppr [TyClGroup GhcRn]
all_groups)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyClGroup GhcRn]
all_groups, FreeVars
all_fvs) }
where
mk_group :: RoleAnnotEnv
-> KindSigEnv
-> InstDeclFreeVarsMap
-> SCC (LTyClDecl GhcRn)
-> (InstDeclFreeVarsMap, TyClGroup GhcRn)
mk_group :: RoleAnnotEnv
-> KindSigEnv
-> InstDeclFreeVarsMap
-> SCC (LTyClDecl GhcRn)
-> (InstDeclFreeVarsMap, TyClGroup GhcRn)
mk_group RoleAnnotEnv
role_env KindSigEnv
kisig_env InstDeclFreeVarsMap
inst_map SCC (LTyClDecl GhcRn)
scc
= (InstDeclFreeVarsMap
inst_map', TyClGroup GhcRn
group)
where
tycl_ds :: [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
tycl_ds = forall vertex. SCC vertex -> [vertex]
flattenSCC SCC (LTyClDecl GhcRn)
scc
bndrs :: [Name]
bndrs = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
tycl_ds
roles :: [LRoleAnnotDecl GhcRn]
roles = [Name] -> RoleAnnotEnv -> [LRoleAnnotDecl GhcRn]
getRoleAnnots [Name]
bndrs RoleAnnotEnv
role_env
kisigs :: [LStandaloneKindSig GhcRn]
kisigs = [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
getKindSigs [Name]
bndrs KindSigEnv
kisig_env
([LInstDecl GhcRn]
inst_ds, InstDeclFreeVarsMap
inst_map') = [Name]
-> InstDeclFreeVarsMap -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts [Name]
bndrs InstDeclFreeVarsMap
inst_map
group :: TyClGroup GhcRn
group = TyClGroup { group_ext :: XCTyClGroup GhcRn
group_ext = NoExtField
noExtField
, group_tyclds :: [LTyClDecl GhcRn]
group_tyclds = [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
tycl_ds
, group_kisigs :: [LStandaloneKindSig GhcRn]
group_kisigs = [LStandaloneKindSig GhcRn]
kisigs
, group_roles :: [LRoleAnnotDecl GhcRn]
group_roles = [LRoleAnnotDecl GhcRn]
roles
, group_instds :: [LInstDecl GhcRn]
group_instds = [LInstDecl GhcRn]
inst_ds }
newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)
lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars
lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars
lookupKindSig_FV_Env (KindSig_FV_Env NameEnv FreeVars
e) Name
name
= forall a. a -> Maybe a -> a
fromMaybe FreeVars
emptyFVs (forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv FreeVars
e Name
name)
type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn)
mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env)
mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)]
-> (KindSigEnv, KindSig_FV_Env)
mkKindSig_fv_env [(LStandaloneKindSig GhcRn, FreeVars)]
kisigs_w_fvs = (NameEnv (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
kisig_env, KindSig_FV_Env
kisig_fv_env)
where
kisig_env :: NameEnv (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn))
kisig_env = forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv forall a b. (a, b) -> a
fst NameEnv (LStandaloneKindSig GhcRn, FreeVars)
compound_env
kisig_fv_env :: KindSig_FV_Env
kisig_fv_env = NameEnv FreeVars -> KindSig_FV_Env
KindSig_FV_Env (forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv forall a b. (a, b) -> b
snd NameEnv (LStandaloneKindSig GhcRn, FreeVars)
compound_env)
NameEnv (LStandaloneKindSig GhcRn, FreeVars)
compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)
= forall a. (a -> Name) -> [a] -> NameEnv a
mkNameEnvWith (forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(LStandaloneKindSig GhcRn, FreeVars)]
kisigs_w_fvs
getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
getKindSigs [Name]
bndrs KindSigEnv
kisig_env = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv KindSigEnv
kisig_env) [Name]
bndrs
rnStandaloneKindSignatures
:: NameSet
-> [LStandaloneKindSig GhcPs]
-> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
rnStandaloneKindSignatures :: FreeVars
-> [LStandaloneKindSig GhcPs]
-> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
rnStandaloneKindSignatures FreeVars
tc_names [LStandaloneKindSig GhcPs]
kisigs
= do { let ([GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)]
no_dups, [NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))]
dup_kisigs) = forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {l} {p :: Pass}.
GenLocated l (StandaloneKindSig (GhcPass p)) -> IdGhcP p
get_name) [LStandaloneKindSig GhcPs]
kisigs
get_name :: GenLocated l (StandaloneKindSig (GhcPass p)) -> IdGhcP p
get_name = forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (LStandaloneKindSig GhcPs) -> TcRn ()
dupKindSig_Err [NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))]
dup_kisigs
; forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA (FreeVars
-> StandaloneKindSig GhcPs
-> RnM (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
-> RnM (StandaloneKindSig GhcRn, FreeVars)
rnStandaloneKindSignature FreeVars
tc_names (StandaloneKindSig XStandaloneKindSig GhcPs
_ LIdP GhcPs
v LHsSigType GhcPs
ki)
= do { Bool
standalone_ki_sig_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.StandaloneKindSignatures
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
standalone_ki_sig_ok forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
addErr SDoc
standaloneKiSigErr
; GenLocated SrcSpanAnnN Name
new_v <- HsSigCtxt
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigCtxtOccRnN (FreeVars -> HsSigCtxt
TopSigCtxt FreeVars
tc_names) (String -> SDoc
text String
"standalone kind signature") LIdP GhcPs
v
; let doc :: HsDocContext
doc = SDoc -> HsDocContext
StandaloneKindSigCtx (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
v)
; (GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_ki, FreeVars
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType HsDocContext
doc TypeOrKind
KindLevel LHsSigType GhcPs
ki
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XStandaloneKindSig pass
-> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig NoExtField
noExtField GenLocated SrcSpanAnnN Name
new_v GenLocated SrcSpanAnnA (HsSigType GhcRn)
new_ki, FreeVars
fvs)
}
where
standaloneKiSigErr :: SDoc
standaloneKiSigErr :: SDoc
standaloneKiSigErr =
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal standalone kind signature")
Int
2 (String -> SDoc
text String
"Did you mean to enable StandaloneKindSignatures?")
depAnalTyClDecls :: GlobalRdrEnv
-> KindSig_FV_Env
-> [(LTyClDecl GhcRn, FreeVars)]
-> [SCC (LTyClDecl GhcRn)]
depAnalTyClDecls :: GlobalRdrEnv
-> KindSig_FV_Env
-> [(LTyClDecl GhcRn, FreeVars)]
-> [SCC (LTyClDecl GhcRn)]
depAnalTyClDecls GlobalRdrEnv
rdr_env KindSig_FV_Env
kisig_fv_env [(LTyClDecl GhcRn, FreeVars)]
ds_w_fvs
= forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Name (LTyClDecl GhcRn)]
edges
where
edges :: [ Node Name (LTyClDecl GhcRn) ]
edges :: [Node Name (LTyClDecl GhcRn)]
edges = [ forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d IdP GhcRn
name (forall a b. (a -> b) -> [a] -> [b]
map (GlobalRdrEnv -> Name -> Name
getParent GlobalRdrEnv
rdr_env) (forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet FreeVars
deps))
| (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d, FreeVars
fvs) <- [(LTyClDecl GhcRn, FreeVars)]
ds_w_fvs,
let { name :: IdP GhcRn
name = forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d)
; kisig_fvs :: FreeVars
kisig_fvs = KindSig_FV_Env -> Name -> FreeVars
lookupKindSig_FV_Env KindSig_FV_Env
kisig_fv_env IdP GhcRn
name
; deps :: FreeVars
deps = FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
kisig_fvs
}
]
toParents :: GlobalRdrEnv -> NameSet -> NameSet
toParents :: GlobalRdrEnv -> FreeVars -> FreeVars
toParents GlobalRdrEnv
rdr_env FreeVars
ns
= forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet Name -> FreeVars -> FreeVars
add FreeVars
emptyNameSet FreeVars
ns
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) = forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {l} {p :: Pass}.
GenLocated l (RoleAnnotDecl (GhcPass p)) -> IdGhcP p
get_name) [LRoleAnnotDecl GhcPs]
role_annots
get_name :: GenLocated l (RoleAnnotDecl (GhcPass p)) -> IdGhcP p
get_name = forall (p :: Pass). RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
roleAnnotDeclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (LRoleAnnotDecl GhcPs) -> TcRn ()
dupRoleAnnotErr [NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))]
dup_annots
; forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA RoleAnnotDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (RoleAnnotDecl GhcRn)
rn_role_annot1) [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)]
no_dups }
where
rn_role_annot1 :: RoleAnnotDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (RoleAnnotDecl GhcRn)
rn_role_annot1 (RoleAnnotDecl XCRoleAnnotDecl GhcPs
_ LIdP GhcPs
tycon [XRec GhcPs (Maybe Role)]
roles)
= do {
GenLocated SrcSpanAnnN Name
tycon' <- HsSigCtxt
-> SDoc
-> GenLocated SrcSpanAnnN RdrName
-> RnM (GenLocated SrcSpanAnnN Name)
lookupSigCtxtOccRnN (FreeVars -> HsSigCtxt
RoleAnnotCtxt FreeVars
tc_names)
(String -> SDoc
text String
"role annotation")
LIdP GhcPs
tycon
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall pass.
XCRoleAnnotDecl pass
-> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass
RoleAnnotDecl NoExtField
noExtField GenLocated SrcSpanAnnN Name
tycon' [XRec GhcPs (Maybe Role)]
roles }
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> TcRn ()
dupRoleAnnotErr NonEmpty (LRoleAnnotDecl GhcPs)
list
= SrcSpan -> SDoc -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Duplicate role annotations for" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall (p :: Pass). RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
roleAnnotDeclName RoleAnnotDecl GhcPs
first_decl) SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 ([SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}.
Outputable a =>
GenLocated (SrcSpanAnn' a) a -> SDoc
pp_role_annot forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
sorted_list)
where
sorted_list :: NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
sorted_list = forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy forall {a} {e}.
GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e -> Ordering
cmp_loc NonEmpty (LRoleAnnotDecl GhcPs)
list
((L SrcSpanAnnA
loc RoleAnnotDecl GhcPs
first_decl) :| [GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs)]
_) = NonEmpty (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcPs))
sorted_list
pp_role_annot :: GenLocated (SrcSpanAnn' a) a -> SDoc
pp_role_annot (L SrcSpanAnn' a
loc a
decl) = SDoc -> Int -> SDoc -> SDoc
hang (forall a. Outputable a => a -> SDoc
ppr a
decl)
Int
4 (String -> SDoc
text String
"-- written at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc))
cmp_loc :: GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e -> Ordering
cmp_loc = SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA
dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()
dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> TcRn ()
dupKindSig_Err NonEmpty (LStandaloneKindSig GhcPs)
list
= SrcSpan -> SDoc -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Duplicate standalone kind signatures for" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName StandaloneKindSig GhcPs
first_decl) SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 ([SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}.
Outputable a =>
GenLocated (SrcSpanAnn' a) a -> SDoc
pp_kisig forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
sorted_list)
where
sorted_list :: NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
sorted_list = forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy forall {a} {e}.
GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e -> Ordering
cmp_loc NonEmpty (LStandaloneKindSig GhcPs)
list
((L SrcSpanAnnA
loc StandaloneKindSig GhcPs
first_decl) :| [GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs)]
_) = NonEmpty (GenLocated SrcSpanAnnA (StandaloneKindSig GhcPs))
sorted_list
pp_kisig :: GenLocated (SrcSpanAnn' a) a -> SDoc
pp_kisig (L SrcSpanAnn' a
loc a
decl) =
SDoc -> Int -> SDoc -> SDoc
hang (forall a. Outputable a => a -> SDoc
ppr a
decl) Int
4 (String -> SDoc
text String
"-- written at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc))
cmp_loc :: GenLocated (SrcSpanAnn' a) e
-> GenLocated (SrcSpanAnn' a) e -> Ordering
cmp_loc = SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA
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
= [ (LocatedA (InstDecl GhcRn)
inst_decl, GlobalRdrEnv -> FreeVars -> FreeVars
toParents GlobalRdrEnv
rdr_env FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`intersectFVs` FreeVars
tycl_bndrs)
| (LocatedA (InstDecl GhcRn)
inst_decl, FreeVars
fvs) <- InstDeclFreeVarsMap
inst_ds_fvs ]
getInsts :: [Name] -> InstDeclFreeVarsMap
-> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts :: [Name]
-> InstDeclFreeVarsMap -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts [Name]
bndrs InstDeclFreeVarsMap
inst_decl_map
= forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (LInstDecl GhcRn, FreeVars)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
pick_me InstDeclFreeVarsMap
inst_decl_map
where
pick_me :: (LInstDecl GhcRn, FreeVars)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
pick_me :: (LInstDecl GhcRn, FreeVars)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
pick_me (LInstDecl GhcRn
decl, FreeVars
fvs)
| FreeVars -> Bool
isEmptyNameSet FreeVars
depleted_fvs = forall a b. a -> Either a b
Left LInstDecl GhcRn
decl
| Bool
otherwise = forall a b. b -> Either a b
Right (LInstDecl GhcRn
decl, FreeVars
depleted_fvs)
where
depleted_fvs :: FreeVars
depleted_fvs = [Name] -> FreeVars -> FreeVars
delFVs [Name]
bndrs FreeVars
fvs
rnTyClDecl :: TyClDecl GhcPs
-> RnM (TyClDecl GhcRn, FreeVars)
rnTyClDecl :: TyClDecl GhcPs -> RnM (TyClDecl GhcRn, FreeVars)
rnTyClDecl (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcPs
fam })
= do { (FamilyDecl GhcRn
fam', FreeVars
fvs) <- Maybe Name -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, FreeVars)
rnFamDecl forall a. Maybe a
Nothing FamilyDecl GhcPs
fam
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
noExtField FamilyDecl GhcRn
fam', FreeVars
fvs) }
rnTyClDecl (SynDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP GhcPs
tycon, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcPs
tyvars,
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdFixity = LexicalFixity
fixity, tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = LHsType GhcPs
rhs })
= do { GenLocated SrcSpanAnnN Name
tycon' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
tycon
; let kvs :: [GenLocated SrcSpanAnnN RdrName]
kvs = LHsType GhcPs -> [GenLocated SrcSpanAnnN RdrName]
extractHsTyRdrTyVarsKindVars LHsType GhcPs
rhs
doc :: HsDocContext
doc = GenLocated SrcSpanAnnN RdrName -> HsDocContext
TySynCtx LIdP GhcPs
tycon
; String -> SDoc -> TcRn ()
traceRn String
"rntycl-ty" (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
tycon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN RdrName]
kvs)
; forall a b.
HsDocContext
-> Maybe a
-> [GenLocated SrcSpanAnnN RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc forall a. Maybe a
Nothing [GenLocated SrcSpanAnnN RdrName]
kvs LHsQTyVars GhcPs
tyvars forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
_ ->
do { (GenLocated SrcSpanAnnA (HsType GhcRn)
rhs', FreeVars
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnTySyn HsDocContext
doc LHsType GhcPs
rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (SynDecl { tcdLName :: LIdP GhcRn
tcdLName = GenLocated SrcSpanAnnN Name
tycon', tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars'
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdRhs :: LHsType GhcRn
tcdRhs = GenLocated SrcSpanAnnA (HsType GhcRn)
rhs', tcdSExt :: XSynDecl GhcRn
tcdSExt = FreeVars
fvs }, FreeVars
fvs) } }
rnTyClDecl (DataDecl
{ tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP GhcPs
tycon, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcPs
tyvars,
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdFixity = LexicalFixity
fixity,
tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = defn :: HsDataDefn GhcPs
defn@HsDataDefn{ dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data
, dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsType GhcPs)
kind_sig} })
= do { GenLocated SrcSpanAnnN Name
tycon' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
tycon
; let kvs :: [GenLocated SrcSpanAnnN RdrName]
kvs = HsDataDefn GhcPs -> [GenLocated SrcSpanAnnN RdrName]
extractDataDefnKindVars HsDataDefn GhcPs
defn
doc :: HsDocContext
doc = GenLocated SrcSpanAnnN RdrName -> HsDocContext
TyDataCtx LIdP GhcPs
tycon
; String -> SDoc -> TcRn ()
traceRn String
"rntycl-data" (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
tycon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN RdrName]
kvs)
; forall a b.
HsDocContext
-> Maybe a
-> [GenLocated SrcSpanAnnN RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc forall a. Maybe a
Nothing [GenLocated SrcSpanAnnN RdrName]
kvs LHsQTyVars GhcPs
tyvars forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
no_rhs_kvs ->
do { (HsDataDefn GhcRn
defn', FreeVars
fvs) <- HsDocContext
-> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn HsDocContext
doc HsDataDefn GhcPs
defn
; Bool
cusk <- forall (p :: Pass) (p' :: Pass).
LHsQTyVars (GhcPass p)
-> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> TcRn Bool
data_decl_has_cusk LHsQTyVars GhcRn
tyvars' NewOrData
new_or_data Bool
no_rhs_kvs Maybe (LHsType GhcPs)
kind_sig
; let rn_info :: DataDeclRn
rn_info = DataDeclRn { tcdDataCusk :: Bool
tcdDataCusk = Bool
cusk
, tcdFVs :: FreeVars
tcdFVs = FreeVars
fvs }
; String -> SDoc -> TcRn ()
traceRn String
"rndata" (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
tycon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bool
cusk SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bool
no_rhs_kvs)
; forall (m :: * -> *) a. Monad m => a -> m a
return (DataDecl { tcdLName :: LIdP GhcRn
tcdLName = GenLocated SrcSpanAnnN Name
tycon'
, tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars'
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdDataDefn :: HsDataDefn GhcRn
tcdDataDefn = HsDataDefn GhcRn
defn'
, tcdDExt :: XDataDecl GhcRn
tcdDExt = DataDeclRn
rn_info }, FreeVars
fvs) } }
rnTyClDecl (ClassDecl { tcdCtxt :: forall pass. TyClDecl pass -> Maybe (LHsContext pass)
tcdCtxt = Maybe (LHsContext GhcPs)
context, tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP GhcPs
lcls,
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcPs
tyvars, tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdFixity = LexicalFixity
fixity,
tcdFDs :: forall pass. TyClDecl pass -> [LHsFunDep pass]
tcdFDs = [LHsFunDep GhcPs]
fds, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcPs]
sigs,
tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths = LHsBinds GhcPs
mbinds, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcPs]
ats, tcdATDefs :: forall pass. TyClDecl pass -> [LTyFamDefltDecl pass]
tcdATDefs = [LTyFamInstDecl GhcPs]
at_defs,
tcdDocs :: forall pass. TyClDecl pass -> [LDocDecl pass]
tcdDocs = [LDocDecl GhcPs]
docs})
= do { GenLocated SrcSpanAnnN Name
lcls' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
lcls
; let cls' :: Name
cls' = 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', [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats'), FreeVars
stuff_fvs)
<- forall a b.
HsDocContext
-> Maybe a
-> [GenLocated SrcSpanAnnN RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
cls_doc forall a. Maybe a
Nothing forall a. [a]
kvs LHsQTyVars GhcPs
tyvars forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
_ -> do
{ (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', FreeVars
cxt_fvs) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnContext HsDocContext
cls_doc Maybe (LHsContext GhcPs)
context
; [GenLocated SrcSpanAnnA (FunDep GhcRn)]
fds' <- [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds [LHsFunDep GhcPs]
fds
; ([GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats', FreeVars
fv_ats) <- Name -> [LFamilyDecl GhcPs] -> RnM ([LFamilyDecl GhcRn], FreeVars)
rnATDecls Name
cls' [LFamilyDecl GhcPs]
ats
; let fvs :: FreeVars
fvs = FreeVars
cxt_fvs FreeVars -> FreeVars -> FreeVars
`plusFV`
FreeVars
fv_ats
; forall (m :: * -> *) a. Monad m => a -> m a
return ((LHsQTyVars GhcRn
tyvars', Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', [GenLocated SrcSpanAnnA (FunDep GhcRn)]
fds', [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats'), FreeVars
fvs) }
; ([LocatedA (TyFamInstDecl GhcRn)]
at_defs', FreeVars
fv_at_defs) <- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList (Name -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamDefltDecl Name
cls') [LTyFamInstDecl GhcPs]
at_defs
; let sig_rdr_names_w_locs :: [GenLocated SrcSpanAnnN RdrName]
sig_rdr_names_w_locs =
[GenLocated SrcSpanAnnN RdrName
op | L SrcSpanAnnA
_ (ClassOpSig XClassOpSig GhcPs
_ Bool
False [LIdP GhcPs]
ops LHsSigType GhcPs
_) <- [LSig GhcPs]
sigs
, GenLocated SrcSpanAnnN RdrName
op <- [LIdP GhcPs]
ops]
; [GenLocated SrcSpanAnnN RdrName] -> TcRn ()
checkDupRdrNamesN [GenLocated SrcSpanAnnN RdrName]
sig_rdr_names_w_locs
; (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
; forall (m :: * -> *) a. Monad m => a -> m a
return (ClassDecl { tcdCtxt :: Maybe (LHsContext GhcRn)
tcdCtxt = Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', tcdLName :: LIdP GhcRn
tcdLName = GenLocated SrcSpanAnnN Name
lcls',
tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars', tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity,
tcdFDs :: [LHsFunDep GhcRn]
tcdFDs = [GenLocated SrcSpanAnnA (FunDep GhcRn)]
fds', tcdSigs :: [LSig GhcRn]
tcdSigs = [GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs',
tcdMeths :: LHsBinds GhcRn
tcdMeths = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbinds', tcdATs :: [LFamilyDecl GhcRn]
tcdATs = [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats', tcdATDefs :: [LTyFamInstDecl GhcRn]
tcdATDefs = [LocatedA (TyFamInstDecl GhcRn)]
at_defs',
tcdDocs :: [LDocDecl GhcRn]
tcdDocs = [LDocDecl GhcPs]
docs, tcdCExt :: XClassDecl GhcRn
tcdCExt = FreeVars
all_fvs },
FreeVars
all_fvs ) }
where
cls_doc :: HsDocContext
cls_doc = GenLocated SrcSpanAnnN RdrName -> HsDocContext
ClassDeclCtx LIdP GhcPs
lcls
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 <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UnliftedNewtypes
; let non_cusk_newtype :: Bool
non_cusk_newtype
| NewOrData
NewType <- NewOrData
new_or_data =
Bool
unlifted_newtypes Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe (LHsKind (GhcPass p'))
kind_sig
| Bool
otherwise = Bool
False
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: Pass). LHsQTyVars (GhcPass p) -> Bool
hsTvbAllKinded LHsQTyVars (GhcPass p)
tyvars Bool -> Bool -> Bool
&& Bool
no_rhs_kvs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
non_cusk_newtype
}
rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnTySyn HsDocContext
doc LHsType GhcPs
rhs = HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
doc LHsType GhcPs
rhs
rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
-> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn :: HsDocContext
-> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn HsDocContext
doc (HsDataDefn { dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_cType = Maybe (XRec GhcPs CType)
cType
, dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ctxt = Maybe (LHsContext GhcPs)
context, dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcPs]
condecls
, dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsType GhcPs)
m_sig, dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcPs
derivs })
= do { Bool -> SDoc -> TcRn ()
checkTc (Bool
h98_style Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcPs)
context))
(HsDocContext -> SDoc
badGadtStupidTheta HsDocContext
doc)
; (Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
m_sig', FreeVars
sig_fvs) <- case Maybe (LHsType GhcPs)
m_sig of
Just LHsType GhcPs
sig -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
doc LHsType GhcPs
sig
Maybe (LHsType GhcPs)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, FreeVars
emptyFVs)
; (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', FreeVars
fvs1) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnContext HsDocContext
doc Maybe (LHsContext GhcPs)
context
; ([GenLocated SrcSpan (HsDerivingClause GhcRn)]
derivs', FreeVars
fvs3) <- [GenLocated SrcSpan (HsDerivingClause GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpan (HsDerivingClause GhcRn)], FreeVars)
rn_derivs HsDeriving GhcPs
derivs
; let { zap_lcl_env :: RnM ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
-> RnM ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
zap_lcl_env | Bool
h98_style = \ RnM ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
thing -> RnM ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
thing
| Bool
otherwise = forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
emptyLocalRdrEnv }
; ([GenLocated SrcSpanAnnA (ConDecl GhcRn)]
condecls', FreeVars
con_fvs) <- RnM ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
-> RnM ([GenLocated SrcSpanAnnA (ConDecl GhcRn)], FreeVars)
zap_lcl_env forall a b. (a -> b) -> a -> b
$ [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
rnConDecls [LConDecl GhcPs]
condecls
; let all_fvs :: FreeVars
all_fvs = FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3 FreeVars -> FreeVars -> FreeVars
`plusFV`
FreeVars
con_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
sig_fvs
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsDataDefn { dd_ext :: XCHsDataDefn GhcRn
dd_ext = NoExtField
noExtField
, dd_ND :: NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: Maybe (XRec GhcRn CType)
dd_cType = Maybe (XRec GhcPs CType)
cType
, dd_ctxt :: Maybe (LHsContext GhcRn)
dd_ctxt = Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
context', dd_kindSig :: Maybe (LHsType GhcRn)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
m_sig'
, dd_cons :: [LConDecl GhcRn]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
condecls'
, dd_derivs :: HsDeriving GhcRn
dd_derivs = [GenLocated SrcSpan (HsDerivingClause GhcRn)]
derivs' }
, FreeVars
all_fvs )
}
where
h98_style :: Bool
h98_style = case [LConDecl GhcPs]
condecls of
(L SrcSpanAnnA
_ (ConDeclGADT {})) : [LConDecl GhcPs]
_ -> Bool
False
[LConDecl GhcPs]
_ -> Bool
True
rn_derivs :: [GenLocated SrcSpan (HsDerivingClause GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpan (HsDerivingClause GhcRn)], FreeVars)
rn_derivs [GenLocated SrcSpan (HsDerivingClause GhcPs)]
ds
= do { Bool
deriv_strats_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DerivingStrategies
; Bool -> SDoc -> TcRn ()
failIfTc (forall a. [a] -> Int -> Bool
lengthExceeds [GenLocated SrcSpan (HsDerivingClause GhcPs)]
ds Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
deriv_strats_ok)
SDoc
multipleDerivClausesErr
; ([GenLocated SrcSpan (HsDerivingClause GhcRn)]
ds', FreeVars
fvs) <- forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (HsDocContext
-> LHsDerivingClause GhcPs
-> RnM (LHsDerivingClause GhcRn, FreeVars)
rnLHsDerivingClause HsDocContext
doc) [GenLocated SrcSpan (HsDerivingClause GhcPs)]
ds
; forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated SrcSpan (HsDerivingClause GhcRn)]
ds', FreeVars
fvs) }
warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
-> SrcSpan
-> RnM ()
warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (LDerivStrategy GhcRn)
mds SrcSpan
loc
= do { DynFlags
dyn_flags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingDerivingStrategies DynFlags
dyn_flags) forall a b. (a -> b) -> a -> b
$
case Maybe (LDerivStrategy GhcRn)
mds of
Maybe (LDerivStrategy GhcRn)
Nothing -> WarnReason -> SrcSpan -> SDoc -> TcRn ()
addWarnAt
(WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingDerivingStrategies)
SrcSpan
loc
(if Extension -> DynFlags -> Bool
xopt Extension
LangExt.DerivingStrategies DynFlags
dyn_flags
then SDoc
no_strat_warning
else SDoc
no_strat_warning SDoc -> SDoc -> SDoc
$+$ SDoc
deriv_strat_nenabled
)
Maybe (LDerivStrategy GhcRn)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
}
where
no_strat_warning :: SDoc
no_strat_warning :: SDoc
no_strat_warning = String -> SDoc
text String
"No deriving strategy specified. Did you want stock"
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", newtype, or anyclass?"
deriv_strat_nenabled :: SDoc
deriv_strat_nenabled :: SDoc
deriv_strat_nenabled = String -> SDoc
text String
"Use DerivingStrategies to specify a strategy."
rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs
-> RnM (LHsDerivingClause GhcRn, FreeVars)
rnLHsDerivingClause :: HsDocContext
-> LHsDerivingClause GhcPs
-> RnM (LHsDerivingClause GhcRn, FreeVars)
rnLHsDerivingClause HsDocContext
doc
(L SrcSpan
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 SrcSpan (DerivStrategy GhcRn))
dcs', GenLocated SrcSpanAnnC (DerivClauseTys GhcRn)
dct', FreeVars
fvs)
<- forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy HsDocContext
doc Maybe (LDerivStrategy GhcPs)
dcs forall a b. (a -> b) -> a -> b
$ LDerivClauseTys GhcPs -> RnM (LDerivClauseTys GhcRn, FreeVars)
rn_deriv_clause_tys LDerivClauseTys GhcPs
dct
; Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (GenLocated SrcSpan (DerivStrategy GhcRn))
dcs' SrcSpan
loc
; forall (f :: * -> *) a. Applicative f => a -> f a
pure ( forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsDerivingClause { deriv_clause_ext :: XCHsDerivingClause GhcRn
deriv_clause_ext = XCHsDerivingClause GhcPs
noExtField
, deriv_clause_strategy :: Maybe (LDerivStrategy GhcRn)
deriv_clause_strategy = Maybe (GenLocated SrcSpan (DerivStrategy GhcRn))
dcs'
, deriv_clause_tys :: LDerivClauseTys GhcRn
deriv_clause_tys = GenLocated SrcSpanAnnC (DerivClauseTys GhcRn)
dct' })
, FreeVars
fvs ) }
where
rn_deriv_clause_tys :: LDerivClauseTys GhcPs
-> RnM (LDerivClauseTys GhcRn, FreeVars)
rn_deriv_clause_tys :: LDerivClauseTys GhcPs -> RnM (LDerivClauseTys GhcRn, FreeVars)
rn_deriv_clause_tys (L SrcSpanAnnC
l DerivClauseTys GhcPs
dct) = case DerivClauseTys GhcPs
dct of
DctSingle XDctSingle GhcPs
x LHsSigType GhcPs
ty -> do
(GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty', FreeVars
fvs) <- LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
rn_clause_pred LHsSigType GhcPs
ty
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
l (forall pass.
XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass
DctSingle XDctSingle GhcPs
x GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty'), FreeVars
fvs)
DctMulti XDctMulti GhcPs
x [LHsSigType GhcPs]
tys -> do
([GenLocated SrcSpanAnnA (HsSigType GhcRn)]
tys', FreeVars
fvs) <- forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
rn_clause_pred [LHsSigType GhcPs]
tys
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
l (forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti XDctMulti GhcPs
x [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
tys'), FreeVars
fvs)
rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
rn_clause_pred LHsSigType GhcPs
pred_ty = do
let inf_err :: Maybe SDoc
inf_err = forall a. a -> Maybe a
Just (String -> SDoc
text String
"Inferred type variables are not allowed")
HsDocContext -> Maybe SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
doc Maybe SDoc
inf_err LHsSigType GhcPs
pred_ty
ret :: (GenLocated SrcSpanAnnA (HsSigType GhcRn), FreeVars)
ret@(GenLocated SrcSpanAnnA (HsSigType GhcRn)
pred_ty', FreeVars
_) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType HsDocContext
doc TypeOrKind
TypeLevel LHsSigType GhcPs
pred_ty
HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
doc (String -> SDoc
text String
"Derived class type")
(forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead GenLocated SrcSpanAnnA (HsSigType GhcRn)
pred_ty')
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsSigType GhcRn), FreeVars)
ret
rnLDerivStrategy :: forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy :: forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy HsDocContext
doc Maybe (LDerivStrategy GhcPs)
mds RnM (a, FreeVars)
thing_inside
= case Maybe (LDerivStrategy GhcPs)
mds of
Maybe (LDerivStrategy GhcPs)
Nothing -> forall ds. ds -> RnM (ds, a, FreeVars)
boring_case forall a. Maybe a
Nothing
Just (L SrcSpan
loc DerivStrategy GhcPs
ds) ->
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ do
(DerivStrategy GhcRn
ds', a
thing, FreeVars
fvs) <- DerivStrategy GhcPs -> RnM (DerivStrategy GhcRn, a, FreeVars)
rn_deriv_strat DerivStrategy GhcPs
ds
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L SrcSpan
loc DerivStrategy GhcRn
ds'), a
thing, FreeVars
fvs)
where
rn_deriv_strat :: DerivStrategy GhcPs
-> RnM (DerivStrategy GhcRn, a, FreeVars)
rn_deriv_strat :: DerivStrategy GhcPs -> RnM (DerivStrategy GhcRn, a, FreeVars)
rn_deriv_strat DerivStrategy GhcPs
ds = do
let extNeeded :: LangExt.Extension
extNeeded :: Extension
extNeeded
| ViaStrategy{} <- DerivStrategy GhcPs
ds
= Extension
LangExt.DerivingVia
| Bool
otherwise
= Extension
LangExt.DerivingStrategies
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
extNeeded forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a
failWith forall a b. (a -> b) -> a -> b
$ DerivStrategy GhcPs -> SDoc
illegalDerivStrategyErr DerivStrategy GhcPs
ds
case DerivStrategy GhcPs
ds of
StockStrategy XStockStrategy GhcPs
_ -> forall ds. ds -> RnM (ds, a, FreeVars)
boring_case (forall pass. XStockStrategy pass -> DerivStrategy pass
StockStrategy NoExtField
noExtField)
AnyclassStrategy XAnyClassStrategy GhcPs
_ -> forall ds. ds -> RnM (ds, a, FreeVars)
boring_case (forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy NoExtField
noExtField)
NewtypeStrategy XNewtypeStrategy GhcPs
_ -> forall ds. ds -> RnM (ds, a, FreeVars)
boring_case (forall pass. XNewtypeStrategy pass -> DerivStrategy pass
NewtypeStrategy NoExtField
noExtField)
ViaStrategy (XViaStrategyPs EpAnn [AddEpAnn]
_ LHsSigType GhcPs
via_ty) ->
do HsDocContext -> Maybe SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
doc Maybe SDoc
inf_err LHsSigType GhcPs
via_ty
(GenLocated SrcSpanAnnA (HsSigType GhcRn)
via_ty', FreeVars
fvs1) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
rnHsSigType HsDocContext
doc TypeOrKind
TypeLevel LHsSigType GhcPs
via_ty
let HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterTyVarBndrs Specificity GhcRn
via_outer_bndrs
, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
via_body } = forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsSigType GhcRn)
via_ty'
via_tvs :: [Name]
via_tvs = forall flag. HsOuterTyVarBndrs flag GhcRn -> [Name]
hsOuterTyVarNames HsOuterTyVarBndrs Specificity GhcRn
via_outer_bndrs
HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
doc
(SDoc -> SDoc
quotes (String -> SDoc
text String
"via") SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"type") LHsType GhcRn
via_body
(a
thing, FreeVars
fvs2) <- forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
via_tvs RnM (a, FreeVars)
thing_inside
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy GenLocated SrcSpanAnnA (HsSigType GhcRn)
via_ty', a
thing, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2)
inf_err :: Maybe SDoc
inf_err = forall a. a -> Maybe a
Just (String -> SDoc
text String
"Inferred type variables are not allowed")
boring_case :: ds -> RnM (ds, a, FreeVars)
boring_case :: forall ds. ds -> RnM (ds, a, FreeVars)
boring_case ds
ds = do
(a
thing, FreeVars
fvs) <- RnM (a, FreeVars)
thing_inside
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ds
ds, a
thing, FreeVars
fvs)
badGadtStupidTheta :: HsDocContext -> SDoc
badGadtStupidTheta :: HsDocContext -> SDoc
badGadtStupidTheta HsDocContext
_
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"No context is allowed on a GADT-style data declaration",
String -> SDoc
text String
"(You can put a context on each constructor, though.)"]
illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc
illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc
illegalDerivStrategyErr DerivStrategy GhcPs
ds
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal deriving strategy" SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> forall a. DerivStrategy a -> SDoc
derivStrategyName DerivStrategy GhcPs
ds
, String -> SDoc
text String
enableStrategy ]
where
enableStrategy :: String
enableStrategy :: String
enableStrategy
| ViaStrategy{} <- DerivStrategy GhcPs
ds
= String
"Use DerivingVia to enable this extension"
| Bool
otherwise
= String
"Use DerivingStrategies to enable this extension"
multipleDerivClausesErr :: SDoc
multipleDerivClausesErr :: SDoc
multipleDerivClausesErr
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal use of multiple, consecutive deriving clauses"
, String -> SDoc
text String
"Use DerivingStrategies to allow this" ]
rnFamDecl :: Maybe Name
-> FamilyDecl GhcPs
-> RnM (FamilyDecl GhcRn, FreeVars)
rnFamDecl :: Maybe Name -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, FreeVars)
rnFamDecl Maybe Name
mb_cls (FamilyDecl { fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = LIdP GhcPs
tycon, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcPs
tyvars
, fdTopLevel :: forall pass. FamilyDecl pass -> TopLevelFlag
fdTopLevel = TopLevelFlag
toplevel
, fdFixity :: forall pass. FamilyDecl pass -> LexicalFixity
fdFixity = LexicalFixity
fixity
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcPs
info, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = LFamilyResultSig GhcPs
res_sig
, fdInjectivityAnn :: forall pass. FamilyDecl pass -> Maybe (LInjectivityAnn pass)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcPs)
injectivity })
= do { GenLocated SrcSpanAnnN Name
tycon' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
tycon
; ((LHsQTyVars GhcRn
tyvars', Located (FamilyResultSig GhcRn)
res_sig', Maybe (GenLocated SrcSpan (InjectivityAnn GhcRn))
injectivity'), FreeVars
fv1) <-
forall a b.
HsDocContext
-> Maybe a
-> [GenLocated SrcSpanAnnN RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc Maybe Name
mb_cls [GenLocated SrcSpanAnnN RdrName]
kvs LHsQTyVars GhcPs
tyvars forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
_ ->
do { let rn_sig :: FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, FreeVars)
rn_sig = HsDocContext
-> FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, FreeVars)
rnFamResultSig HsDocContext
doc
; (Located (FamilyResultSig GhcRn)
res_sig', FreeVars
fv_kind) <- forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, FreeVars)
rn_sig LFamilyResultSig GhcPs
res_sig
; Maybe (GenLocated SrcSpan (InjectivityAnn GhcRn))
injectivity' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (LHsQTyVars GhcRn
-> LFamilyResultSig GhcRn
-> LInjectivityAnn GhcPs
-> RnM (LInjectivityAnn GhcRn)
rnInjectivityAnn LHsQTyVars GhcRn
tyvars' Located (FamilyResultSig GhcRn)
res_sig')
Maybe (LInjectivityAnn GhcPs)
injectivity
; forall (m :: * -> *) a. Monad m => a -> m a
return ( (LHsQTyVars GhcRn
tyvars', Located (FamilyResultSig GhcRn)
res_sig', Maybe (GenLocated SrcSpan (InjectivityAnn GhcRn))
injectivity') , FreeVars
fv_kind ) }
; (FamilyInfo GhcRn
info', FreeVars
fv2) <- FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
rn_info FamilyInfo GhcPs
info
; forall (m :: * -> *) a. Monad m => a -> m a
return (FamilyDecl { fdExt :: XCFamilyDecl GhcRn
fdExt = forall a. EpAnn a
noAnn
, fdLName :: LIdP GhcRn
fdLName = GenLocated SrcSpanAnnN Name
tycon', fdTyVars :: LHsQTyVars GhcRn
fdTyVars = LHsQTyVars GhcRn
tyvars'
, fdTopLevel :: TopLevelFlag
fdTopLevel = TopLevelFlag
toplevel
, fdFixity :: LexicalFixity
fdFixity = LexicalFixity
fixity
, fdInfo :: FamilyInfo GhcRn
fdInfo = FamilyInfo GhcRn
info', fdResultSig :: LFamilyResultSig GhcRn
fdResultSig = Located (FamilyResultSig GhcRn)
res_sig'
, fdInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
fdInjectivityAnn = Maybe (GenLocated SrcSpan (InjectivityAnn GhcRn))
injectivity' }
, FreeVars
fv1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv2) }
where
doc :: HsDocContext
doc = GenLocated SrcSpanAnnN RdrName -> HsDocContext
TyFamilyCtx LIdP GhcPs
tycon
kvs :: [GenLocated SrcSpanAnnN RdrName]
kvs = LFamilyResultSig GhcPs -> [GenLocated SrcSpanAnnN RdrName]
extractRdrKindSigVars LFamilyResultSig GhcPs
res_sig
rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
rn_info (ClosedTypeFamily (Just [LTyFamInstEqn GhcPs]
eqns))
= do { ([LocatedA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
eqns', FreeVars
fvs)
<- forall a b.
(a -> RnM (b, FreeVars))
-> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
rnList (AssocTyFamInfo
-> TyFamInstEqn GhcPs -> RnM (TyFamInstEqn GhcRn, FreeVars)
rnTyFamInstEqn (ClosedTyFamInfo -> AssocTyFamInfo
NonAssocTyFamEqn ClosedTyFamInfo
ClosedTyFam)) [LTyFamInstEqn GhcPs]
eqns
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily (forall a. a -> Maybe a
Just [LocatedA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
eqns'), FreeVars
fvs) }
rn_info (ClosedTypeFamily Maybe [LTyFamInstEqn GhcPs]
Nothing)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily forall a. Maybe a
Nothing, FreeVars
emptyFVs)
rn_info FamilyInfo GhcPs
OpenTypeFamily = forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. FamilyInfo pass
OpenTypeFamily, FreeVars
emptyFVs)
rn_info FamilyInfo GhcPs
DataFamily = forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. FamilyInfo pass
DataFamily, FreeVars
emptyFVs)
rnFamResultSig :: HsDocContext
-> FamilyResultSig GhcPs
-> RnM (FamilyResultSig GhcRn, FreeVars)
rnFamResultSig :: HsDocContext
-> FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, FreeVars)
rnFamResultSig HsDocContext
_ (NoSig XNoSig GhcPs
_)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. XNoSig pass -> FamilyResultSig pass
NoSig NoExtField
noExtField, FreeVars
emptyFVs)
rnFamResultSig HsDocContext
doc (KindSig XCKindSig GhcPs
_ LHsType GhcPs
kind)
= do { (GenLocated SrcSpanAnnA (HsType GhcRn)
rndKind, FreeVars
ftvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
doc LHsType GhcPs
kind
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
KindSig NoExtField
noExtField GenLocated SrcSpanAnnA (HsType GhcRn)
rndKind, FreeVars
ftvs) }
rnFamResultSig HsDocContext
doc (TyVarSig XTyVarSig GhcPs
_ LHsTyVarBndr () GhcPs
tvbndr)
= do {
LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
; let resName :: IdP GhcPs
resName = forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcPs
tvbndr
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IdP GhcPs
resName RdrName -> LocalRdrEnv -> Bool
`elemLocalRdrEnv` LocalRdrEnv
rdr_env) forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> TcRn ()
addErrAt (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsTyVarBndr () GhcPs
tvbndr) forall a b. (a -> b) -> a -> b
$
([SDoc] -> SDoc
hsep [ String -> SDoc
text String
"Type variable", SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr IdP GhcPs
resName) SDoc -> SDoc -> SDoc
<> SDoc
comma
, String -> SDoc
text String
"naming a type family result,"
] SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"shadows an already bound type variable")
; forall a flag b.
HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr HsDocContext
doc forall a. Maybe a
Nothing
LHsTyVarBndr () GhcPs
tvbndr forall a b. (a -> b) -> a -> b
$ \ LHsTyVarBndr () GhcRn
tvbndr' ->
forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XTyVarSig pass -> LHsTyVarBndr () pass -> FamilyResultSig pass
TyVarSig NoExtField
noExtField LHsTyVarBndr () GhcRn
tvbndr', Name -> FreeVars
unitFV (forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
tvbndr')) }
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 SrcSpan
_ (TyVarSig XTyVarSig GhcRn
_ LHsTyVarBndr () GhcRn
resTv))
(L SrcSpan
srcSpan (InjectivityAnn XCInjectivityAnn GhcPs
x LIdP GhcPs
injFrom [LIdP GhcPs]
injTo))
= do
{ (injDecl' :: GenLocated SrcSpan (InjectivityAnn GhcRn)
injDecl'@(L SrcSpan
_ (InjectivityAnn XCInjectivityAnn GhcRn
_ LIdP GhcRn
injFrom' [LIdP GhcRn]
injTo')), Bool
noRnErrors)
<- forall a. TcRn a -> TcRn (a, Bool)
askNoErrs forall a b. (a -> b) -> a -> b
$
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
resTv] forall a b. (a -> b) -> a -> b
$
do { GenLocated SrcSpanAnnN Name
injFrom' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnLTyVar LIdP GhcPs
injFrom
; [GenLocated SrcSpanAnnN Name]
injTo' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnLTyVar [LIdP GhcPs]
injTo
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpan
srcSpan (forall pass.
XCInjectivityAnn pass
-> LIdP pass -> [LIdP pass] -> InjectivityAnn pass
InjectivityAnn XCInjectivityAnn GhcPs
x GenLocated SrcSpanAnnN Name
injFrom' [GenLocated SrcSpanAnnN Name]
injTo') }
; let tvNames :: Set Name
tvNames = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ LHsQTyVars GhcRn -> [Name]
hsAllLTyVarNames LHsQTyVars GhcRn
tvBndrs
resName :: IdP GhcRn
resName = forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
resTv
lhsValid :: Bool
lhsValid = Ordering
EQ forall a. Eq a => a -> a -> Bool
== (Name -> Name -> Ordering
stableNameCmp IdP GhcRn
resName (forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
injFrom'))
rhsValid :: Set Name
rhsValid = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
injTo') forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Name
tvNames
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
noRnErrors Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
lhsValid) forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> TcRn ()
addErrAt (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LIdP GhcPs
injFrom)
( [SDoc] -> SDoc
vcat [ String -> SDoc
text forall a b. (a -> b) -> a -> b
$ String
"Incorrect type variable on the LHS of "
forall a. [a] -> [a] -> [a]
++ String
"injectivity condition"
, Int -> SDoc -> SDoc
nest Int
5
( [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Expected :" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr IdP GhcRn
resName
, String -> SDoc
text String
"Actual :" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
injFrom ])])
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
noRnErrors Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set Name
rhsValid)) forall a b. (a -> b) -> a -> b
$
do { let errorVars :: [Name]
errorVars = forall a. Set a -> [a]
Set.toList Set Name
rhsValid
; SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ ( [SDoc] -> SDoc
hsep
[ String -> SDoc
text String
"Unknown type variable" SDoc -> SDoc -> SDoc
<> forall a. [a] -> SDoc
plural [Name]
errorVars
, String -> SDoc
text String
"on the RHS of injectivity condition:"
, forall a. Outputable a => [a] -> SDoc
interpp'SP [Name]
errorVars ] ) }
; forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpan (InjectivityAnn GhcRn)
injDecl' }
rnInjectivityAnn LHsQTyVars GhcRn
_ LFamilyResultSig GhcRn
_ (L SrcSpan
srcSpan (InjectivityAnn XCInjectivityAnn GhcPs
x LIdP GhcPs
injFrom [LIdP GhcPs]
injTo)) =
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ do
(GenLocated SrcSpan (InjectivityAnn GhcRn)
injDecl', Bool
_) <- forall a. TcRn a -> TcRn (a, Bool)
askNoErrs forall a b. (a -> b) -> a -> b
$ do
GenLocated SrcSpanAnnN Name
injFrom' <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnLTyVar LIdP GhcPs
injFrom
[GenLocated SrcSpanAnnN Name]
injTo' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnLTyVar [LIdP GhcPs]
injTo
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpan
srcSpan (forall pass.
XCInjectivityAnn pass
-> LIdP pass -> [LIdP pass] -> InjectivityAnn pass
InjectivityAnn XCInjectivityAnn GhcPs
x GenLocated SrcSpanAnnN Name
injFrom' [GenLocated SrcSpanAnnN Name]
injTo')
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan (InjectivityAnn GhcRn)
injDecl'
rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
rnConDecls = forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl)
rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl decl :: ConDecl GhcPs
decl@(ConDeclH98 { con_name :: forall pass. ConDecl pass -> LIdP pass
con_name = LIdP GhcPs
name, con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs = [LHsTyVarBndr Specificity GhcPs]
ex_tvs
, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcPs)
mcxt, con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = HsConDeclH98Details GhcPs
args
, con_doc :: forall pass. ConDecl pass -> Maybe LHsDocString
con_doc = Maybe LHsDocString
mb_doc, con_forall :: forall pass. ConDecl pass -> Bool
con_forall = Bool
forall })
= do { ()
_ <- forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA RdrName -> TcRn ()
checkConName LIdP GhcPs
name
; GenLocated SrcSpanAnnN Name
new_name <- GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN LIdP GhcPs
name
; let ctxt :: HsDocContext
ctxt = [GenLocated SrcSpanAnnN Name] -> HsDocContext
ConDeclCtx [GenLocated SrcSpanAnnN Name
new_name]
; forall flag a b.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
ctxt WarnUnusedForalls
WarnUnusedForalls
forall a. Maybe a
Nothing [LHsTyVarBndr Specificity GhcPs]
ex_tvs forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr Specificity GhcRn]
new_ex_tvs ->
do { (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
new_context, FreeVars
fvs1) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMbContext HsDocContext
ctxt Maybe (LHsContext GhcPs)
mcxt
; (HsConDetails
Void
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
new_args, FreeVars
fvs2) <- Name
-> HsDocContext
-> HsConDeclH98Details GhcPs
-> RnM (HsConDeclH98Details GhcRn, FreeVars)
rnConDeclH98Details (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
new_name) HsDocContext
ctxt HsConDeclH98Details GhcPs
args
; let all_fvs :: FreeVars
all_fvs = FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2
; String -> SDoc -> TcRn ()
traceRn String
"rnConDecl (ConDeclH98)" (forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
name SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"ex_tvs:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr Specificity GhcPs]
ex_tvs
, String -> SDoc
text String
"new_ex_dqtvs':" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr Specificity GhcRn]
new_ex_tvs ])
; forall (m :: * -> *) a. Monad m => a -> m a
return (ConDecl GhcPs
decl { con_ext :: XConDeclH98 GhcRn
con_ext = forall a. EpAnn a
noAnn
, con_name :: LIdP GhcRn
con_name = GenLocated SrcSpanAnnN Name
new_name, con_ex_tvs :: [LHsTyVarBndr Specificity GhcRn]
con_ex_tvs = [LHsTyVarBndr Specificity GhcRn]
new_ex_tvs
, con_mb_cxt :: Maybe (LHsContext GhcRn)
con_mb_cxt = Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
new_context, con_args :: HsConDeclH98Details GhcRn
con_args = HsConDetails
Void
(HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
new_args
, con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
mb_doc
, con_forall :: Bool
con_forall = Bool
forall },
FreeVars
all_fvs) }}
rnConDecl (ConDeclGADT { con_names :: forall pass. ConDecl pass -> [LIdP pass]
con_names = [LIdP GhcPs]
names
, con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs = L SrcSpanAnnA
l HsOuterTyVarBndrs Specificity 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 LHsDocString
con_doc = Maybe LHsDocString
mb_doc })
= do { forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA RdrName -> TcRn ()
checkConName) [LIdP GhcPs]
names
; [GenLocated SrcSpanAnnN Name]
new_names <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
lookupLocatedTopBndrRnN [LIdP GhcPs]
names
; let
implicit_bndrs :: [GenLocated SrcSpanAnnN RdrName]
implicit_bndrs =
forall flag.
HsOuterTyVarBndrs flag GhcPs
-> [GenLocated SrcSpanAnnN RdrName]
-> [GenLocated SrcSpanAnnN RdrName]
extractHsOuterTvBndrs HsOuterTyVarBndrs Specificity GhcPs
outer_bndrs forall a b. (a -> b) -> a -> b
$
[LHsType GhcPs]
-> [GenLocated SrcSpanAnnN RdrName]
-> [GenLocated SrcSpanAnnN RdrName]
extractHsTysRdrTyVars (forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
hsConDeclTheta Maybe (LHsContext GhcPs)
mcxt) forall a b. (a -> b) -> a -> b
$
HsConDeclGADTDetails GhcPs
-> [GenLocated SrcSpanAnnN RdrName]
-> [GenLocated SrcSpanAnnN RdrName]
extractConDeclGADTDetailsTyVars HsConDeclGADTDetails GhcPs
args forall a b. (a -> b) -> a -> b
$
[LHsType GhcPs]
-> [GenLocated SrcSpanAnnN RdrName]
-> [GenLocated SrcSpanAnnN RdrName]
extractHsTysRdrTyVars [LHsType GhcPs
res_ty] []
; let ctxt :: HsDocContext
ctxt = [GenLocated SrcSpanAnnN Name] -> HsDocContext
ConDeclCtx [GenLocated SrcSpanAnnN Name]
new_names
; forall flag assoc a.
OutputableBndrFlag flag 'Renamed =>
HsDocContext
-> Maybe assoc
-> [GenLocated SrcSpanAnnN RdrName]
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsOuterTyVarBndrs HsDocContext
ctxt forall a. Maybe a
Nothing [GenLocated SrcSpanAnnN RdrName]
implicit_bndrs HsOuterTyVarBndrs Specificity GhcPs
outer_bndrs forall a b. (a -> b) -> a -> b
$ \HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs' ->
do { (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
new_cxt, FreeVars
fvs1) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMbContext HsDocContext
ctxt Maybe (LHsContext GhcPs)
mcxt
; (HsConDeclGADTDetails GhcRn
new_args, FreeVars
fvs2) <- Name
-> HsDocContext
-> HsConDeclGADTDetails GhcPs
-> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
rnConDeclGADTDetails (forall l e. GenLocated l e -> e
unLoc (forall a. [a] -> a
head [GenLocated SrcSpanAnnN Name]
new_names)) HsDocContext
ctxt HsConDeclGADTDetails GhcPs
args
; (GenLocated SrcSpanAnnA (HsType GhcRn)
new_res_ty, FreeVars
fvs3) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
ctxt LHsType GhcPs
res_ty
; HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
ctxt
(String -> SDoc
text String
"GADT constructor type signature") GenLocated SrcSpanAnnA (HsType GhcRn)
new_res_ty
; let all_fvs :: FreeVars
all_fvs = FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3
; String -> SDoc -> TcRn ()
traceRn String
"rnConDecl (ConDeclGADT)"
(forall a. Outputable a => a -> SDoc
ppr [LIdP GhcPs]
names SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs')
; forall (m :: * -> *) a. Monad m => a -> m a
return (ConDeclGADT { con_g_ext :: XConDeclGADT GhcRn
con_g_ext = forall a. EpAnn a
noAnn, con_names :: [LIdP GhcRn]
con_names = [GenLocated SrcSpanAnnN Name]
new_names
, con_bndrs :: XRec GhcRn (HsOuterTyVarBndrs Specificity GhcRn)
con_bndrs = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs', con_mb_cxt :: Maybe (LHsContext GhcRn)
con_mb_cxt = Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
new_cxt
, con_g_args :: HsConDeclGADTDetails GhcRn
con_g_args = HsConDeclGADTDetails GhcRn
new_args, con_res_ty :: LHsType GhcRn
con_res_ty = GenLocated SrcSpanAnnA (HsType GhcRn)
new_res_ty
, con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
mb_doc },
FreeVars
all_fvs) } }
rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMbContext :: HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMbContext HsDocContext
_ Maybe (LHsContext GhcPs)
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, FreeVars
emptyFVs)
rnMbContext HsDocContext
doc Maybe (LHsContext GhcPs)
cxt = do { (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
ctx',FreeVars
fvs) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnContext HsDocContext
doc Maybe (LHsContext GhcPs)
cxt
; forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
ctx',FreeVars
fvs) }
rnConDeclH98Details ::
Name
-> HsDocContext
-> HsConDeclH98Details GhcPs
-> RnM (HsConDeclH98Details GhcRn, FreeVars)
rnConDeclH98Details :: Name
-> HsDocContext
-> HsConDeclH98Details GhcPs
-> RnM (HsConDeclH98Details GhcRn, FreeVars)
rnConDeclH98Details Name
_ HsDocContext
doc (PrefixCon [Void]
_ [HsScaled GhcPs (LHsType GhcPs)]
tys)
= do { ([HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
new_tys, FreeVars
fvs) <- forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc) [HsScaled GhcPs (LHsType GhcPs)]
tys
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [Void]
noTypeArgs [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
new_tys, FreeVars
fvs) }
rnConDeclH98Details Name
_ HsDocContext
doc (InfixCon HsScaled GhcPs (LHsType GhcPs)
ty1 HsScaled GhcPs (LHsType GhcPs)
ty2)
= do { (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
new_ty1, FreeVars
fvs1) <- HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc HsScaled GhcPs (LHsType GhcPs)
ty1
; (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
new_ty2, FreeVars
fvs2) <- HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc HsScaled GhcPs (LHsType GhcPs)
ty2
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
new_ty1 HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
new_ty2, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }
rnConDeclH98Details Name
con HsDocContext
doc (RecCon XRec GhcPs [LConDeclField GhcPs]
flds)
= do { (GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_flds, FreeVars
fvs) <- Name
-> HsDocContext
-> LocatedL [LConDeclField GhcPs]
-> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields Name
con HsDocContext
doc XRec GhcPs [LConDeclField GhcPs]
flds
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_flds, FreeVars
fvs) }
rnConDeclGADTDetails ::
Name
-> HsDocContext
-> HsConDeclGADTDetails GhcPs
-> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
rnConDeclGADTDetails :: Name
-> HsDocContext
-> HsConDeclGADTDetails GhcPs
-> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
rnConDeclGADTDetails Name
_ HsDocContext
doc (PrefixConGADT [HsScaled GhcPs (LHsType GhcPs)]
tys)
= do { ([HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
new_tys, FreeVars
fvs) <- forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc) [HsScaled GhcPs (LHsType GhcPs)]
tys
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
new_tys, FreeVars
fvs) }
rnConDeclGADTDetails Name
con HsDocContext
doc (RecConGADT XRec GhcPs [LConDeclField GhcPs]
flds)
= do { (GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_flds, FreeVars
fvs) <- Name
-> HsDocContext
-> LocatedL [LConDeclField GhcPs]
-> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields Name
con HsDocContext
doc XRec GhcPs [LConDeclField GhcPs]
flds
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass
RecConGADT GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_flds, FreeVars
fvs) }
rnRecConDeclFields ::
Name
-> HsDocContext
-> LocatedL [LConDeclField GhcPs]
-> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields :: Name
-> HsDocContext
-> LocatedL [LConDeclField GhcPs]
-> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields Name
con HsDocContext
doc (L SrcSpanAnnL
l [LConDeclField GhcPs]
fields)
= do { [FieldLabel]
fls <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
con
; ([GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_fields, FreeVars
fvs) <- HsDocContext
-> [FieldLabel]
-> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], FreeVars)
rnConDeclFields HsDocContext
doc [FieldLabel]
fls [LConDeclField GhcPs]
fields
; forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
new_fields, FreeVars
fvs) }
extendPatSynEnv :: DuplicateRecordFields -> FieldSelectors -> HsValBinds GhcPs -> MiniFixityEnv
-> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
extendPatSynEnv :: forall a.
DuplicateRecordFields
-> FieldSelectors
-> HsValBinds GhcPs
-> MiniFixityEnv
-> ([Name] -> TcRnIf TcGblEnv TcLclEnv a)
-> TcRnIf TcGblEnv TcLclEnv a
extendPatSynEnv DuplicateRecordFields
dup_fields_ok FieldSelectors
has_sel HsValBinds GhcPs
val_decls MiniFixityEnv
local_fix_env [Name] -> TcRnIf TcGblEnv TcLclEnv a
thing = do {
[(Name, [FieldLabel])]
names_with_fls <- HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
new_ps HsValBinds GhcPs
val_decls
; let pat_syn_bndrs :: [Name]
pat_syn_bndrs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Name
nameforall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector [FieldLabel]
fields
| (Name
name, [FieldLabel]
fields) <- [(Name, [FieldLabel])]
names_with_fls ]
; let avails :: [AvailInfo]
avails = forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, [FieldLabel])]
names_with_fls)
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> AvailInfo
availField (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Name, [FieldLabel])]
names_with_fls)
; (TcGblEnv
gbl_env, TcLclEnv
lcl_env) <- [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn [AvailInfo]
avails MiniFixityEnv
local_fix_env
; let field_env' :: NameEnv [FieldLabel]
field_env' = forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcGblEnv -> NameEnv [FieldLabel]
tcg_field_env TcGblEnv
gbl_env) [(Name, [FieldLabel])]
names_with_fls
final_gbl_env :: TcGblEnv
final_gbl_env = TcGblEnv
gbl_env { tcg_field_env :: NameEnv [FieldLabel]
tcg_field_env = NameEnv [FieldLabel]
field_env' }
; forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
final_gbl_env, TcLclEnv
lcl_env) ([Name] -> TcRnIf TcGblEnv TcLclEnv a
thing [Name]
pat_syn_bndrs) }
where
new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
new_ps (ValBinds XValBinds GhcPs GhcPs
_ LHsBinds GhcPs
binds [LSig GhcPs]
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM LHsBindLR GhcPs GhcPs
-> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
new_ps' [] LHsBinds GhcPs
binds
new_ps HsValBinds GhcPs
_ = forall a. String -> a
panic String
"new_ps"
new_ps' :: LHsBindLR GhcPs GhcPs
-> [(Name, [FieldLabel])]
-> TcM [(Name, [FieldLabel])]
new_ps' :: LHsBindLR GhcPs GhcPs
-> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
new_ps' LHsBindLR GhcPs GhcPs
bind [(Name, [FieldLabel])]
names
| (L SrcSpanAnnA
bind_loc (PatSynBind XPatSynBind GhcPs GhcPs
_ (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L SrcSpanAnnN
_ RdrName
n
, psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_args = RecCon [RecordPatSynField GhcPs]
as }))) <- LHsBindLR GhcPs GhcPs
bind
= do
Name
bnd_name <- GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
newTopSrcBinder (forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnA
bind_loc) RdrName
n)
let field_occs :: [GenLocated SrcSpan (FieldOcc GhcPs)]
field_occs = forall a b. (a -> b) -> [a] -> [b]
map ((\ FieldOcc GhcPs
f -> forall l e. l -> e -> GenLocated l e
L (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (forall pass. FieldOcc pass -> GenLocated SrcSpanAnnN RdrName
rdrNameFieldOcc FieldOcc GhcPs
f)) FieldOcc GhcPs
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. RecordPatSynField pass -> FieldOcc pass
recordPatSynField) [RecordPatSynField GhcPs]
as
[FieldLabel]
flds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DuplicateRecordFields
-> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
newRecordSelector DuplicateRecordFields
dup_fields_ok FieldSelectors
has_sel [Name
bnd_name]) [GenLocated SrcSpan (FieldOcc GhcPs)]
field_occs
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
bnd_name, [FieldLabel]
flds)forall a. a -> [a] -> [a]
: [(Name, [FieldLabel])]
names)
| L SrcSpanAnnA
bind_loc (PatSynBind XPatSynBind GhcPs GhcPs
_ (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L SrcSpanAnnN
_ RdrName
n})) <- LHsBindLR GhcPs GhcPs
bind
= do
Name
bnd_name <- GenLocated SrcSpanAnnN RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
newTopSrcBinder (forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
bind_loc) RdrName
n)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
bnd_name, [])forall a. a -> [a] -> [a]
: [(Name, [FieldLabel])]
names)
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return [(Name, [FieldLabel])]
names
rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds [LHsFunDep GhcPs]
fds
= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA FunDep GhcPs -> RnM (FunDep GhcRn)
rn_fds) [LHsFunDep GhcPs]
fds
where
rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn)
rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn)
rn_fds (FunDep XCFunDep GhcPs
x [LIdP GhcPs]
tys1 [LIdP GhcPs]
tys2)
= do { [GenLocated SrcSpanAnnN Name]
tys1' <- [GenLocated SrcSpanAnnN RdrName]
-> RnM [GenLocated SrcSpanAnnN Name]
rnHsTyVars [LIdP GhcPs]
tys1
; [GenLocated SrcSpanAnnN Name]
tys2' <- [GenLocated SrcSpanAnnN RdrName]
-> RnM [GenLocated SrcSpanAnnN Name]
rnHsTyVars [LIdP GhcPs]
tys2
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCFunDep pass -> [LIdP pass] -> [LIdP pass] -> FunDep pass
FunDep XCFunDep GhcPs
x [GenLocated SrcSpanAnnN Name]
tys1' [GenLocated SrcSpanAnnN Name]
tys2') }
rnHsTyVars :: [LocatedN RdrName] -> RnM [LocatedN Name]
rnHsTyVars :: [GenLocated SrcSpanAnnN RdrName]
-> RnM [GenLocated SrcSpanAnnN Name]
rnHsTyVars [GenLocated SrcSpanAnnN RdrName]
tvs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnHsTyVar [GenLocated SrcSpanAnnN RdrName]
tvs
rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name)
rnHsTyVar :: GenLocated SrcSpanAnnN RdrName -> RnM (GenLocated SrcSpanAnnN Name)
rnHsTyVar (L SrcSpanAnnN
l RdrName
tyvar) = do
Name
tyvar' <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupOccRn RdrName
tyvar
forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l Name
tyvar')
findSplice :: [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice :: [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
ds = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl forall (p :: Pass). HsGroup (GhcPass p)
emptyRdrGroup [LHsDecl GhcPs]
ds
addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl :: HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl HsGroup GhcPs
gp [] = forall (m :: * -> *) a. Monad m => a -> m a
return (HsGroup GhcPs
gp, forall a. Maybe a
Nothing)
addl HsGroup GhcPs
gp (L SrcSpanAnnA
l HsDecl GhcPs
d : [LHsDecl GhcPs]
ds) = HsGroup GhcPs
-> SrcSpanAnnA
-> HsDecl GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
add HsGroup GhcPs
gp SrcSpanAnnA
l HsDecl GhcPs
d [LHsDecl GhcPs]
ds
add :: HsGroup GhcPs -> SrcSpanAnnA -> HsDecl GhcPs -> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
add :: HsGroup GhcPs
-> SrcSpanAnnA
-> HsDecl GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
add HsGroup GhcPs
gp SrcSpanAnnA
_ (SpliceD XSpliceD GhcPs
_ (SpliceDecl XSpliceDecl GhcPs
_ (L SrcSpanAnnA
_ qq :: HsSplice GhcPs
qq@HsQuasiQuote{}) SpliceExplicitFlag
_)) [LHsDecl GhcPs]
ds
= do { ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds', FreeVars
_) <- HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls HsSplice GhcPs
qq
; HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl HsGroup GhcPs
gp ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds' forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
ds)
}
add HsGroup GhcPs
gp SrcSpanAnnA
loc (SpliceD XSpliceD GhcPs
_ splice :: SpliceDecl GhcPs
splice@(SpliceDecl XSpliceDecl GhcPs
_ XRec GhcPs (HsSplice GhcPs)
_ SpliceExplicitFlag
flag)) [LHsDecl GhcPs]
ds
= do {
case SpliceExplicitFlag
flag of
SpliceExplicitFlag
ExplicitSplice -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
SpliceExplicitFlag
ImplicitSplice -> do { Bool
th_on <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TemplateHaskell
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
th_on forall a b. (a -> b) -> a -> b
$ forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a
failWith SDoc
badImplicitSplice }
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsGroup GhcPs
gp, forall a. a -> Maybe a
Just (SpliceDecl GhcPs
splice, [LHsDecl GhcPs]
ds)) }
where
badImplicitSplice :: SDoc
badImplicitSplice = String -> SDoc
text String
"Parse error: module header, import declaration"
SDoc -> SDoc -> SDoc
$$ String -> SDoc
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 :: [TyClGroup GhcPs]
hs_tyclds = forall (p :: Pass).
LTyClDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_tycld (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l TyClDecl GhcPs
d) [TyClGroup GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_fixds :: forall p. HsGroup p -> [LFixitySig p]
hs_fixds = [LFixitySig GhcPs]
ts}) SrcSpanAnnA
l (SigD XSigD GhcPs
_ (FixSig XFixSig GhcPs
_ FixitySig GhcPs
f)) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp {hs_fixds :: [LFixitySig GhcPs]
hs_fixds = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l FixitySig GhcPs
f forall a. a -> [a] -> [a]
: [LFixitySig GhcPs]
ts}) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup GhcPs]
ts}) SrcSpanAnnA
l (KindSigD XKindSigD GhcPs
_ StandaloneKindSig GhcPs
s) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp {hs_tyclds :: [TyClGroup GhcPs]
hs_tyclds = forall (p :: Pass).
LStandaloneKindSig (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_kisig (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l StandaloneKindSig GhcPs
s) [TyClGroup GhcPs]
ts}) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds = HsValBinds GhcPs
ts}) SrcSpanAnnA
l (SigD XSigD GhcPs
_ Sig GhcPs
d) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp {hs_valds :: HsValBinds GhcPs
hs_valds = forall (a :: Pass).
LSig (GhcPass a)
-> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l Sig GhcPs
d) HsValBinds GhcPs
ts}) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds = HsValBinds GhcPs
ts}) SrcSpanAnnA
l (ValD XValD GhcPs
_ HsBindLR GhcPs GhcPs
d) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_valds :: HsValBinds GhcPs
hs_valds = forall a. LHsBind a -> HsValBinds a -> HsValBinds a
add_bind (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsBindLR GhcPs GhcPs
d) HsValBinds GhcPs
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup GhcPs]
ts}) SrcSpanAnnA
l (RoleAnnotD XRoleAnnotD GhcPs
_ RoleAnnotDecl GhcPs
d) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_tyclds :: [TyClGroup GhcPs]
hs_tyclds = forall (p :: Pass).
LRoleAnnotDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_role_annot (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l RoleAnnotDecl GhcPs
d) [TyClGroup GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup GhcPs]
ts}) SrcSpanAnnA
l (InstD XInstD GhcPs
_ InstDecl GhcPs
d) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_tyclds :: [TyClGroup GhcPs]
hs_tyclds = forall (p :: Pass).
LInstDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_instd (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l InstDecl GhcPs
d) [TyClGroup GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_derivds :: forall p. HsGroup p -> [LDerivDecl p]
hs_derivds = [LDerivDecl GhcPs]
ts}) SrcSpanAnnA
l (DerivD XDerivD GhcPs
_ DerivDecl GhcPs
d) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_derivds :: [LDerivDecl GhcPs]
hs_derivds = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l DerivDecl GhcPs
d forall a. a -> [a] -> [a]
: [LDerivDecl GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_defds :: forall p. HsGroup p -> [LDefaultDecl p]
hs_defds = [LDefaultDecl GhcPs]
ts}) SrcSpanAnnA
l (DefD XDefD GhcPs
_ DefaultDecl GhcPs
d) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_defds :: [LDefaultDecl GhcPs]
hs_defds = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l DefaultDecl GhcPs
d forall a. a -> [a] -> [a]
: [LDefaultDecl GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_fords :: forall p. HsGroup p -> [LForeignDecl p]
hs_fords = [LForeignDecl GhcPs]
ts}) SrcSpanAnnA
l (ForD XForD GhcPs
_ ForeignDecl GhcPs
d) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_fords :: [LForeignDecl GhcPs]
hs_fords = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l ForeignDecl GhcPs
d forall a. a -> [a] -> [a]
: [LForeignDecl GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_warnds :: forall p. HsGroup p -> [LWarnDecls p]
hs_warnds = [LWarnDecls GhcPs]
ts}) SrcSpanAnnA
l (WarningD XWarningD GhcPs
_ WarnDecls GhcPs
d) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_warnds :: [LWarnDecls GhcPs]
hs_warnds = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l WarnDecls GhcPs
d forall a. a -> [a] -> [a]
: [LWarnDecls GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_annds :: forall p. HsGroup p -> [LAnnDecl p]
hs_annds = [LAnnDecl GhcPs]
ts}) SrcSpanAnnA
l (AnnD XAnnD GhcPs
_ AnnDecl GhcPs
d) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_annds :: [LAnnDecl GhcPs]
hs_annds = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l AnnDecl GhcPs
d forall a. a -> [a] -> [a]
: [LAnnDecl GhcPs]
ts }) [LHsDecl GhcPs]
ds
add gp :: HsGroup GhcPs
gp@(HsGroup {hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds = [LRuleDecls GhcPs]
ts}) SrcSpanAnnA
l (RuleD XRuleD GhcPs
_ RuleDecls GhcPs
d) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_ruleds :: [LRuleDecls GhcPs]
hs_ruleds = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l RuleDecls GhcPs
d forall a. a -> [a] -> [a]
: [LRuleDecls GhcPs]
ts }) [LHsDecl GhcPs]
ds
add HsGroup GhcPs
gp SrcSpanAnnA
l (DocD XDocD GhcPs
_ DocDecl
d) [LHsDecl GhcPs]
ds
= HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl (HsGroup GhcPs
gp { hs_docs :: [LDocDecl GhcPs]
hs_docs = (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l DocDecl
d) forall a. a -> [a] -> [a]
: (forall p. HsGroup p -> [LDocDecl p]
hs_docs HsGroup GhcPs
gp) }) [LHsDecl GhcPs]
ds
add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
add_tycld :: forall (p :: Pass).
LTyClDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_tycld LTyClDecl (GhcPass p)
d [] = [TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext = NoExtField
noExtField
, group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = [LTyClDecl (GhcPass p)
d]
, group_kisigs :: [LStandaloneKindSig (GhcPass p)]
group_kisigs = []
, group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles = []
, group_instds :: [LInstDecl (GhcPass p)]
group_instds = []
}
]
add_tycld LTyClDecl (GhcPass p)
d (ds :: TyClGroup (GhcPass p)
ds@(TyClGroup { group_tyclds :: forall pass. TyClGroup pass -> [LTyClDecl pass]
group_tyclds = [LTyClDecl (GhcPass p)]
tyclds }):[TyClGroup (GhcPass p)]
dss)
= TyClGroup (GhcPass p)
ds { group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = LTyClDecl (GhcPass p)
d forall a. a -> [a] -> [a]
: [LTyClDecl (GhcPass p)]
tyclds } forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
dss
add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
add_instd :: forall (p :: Pass).
LInstDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_instd LInstDecl (GhcPass p)
d [] = [TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext = NoExtField
noExtField
, group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = []
, group_kisigs :: [LStandaloneKindSig (GhcPass p)]
group_kisigs = []
, group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles = []
, group_instds :: [LInstDecl (GhcPass p)]
group_instds = [LInstDecl (GhcPass p)
d]
}
]
add_instd LInstDecl (GhcPass p)
d (ds :: TyClGroup (GhcPass p)
ds@(TyClGroup { group_instds :: forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds = [LInstDecl (GhcPass p)]
instds }):[TyClGroup (GhcPass p)]
dss)
= TyClGroup (GhcPass p)
ds { group_instds :: [LInstDecl (GhcPass p)]
group_instds = LInstDecl (GhcPass p)
d forall a. a -> [a] -> [a]
: [LInstDecl (GhcPass p)]
instds } forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
dss
add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
add_role_annot :: forall (p :: Pass).
LRoleAnnotDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_role_annot LRoleAnnotDecl (GhcPass p)
d [] = [TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext = NoExtField
noExtField
, group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = []
, group_kisigs :: [LStandaloneKindSig (GhcPass p)]
group_kisigs = []
, group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles = [LRoleAnnotDecl (GhcPass p)
d]
, group_instds :: [LInstDecl (GhcPass p)]
group_instds = []
}
]
add_role_annot LRoleAnnotDecl (GhcPass p)
d (tycls :: TyClGroup (GhcPass p)
tycls@(TyClGroup { group_roles :: forall pass. TyClGroup pass -> [LRoleAnnotDecl pass]
group_roles = [LRoleAnnotDecl (GhcPass p)]
roles }) : [TyClGroup (GhcPass p)]
rest)
= TyClGroup (GhcPass p)
tycls { group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles = LRoleAnnotDecl (GhcPass p)
d forall a. a -> [a] -> [a]
: [LRoleAnnotDecl (GhcPass p)]
roles } forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
rest
add_kisig :: LStandaloneKindSig (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_kisig :: forall (p :: Pass).
LStandaloneKindSig (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_kisig LStandaloneKindSig (GhcPass p)
d [] = [TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext = NoExtField
noExtField
, group_tyclds :: [LTyClDecl (GhcPass p)]
group_tyclds = []
, group_kisigs :: [LStandaloneKindSig (GhcPass p)]
group_kisigs = [LStandaloneKindSig (GhcPass p)
d]
, group_roles :: [LRoleAnnotDecl (GhcPass p)]
group_roles = []
, group_instds :: [LInstDecl (GhcPass p)]
group_instds = []
}
]
add_kisig LStandaloneKindSig (GhcPass p)
d (tycls :: TyClGroup (GhcPass p)
tycls@(TyClGroup { group_kisigs :: forall pass. TyClGroup pass -> [LStandaloneKindSig pass]
group_kisigs = [LStandaloneKindSig (GhcPass p)]
kisigs }) : [TyClGroup (GhcPass p)]
rest)
= TyClGroup (GhcPass p)
tycls { group_kisigs :: [LStandaloneKindSig (GhcPass p)]
group_kisigs = LStandaloneKindSig (GhcPass p)
d forall a. a -> [a] -> [a]
: [LStandaloneKindSig (GhcPass p)]
kisigs } forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
rest
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind :: forall a. LHsBind a -> HsValBinds a -> HsValBinds a
add_bind LHsBind a
b (ValBinds XValBinds a a
x LHsBindsLR a a
bs [LSig a]
sigs) = forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds a a
x (LHsBindsLR a a
bs forall a. Bag a -> a -> Bag a
`snocBag` LHsBind a
b) [LSig a]
sigs
add_bind LHsBind a
_ (XValBindsLR {}) = forall a. String -> a
panic String
"GHC.Rename.Module.add_bind"
add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig :: forall (a :: Pass).
LSig (GhcPass a)
-> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig LSig (GhcPass a)
s (ValBinds XValBinds (GhcPass a) (GhcPass a)
x LHsBindsLR (GhcPass a) (GhcPass a)
bs [LSig (GhcPass a)]
sigs) = forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds (GhcPass a) (GhcPass a)
x LHsBindsLR (GhcPass a) (GhcPass a)
bs (LSig (GhcPass a)
sforall a. a -> [a] -> [a]
:[LSig (GhcPass a)]
sigs)
add_sig LSig (GhcPass a)
_ (XValBindsLR {}) = forall a. String -> a
panic String
"GHC.Rename.Module.add_sig"