{-# 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 "GhclibHsVersions.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
, checkDupRdrNames, bindLocalNamesFV
, checkShadowedRdrNames, warnUnusedTypePatterns
, extendTyVarEnvFVRn, 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(..))
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, isJust, 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]
hs_docs = [LDocDecl]
docs })
= do {
MiniFixityEnv
local_fix_env <- [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv ([LFixitySig GhcPs] -> RnM MiniFixityEnv)
-> [LFixitySig GhcPs] -> RnM MiniFixityEnv
forall a b. (a -> b) -> a -> b
$ HsGroup GhcPs -> [LFixitySig GhcPs]
forall (p :: Pass). HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)]
hsGroupTopLevelFixitySigs HsGroup GhcPs
group ;
((TcGblEnv, TcLclEnv)
tc_envs, NameSet
tc_bndrs) <- MiniFixityEnv
-> HsGroup GhcPs -> RnM ((TcGblEnv, TcLclEnv), NameSet)
getLocalNonValBinders MiniFixityEnv
local_fix_env HsGroup GhcPs
group ;
(TcGblEnv, TcLclEnv)
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
tc_envs (RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$ do {
TcRn ()
failIfErrsM ;
HsValBinds GhcPs
-> MiniFixityEnv
-> ([Name] -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn)
forall a.
HsValBinds GhcPs
-> MiniFixityEnv
-> ([Name] -> TcRnIf TcGblEnv TcLclEnv a)
-> TcRnIf TcGblEnv TcLclEnv a
extendPatSynEnv HsValBinds GhcPs
val_decls MiniFixityEnv
local_fix_env (([Name] -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn))
-> ([Name] -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$ \[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 = HsValBindsLR GhcRn GhcPs -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectHsIdBinders HsValBindsLR GhcRn GhcPs
new_lhs } ;
String -> SDoc -> TcRn ()
traceRn String
"rnSrcDecls" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
[IdP GhcRn]
id_bndrs) ;
(TcGblEnv, TcLclEnv)
tc_envs <- [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn ((Name -> AvailInfo) -> [Name] -> [AvailInfo]
forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail [Name]
[IdP GhcRn]
id_bndrs) MiniFixityEnv
local_fix_env ;
(TcGblEnv, TcLclEnv)
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
tc_envs (RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn))
-> RnM (TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> TcRn ()
traceRn String
"Start rnTyClDecls" ([TyClGroup GhcPs] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyClGroup GhcPs]
tycl_decls) ;
([TyClGroup GhcRn]
rn_tycl_decls, NameSet
src_fvs1) <- [TyClGroup GhcPs] -> RnM ([TyClGroup GhcRn], NameSet)
rnTyClDecls [TyClGroup GhcPs]
tycl_decls ;
String -> SDoc -> TcRn ()
traceRn String
"Start rnmono" SDoc
empty ;
let { val_bndr_set :: NameSet
val_bndr_set = [Name] -> NameSet
mkNameSet [Name]
[IdP GhcRn]
id_bndrs NameSet -> NameSet -> NameSet
`unionNameSet` [Name] -> NameSet
mkNameSet [Name]
pat_syn_bndrs } ;
Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig ;
(HsValBinds GhcRn
rn_val_decls, DefUses
bind_dus) <- if Bool
is_boot
then NameSet
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnTopBindsBoot NameSet
tc_bndrs HsValBindsLR GhcRn GhcPs
new_lhs
else HsSigCtxt
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnValBindsRHS (NameSet -> HsSigCtxt
TopSigCtxt NameSet
val_bndr_set) HsValBindsLR GhcRn GhcPs
new_lhs ;
String -> SDoc -> TcRn ()
traceRn String
"finish rnmono" (HsValBinds GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBinds GhcRn
rn_val_decls) ;
let { all_bndrs :: NameSet
all_bndrs = NameSet
tc_bndrs NameSet -> NameSet -> NameSet
`unionNameSet` NameSet
val_bndr_set } ;
[GenLocated SrcSpan (FixitySig GhcRn)]
rn_fix_decls <- (GenLocated SrcSpan (FixitySig GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpan (FixitySig GhcRn)))
-> [GenLocated SrcSpan (FixitySig GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [GenLocated SrcSpan (FixitySig GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((FixitySig GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (FixitySig GhcRn))
-> GenLocated SrcSpan (FixitySig GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpan (FixitySig GhcRn))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsSigCtxt
-> FixitySig GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (FixitySig GhcRn)
rnSrcFixityDecl (NameSet -> HsSigCtxt
TopSigCtxt NameSet
all_bndrs)))
[GenLocated SrcSpan (FixitySig GhcPs)]
[LFixitySig GhcPs]
fix_decls ;
Warnings
rn_warns <- NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
rnSrcWarnDecls NameSet
all_bndrs [LWarnDecls GhcPs]
warn_decls ;
([Located (RuleDecls GhcRn)]
rn_rule_decls, NameSet
src_fvs2) <- Extension
-> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
-> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.ScopedTypeVariables (TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
-> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet))
-> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
-> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
forall a b. (a -> b) -> a -> b
$
(RuleDecls GhcPs -> RnM (RuleDecls GhcRn, NameSet))
-> [Located (RuleDecls GhcPs)]
-> TcRnIf TcGblEnv TcLclEnv ([Located (RuleDecls GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList RuleDecls GhcPs -> RnM (RuleDecls GhcRn, NameSet)
rnHsRuleDecls [Located (RuleDecls GhcPs)]
[LRuleDecls GhcPs]
rule_decls ;
([Located (ForeignDecl GhcRn)]
rn_foreign_decls, NameSet
src_fvs3) <- (ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, NameSet))
-> [Located (ForeignDecl GhcPs)]
-> RnM ([Located (ForeignDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, NameSet)
rnHsForeignDecl [Located (ForeignDecl GhcPs)]
[LForeignDecl GhcPs]
foreign_decls ;
([Located (AnnDecl GhcRn)]
rn_ann_decls, NameSet
src_fvs4) <- (AnnDecl GhcPs -> RnM (AnnDecl GhcRn, NameSet))
-> [Located (AnnDecl GhcPs)]
-> RnM ([Located (AnnDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList AnnDecl GhcPs -> RnM (AnnDecl GhcRn, NameSet)
rnAnnDecl [Located (AnnDecl GhcPs)]
[LAnnDecl GhcPs]
ann_decls ;
([Located (DefaultDecl GhcRn)]
rn_default_decls, NameSet
src_fvs5) <- (DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, NameSet))
-> [Located (DefaultDecl GhcPs)]
-> RnM ([Located (DefaultDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, NameSet)
rnDefaultDecl [Located (DefaultDecl GhcPs)]
[LDefaultDecl GhcPs]
default_decls ;
([Located (DerivDecl GhcRn)]
rn_deriv_decls, NameSet
src_fvs6) <- (DerivDecl GhcPs -> RnM (DerivDecl GhcRn, NameSet))
-> [Located (DerivDecl GhcPs)]
-> RnM ([Located (DerivDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList DerivDecl GhcPs -> RnM (DerivDecl GhcRn, NameSet)
rnSrcDerivDecl [Located (DerivDecl GhcPs)]
[LDerivDecl GhcPs]
deriv_decls ;
([Located (SpliceDecl GhcRn)]
rn_splice_decls, NameSet
src_fvs7) <- (SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, NameSet))
-> [Located (SpliceDecl GhcPs)]
-> RnM ([Located (SpliceDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, NameSet)
rnSpliceDecl [Located (SpliceDecl GhcPs)]
[LSpliceDecl GhcPs]
splice_decls ;
TcGblEnv
last_tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv ;
let {rn_group :: HsGroup GhcRn
rn_group = HsGroup :: forall p.
XCHsGroup p
-> HsValBinds p
-> [LSpliceDecl p]
-> [TyClGroup p]
-> [LDerivDecl p]
-> [LFixitySig p]
-> [LDefaultDecl p]
-> [LForeignDecl p]
-> [LWarnDecls p]
-> [LAnnDecl p]
-> [LRuleDecls p]
-> [LDocDecl]
-> HsGroup p
HsGroup { hs_ext :: XCHsGroup GhcRn
hs_ext = NoExtField
XCHsGroup GhcRn
noExtField,
hs_valds :: HsValBinds GhcRn
hs_valds = HsValBinds GhcRn
rn_val_decls,
hs_splcds :: [LSpliceDecl GhcRn]
hs_splcds = [Located (SpliceDecl GhcRn)]
[LSpliceDecl GhcRn]
rn_splice_decls,
hs_tyclds :: [TyClGroup GhcRn]
hs_tyclds = [TyClGroup GhcRn]
rn_tycl_decls,
hs_derivds :: [LDerivDecl GhcRn]
hs_derivds = [Located (DerivDecl GhcRn)]
[LDerivDecl GhcRn]
rn_deriv_decls,
hs_fixds :: [LFixitySig GhcRn]
hs_fixds = [GenLocated SrcSpan (FixitySig GhcRn)]
[LFixitySig GhcRn]
rn_fix_decls,
hs_warnds :: [LWarnDecls GhcRn]
hs_warnds = [],
hs_fords :: [LForeignDecl GhcRn]
hs_fords = [Located (ForeignDecl GhcRn)]
[LForeignDecl GhcRn]
rn_foreign_decls,
hs_annds :: [LAnnDecl GhcRn]
hs_annds = [Located (AnnDecl GhcRn)]
[LAnnDecl GhcRn]
rn_ann_decls,
hs_defds :: [LDefaultDecl GhcRn]
hs_defds = [Located (DefaultDecl GhcRn)]
[LDefaultDecl GhcRn]
rn_default_decls,
hs_ruleds :: [LRuleDecls GhcRn]
hs_ruleds = [Located (RuleDecls GhcRn)]
[LRuleDecls GhcRn]
rn_rule_decls,
hs_docs :: [LDocDecl]
hs_docs = [LDocDecl]
docs } ;
tcf_bndrs :: [Name]
tcf_bndrs = [TyClGroup GhcRn] -> [LForeignDecl GhcRn] -> [Name]
hsTyClForeignBinders [TyClGroup GhcRn]
rn_tycl_decls [Located (ForeignDecl GhcRn)]
[LForeignDecl GhcRn]
rn_foreign_decls ;
other_def :: (Maybe NameSet, NameSet)
other_def = (NameSet -> Maybe NameSet
forall a. a -> Maybe a
Just ([Name] -> NameSet
mkNameSet [Name]
tcf_bndrs), NameSet
emptyNameSet) ;
other_fvs :: NameSet
other_fvs = [NameSet] -> NameSet
plusFVs [NameSet
src_fvs1, NameSet
src_fvs2, NameSet
src_fvs3, NameSet
src_fvs4,
NameSet
src_fvs5, NameSet
src_fvs6, NameSet
src_fvs7] ;
src_dus :: DefUses
src_dus = (Maybe NameSet, NameSet) -> DefUses
forall a. a -> OrdList a
unitOL (Maybe NameSet, NameSet)
other_def DefUses -> DefUses -> DefUses
`plusDU` DefUses
bind_dus DefUses -> DefUses -> DefUses
`plusDU` NameSet -> DefUses
usesOnly NameSet
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" (HsGroup GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsGroup GhcRn
rn_group) ;
String -> SDoc -> TcRn ()
traceRn String
"finish Dus" (DefUses -> SDoc
forall a. Outputable a => a -> SDoc
ppr DefUses
src_dus ) ;
(TcGblEnv, HsGroup GhcRn) -> RnM (TcGblEnv, HsGroup GhcRn)
forall (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)) -> [Located a] -> RnM ([Located b], FreeVars)
rnList :: (a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList a -> RnM (b, NameSet)
f [Located a]
xs = (Located a -> RnM (Located b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn ((a -> RnM (b, NameSet)) -> Located a -> RnM (Located b, NameSet)
forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM a -> RnM (b, NameSet)
f) [Located a]
xs
rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
rnSrcWarnDecls NameSet
_ []
= Warnings -> RnM Warnings
forall (m :: * -> *) a. Monad m => a -> m a
return Warnings
NoWarnings
rnSrcWarnDecls NameSet
bndr_set [LWarnDecls GhcPs]
decls'
= do {
; (NonEmpty (GenLocated SrcSpan RdrName) -> TcRn ())
-> [NonEmpty (GenLocated SrcSpan RdrName)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ NonEmpty (GenLocated SrcSpan RdrName)
dups -> let ((L SrcSpan
loc RdrName
rdr) :| (GenLocated SrcSpan RdrName
lrdr':[GenLocated SrcSpan RdrName]
_)) = NonEmpty (GenLocated SrcSpan RdrName)
dups
in SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
loc (GenLocated SrcSpan RdrName -> RdrName -> SDoc
dupWarnDecl GenLocated SrcSpan RdrName
lrdr' RdrName
rdr))
[NonEmpty (GenLocated SrcSpan RdrName)]
warn_rdr_dups
; [[(OccName, WarningTxt)]]
pairs_s <- (Located (WarnDecl GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)])
-> [Located (WarnDecl GhcPs)]
-> IOEnv (Env TcGblEnv TcLclEnv) [[(OccName, WarningTxt)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((WarnDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)])
-> Located (WarnDecl GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM WarnDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
rn_deprec) [Located (WarnDecl GhcPs)]
decls
; Warnings -> RnM Warnings
forall (m :: * -> *) a. Monad m => a -> m a
return ([(OccName, WarningTxt)] -> Warnings
WarnSome (([[(OccName, WarningTxt)]] -> [(OccName, WarningTxt)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(OccName, WarningTxt)]]
pairs_s))) }
where
decls :: [Located (WarnDecl GhcPs)]
decls = (GenLocated SrcSpan (WarnDecls GhcPs)
-> [Located (WarnDecl GhcPs)])
-> [GenLocated SrcSpan (WarnDecls GhcPs)]
-> [Located (WarnDecl GhcPs)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (WarnDecls GhcPs -> [Located (WarnDecl GhcPs)]
forall pass. WarnDecls pass -> [LWarnDecl pass]
wd_warnings (WarnDecls GhcPs -> [Located (WarnDecl GhcPs)])
-> (GenLocated SrcSpan (WarnDecls GhcPs) -> WarnDecls GhcPs)
-> GenLocated SrcSpan (WarnDecls GhcPs)
-> [Located (WarnDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan (WarnDecls GhcPs) -> WarnDecls GhcPs
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpan (WarnDecls GhcPs)]
[LWarnDecls GhcPs]
decls'
sig_ctxt :: HsSigCtxt
sig_ctxt = NameSet -> HsSigCtxt
TopSigCtxt NameSet
bndr_set
rn_deprec :: WarnDecl GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
rn_deprec (Warning XWarning GhcPs
_ [LIdP GhcPs]
rdr_names WarningTxt
txt)
= do { [(RdrName, Name)]
names <- (GenLocated SrcSpan RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)])
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (HsSigCtxt
-> SDoc
-> RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)]
lookupLocalTcNames HsSigCtxt
sig_ctxt SDoc
what (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)])
-> (GenLocated SrcSpan RdrName -> RdrName)
-> GenLocated SrcSpan RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) [(RdrName, Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc)
[GenLocated SrcSpan RdrName]
[LIdP GhcPs]
rdr_names
; [(OccName, WarningTxt)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(OccName, WarningTxt)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(RdrName -> OccName
rdrNameOcc RdrName
rdr, WarningTxt
txt) | (RdrName
rdr, Name
_) <- [(RdrName, Name)]
names] }
what :: SDoc
what = String -> SDoc
text String
"deprecation"
warn_rdr_dups :: [NonEmpty (GenLocated SrcSpan RdrName)]
warn_rdr_dups = [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
findDupRdrNames
([GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)])
-> [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
forall a b. (a -> b) -> a -> b
$ (Located (WarnDecl GhcPs) -> [GenLocated SrcSpan RdrName])
-> [Located (WarnDecl GhcPs)] -> [GenLocated SrcSpan RdrName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(L SrcSpan
_ (Warning XWarning GhcPs
_ [LIdP GhcPs]
ns WarningTxt
_)) -> [GenLocated SrcSpan RdrName]
[LIdP GhcPs]
ns) [Located (WarnDecl GhcPs)]
decls
findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
findDupRdrNames :: [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
findDupRdrNames = (GenLocated SrcSpan RdrName -> GenLocated SrcSpan RdrName -> Bool)
-> [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (\ GenLocated SrcSpan RdrName
x -> \ GenLocated SrcSpan RdrName
y -> RdrName -> OccName
rdrNameOcc (GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan RdrName
x) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc (GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan RdrName
y))
dupWarnDecl :: Located RdrName -> RdrName -> SDoc
dupWarnDecl :: GenLocated SrcSpan RdrName -> RdrName -> SDoc
dupWarnDecl GenLocated SrcSpan RdrName
d RdrName
rdr_name
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Multiple warning declarations for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name),
String -> SDoc
text String
"also at " SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenLocated SrcSpan RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpan RdrName
d)]
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, NameSet)
rnAnnDecl ann :: AnnDecl GhcPs
ann@(HsAnnotation XHsAnnotation GhcPs
_ SourceText
s AnnProvenance (IdP GhcPs)
provenance XRec GhcPs (HsExpr GhcPs)
expr)
= SDoc
-> RnM (AnnDecl GhcRn, NameSet) -> RnM (AnnDecl GhcRn, NameSet)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (AnnDecl GhcPs -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
AnnDecl (GhcPass p) -> SDoc
annCtxt AnnDecl GhcPs
ann) (RnM (AnnDecl GhcRn, NameSet) -> RnM (AnnDecl GhcRn, NameSet))
-> RnM (AnnDecl GhcRn, NameSet) -> RnM (AnnDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$
do { (AnnProvenance Name
provenance', NameSet
provenance_fvs) <- AnnProvenance RdrName -> RnM (AnnProvenance Name, NameSet)
rnAnnProvenance AnnProvenance RdrName
AnnProvenance (IdP GhcPs)
provenance
; (Located (HsExpr GhcRn)
expr', NameSet
expr_fvs) <- ThStage
-> TcM (Located (HsExpr GhcRn), NameSet)
-> TcM (Located (HsExpr GhcRn), NameSet)
forall a. ThStage -> TcM a -> TcM a
setStage (SpliceType -> ThStage
Splice SpliceType
Untyped) (TcM (Located (HsExpr GhcRn), NameSet)
-> TcM (Located (HsExpr GhcRn), NameSet))
-> TcM (Located (HsExpr GhcRn), NameSet)
-> TcM (Located (HsExpr GhcRn), NameSet)
forall a b. (a -> b) -> a -> b
$
XRec GhcPs (HsExpr GhcPs) -> RnM (LHsExpr GhcRn, NameSet)
rnLExpr XRec GhcPs (HsExpr GhcPs)
expr
; (AnnDecl GhcRn, NameSet) -> RnM (AnnDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsAnnotation GhcRn
-> SourceText
-> AnnProvenance (IdP GhcRn)
-> LHsExpr GhcRn
-> AnnDecl GhcRn
forall pass.
XHsAnnotation pass
-> SourceText
-> AnnProvenance (IdP pass)
-> XRec pass (HsExpr pass)
-> AnnDecl pass
HsAnnotation NoExtField
XHsAnnotation GhcRn
noExtField SourceText
s AnnProvenance Name
AnnProvenance (IdP GhcRn)
provenance' Located (HsExpr GhcRn)
LHsExpr GhcRn
expr',
NameSet
provenance_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
expr_fvs) }
rnAnnProvenance :: AnnProvenance RdrName
-> RnM (AnnProvenance Name, FreeVars)
rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, NameSet)
rnAnnProvenance AnnProvenance RdrName
provenance = do
AnnProvenance Name
provenance' <- (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> AnnProvenance RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) (AnnProvenance Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupTopBndrRn AnnProvenance RdrName
provenance
(AnnProvenance Name, NameSet) -> RnM (AnnProvenance Name, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnProvenance Name
provenance', NameSet -> (Name -> NameSet) -> Maybe Name -> NameSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NameSet
emptyFVs Name -> NameSet
unitFV (AnnProvenance Name -> Maybe Name
forall name. AnnProvenance name -> Maybe name
annProvenanceName_maybe AnnProvenance Name
provenance'))
rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, NameSet)
rnDefaultDecl (DefaultDecl XCDefaultDecl GhcPs
_ [LHsType GhcPs]
tys)
= do { ([Located (HsType GhcRn)]
tys', NameSet
fvs) <- HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], NameSet)
rnLHsTypes HsDocContext
doc_str [LHsType GhcPs]
tys
; (DefaultDecl GhcRn, NameSet) -> RnM (DefaultDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCDefaultDecl GhcRn -> [LHsType GhcRn] -> DefaultDecl GhcRn
forall pass.
XCDefaultDecl pass -> [LHsType pass] -> DefaultDecl pass
DefaultDecl NoExtField
XCDefaultDecl GhcRn
noExtField [Located (HsType GhcRn)]
[LHsType GhcRn]
tys', NameSet
fvs) }
where
doc_str :: HsDocContext
doc_str = HsDocContext
DefaultDeclCtx
rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, NameSet)
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 <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; Located Name
name' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
LIdP GhcPs
name
; (HsImplicitBndrs GhcRn (Located (HsType GhcRn))
ty', NameSet
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType (GenLocated SrcSpan RdrName -> HsDocContext
ForeignDeclCtx GenLocated SrcSpan RdrName
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
; (ForeignDecl GhcRn, NameSet) -> RnM (ForeignDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport :: forall pass.
XForeignImport pass
-> LIdP pass
-> LHsSigType pass
-> ForeignImport
-> ForeignDecl pass
ForeignImport { fd_i_ext :: XForeignImport GhcRn
fd_i_ext = NoExtField
XForeignImport GhcRn
noExtField
, fd_name :: LIdP GhcRn
fd_name = Located Name
LIdP GhcRn
name', fd_sig_ty :: LHsSigType GhcRn
fd_sig_ty = HsImplicitBndrs GhcRn (Located (HsType GhcRn))
LHsSigType GhcRn
ty'
, fd_fi :: ForeignImport
fd_fi = ForeignImport
spec' }, NameSet
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 { Located Name
name' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedOccRn GenLocated SrcSpan RdrName
LIdP GhcPs
name
; (HsImplicitBndrs GhcRn (Located (HsType GhcRn))
ty', NameSet
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType (GenLocated SrcSpan RdrName -> HsDocContext
ForeignDeclCtx GenLocated SrcSpan RdrName
LIdP GhcPs
name) TypeOrKind
TypeLevel LHsSigType GhcPs
ty
; (ForeignDecl GhcRn, NameSet) -> RnM (ForeignDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignExport :: forall pass.
XForeignExport pass
-> LIdP pass
-> LHsSigType pass
-> ForeignExport
-> ForeignDecl pass
ForeignExport { fd_e_ext :: XForeignExport GhcRn
fd_e_ext = NoExtField
XForeignExport GhcRn
noExtField
, fd_name :: LIdP GhcRn
fd_name = Located Name
LIdP GhcRn
name', fd_sig_ty :: LHsSigType GhcRn
fd_sig_ty = HsImplicitBndrs GhcRn (Located (HsType GhcRn))
LHsSigType GhcRn
ty'
, fd_fe :: ForeignExport
fd_fe = ForeignExport
spec }
, NameSet
fvs NameSet -> Name -> NameSet
`addOneFV` Located Name -> Name
forall l e. GenLocated l e -> e
unLoc Located 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 (CCallTarget -> CImportSpec) -> CCallTarget -> CImportSpec
forall a b. (a -> b) -> a -> b
$ Unit -> CCallTarget -> CCallTarget
patchCCallTarget Unit
unit CCallTarget
callTarget
CImportSpec
_ -> CImportSpec
spec
patchCCallTarget :: Unit -> CCallTarget -> CCallTarget
patchCCallTarget :: Unit -> CCallTarget -> CCallTarget
patchCCallTarget Unit
unit CCallTarget
callTarget =
case CCallTarget
callTarget of
StaticTarget SourceText
src CLabelString
label Maybe Unit
Nothing Bool
isFun
-> SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
src CLabelString
label (Unit -> Maybe Unit
forall a. a -> Maybe a
Just Unit
unit) Bool
isFun
CCallTarget
_ -> CCallTarget
callTarget
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, NameSet)
rnSrcInstDecl (TyFamInstD { tfid_inst :: forall pass. InstDecl pass -> TyFamInstDecl pass
tfid_inst = TyFamInstDecl GhcPs
tfi })
= do { (TyFamInstDecl GhcRn
tfi', NameSet
fvs) <- AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet)
rnTyFamInstDecl (ClosedTyFamInfo -> AssocTyFamInfo
NonAssocTyFamEqn ClosedTyFamInfo
NotClosedTyFam) TyFamInstDecl GhcPs
tfi
; (InstDecl GhcRn, NameSet) -> RnM (InstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyFamInstD :: forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD { tfid_ext :: XTyFamInstD GhcRn
tfid_ext = NoExtField
XTyFamInstD GhcRn
noExtField, tfid_inst :: TyFamInstDecl GhcRn
tfid_inst = TyFamInstDecl GhcRn
tfi' }, NameSet
fvs) }
rnSrcInstDecl (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl GhcPs
dfi })
= do { (DataFamInstDecl GhcRn
dfi', NameSet
fvs) <- AssocTyFamInfo
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, NameSet)
rnDataFamInstDecl (ClosedTyFamInfo -> AssocTyFamInfo
NonAssocTyFamEqn ClosedTyFamInfo
NotClosedTyFam) DataFamInstDecl GhcPs
dfi
; (InstDecl GhcRn, NameSet) -> RnM (InstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataFamInstD :: forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD { dfid_ext :: XDataFamInstD GhcRn
dfid_ext = NoExtField
XDataFamInstD GhcRn
noExtField, dfid_inst :: DataFamInstDecl GhcRn
dfid_inst = DataFamInstDecl GhcRn
dfi' }, NameSet
fvs) }
rnSrcInstDecl (ClsInstD { cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst = ClsInstDecl GhcPs
cid })
= do { String -> SDoc -> TcRn ()
traceRn String
"rnSrcIstDecl {" (ClsInstDecl GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInstDecl GhcPs
cid)
; (ClsInstDecl GhcRn
cid', NameSet
fvs) <- ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, NameSet)
rnClsInstDecl ClsInstDecl GhcPs
cid
; String -> SDoc -> TcRn ()
traceRn String
"rnSrcIstDecl end }" SDoc
empty
; (InstDecl GhcRn, NameSet) -> RnM (InstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstD :: forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
ClsInstD { cid_d_ext :: XClsInstD GhcRn
cid_d_ext = NoExtField
XClsInstD GhcRn
noExtField, cid_inst :: ClsInstDecl GhcRn
cid_inst = ClsInstDecl GhcRn
cid' }, NameSet
fvs) }
checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> TcRn ()
checkCanonicalInstances Name
cls LHsSigType GhcRn
poly_ty LHsBinds GhcRn
mbinds = do
WarningFlag -> TcRn () -> TcRn ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNonCanonicalMonadInstances
(TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> TcRn ()
checkCanonicalMonadInstances
String
"https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"
WarningFlag -> TcRn () -> TcRn ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNonCanonicalMonoidInstances
(TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> TcRn ()
checkCanonicalMonoidInstances
String
"https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"
where
checkCanonicalMonadInstances :: String -> TcRn ()
checkCanonicalMonadInstances String
refURL
| Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
applicativeClassName =
[GenLocated SrcSpan (HsBindLR GhcRn GhcRn)]
-> (GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpan (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
LHsBinds GhcRn
mbinds) ((GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ()) -> TcRn ())
-> (GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(L SrcSpan
loc HsBindLR GhcRn GhcRn
mbind) -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
case HsBindLR GhcRn GhcRn
mbind of
FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L _ name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
pureAName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Name
forall a. a -> Maybe a
Just Name
returnMName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"pure" String
"return"
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
thenAName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Name
forall a. a -> Maybe a
Just Name
thenMName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"(*>)" String
"(>>)"
HsBindLR GhcRn GhcRn
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
monadClassName =
[GenLocated SrcSpan (HsBindLR GhcRn GhcRn)]
-> (GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpan (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
LHsBinds GhcRn
mbinds) ((GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ()) -> TcRn ())
-> (GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(L SrcSpan
loc HsBindLR GhcRn GhcRn
mbind) -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
case HsBindLR GhcRn GhcRn
mbind of
FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L _ name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
returnMName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Maybe Name
forall a. a -> Maybe a
Just Name
pureAName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"return" String
"pure"
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
thenMName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Maybe Name
forall a. a -> Maybe a
Just Name
thenAName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonadInstances String
"(>>)" String
"(*>)"
HsBindLR GhcRn GhcRn
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCanonicalMonoidInstances :: String -> TcRn ()
checkCanonicalMonoidInstances String
refURL
| Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
semigroupClassName =
[GenLocated SrcSpan (HsBindLR GhcRn GhcRn)]
-> (GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpan (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
LHsBinds GhcRn
mbinds) ((GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ()) -> TcRn ())
-> (GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(L SrcSpan
loc HsBindLR GhcRn GhcRn
mbind) -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
case HsBindLR GhcRn GhcRn
mbind of
FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L _ name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
sappendName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Name
forall a. a -> Maybe a
Just Name
mappendName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonoidInstances String
"(<>)" String
"mappend"
HsBindLR GhcRn GhcRn
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
monoidClassName =
[GenLocated SrcSpan (HsBindLR GhcRn GhcRn)]
-> (GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpan (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
LHsBinds GhcRn
mbinds) ((GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ()) -> TcRn ())
-> (GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(L SrcSpan
loc HsBindLR GhcRn GhcRn
mbind) -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
case HsBindLR GhcRn GhcRn
mbind of
FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L _ name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
mg }
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
mappendName, MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
mg Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Maybe Name
forall a. a -> Maybe a
Just Name
sappendName
-> String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod2 String
refURL
WarningFlag
Opt_WarnNonCanonicalMonoidInstances
String
"mappend" String
"(<>)"
HsBindLR GhcRn GhcRn
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = () -> TcRn ()
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 _ [L _ (Match { m_pats = []
, m_grhss = grhss })])}
| GRHSs XCGRHSs GhcRn (Located (HsExpr GhcRn))
_ [L _ (GRHS _ [] body)] LHsLocalBinds GhcRn
lbinds <- GRHSs GhcRn (Located (HsExpr GhcRn))
grhss
, EmptyLocalBinds XEmptyLocalBinds GhcRn GhcRn
_ <- GenLocated SrcSpan (HsLocalBindsLR GhcRn GhcRn)
-> HsLocalBindsLR GhcRn GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (HsLocalBindsLR GhcRn GhcRn)
LHsLocalBinds GhcRn
lbinds
, HsVar XVar GhcRn
_ LIdP GhcRn
lrhsName <- Located (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc Located (HsExpr GhcRn)
body = Name -> Maybe Name
forall a. a -> Maybe a
Just (Located Name -> Name
forall l e. GenLocated l e -> e
unLoc Located Name
LIdP GhcRn
lrhsName)
isAliasMG MatchGroup GhcRn (LHsExpr GhcRn)
_ = Maybe Name
forall a. Maybe a
Nothing
addWarnNonCanonicalMethod1 :: String -> WarningFlag -> String -> String -> TcRn ()
addWarnNonCanonicalMethod1 String
refURL WarningFlag
flag String
lhs String
rhs =
WarnReason -> SDoc -> TcRn ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
flag) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"Noncanonical" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (String -> SDoc
text (String
lhs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rhs)) SDoc -> SDoc -> SDoc
<+>
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) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> 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 (Located (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType GhcRn
hs_inst_ty))
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
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, NameSet)
rnClsInstDecl (ClsInstDecl { cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_poly_ty = LHsSigType GhcPs
inst_ty, cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds = LHsBinds GhcPs
mbinds
, cid_sigs :: forall pass. ClsInstDecl pass -> [LSig pass]
cid_sigs = [LSig GhcPs]
uprags, cid_tyfam_insts :: forall pass. ClsInstDecl pass -> [LTyFamInstDecl pass]
cid_tyfam_insts = [LTyFamInstDecl GhcPs]
ats
, cid_overlap_mode :: forall pass. ClsInstDecl pass -> Maybe (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
; (HsImplicitBndrs GhcRn (Located (HsType GhcRn))
inst_ty', NameSet
inst_fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
ctxt TypeOrKind
TypeLevel LHsSigType GhcPs
inst_ty
; let ([Name]
ktv_names, Located [Located (HsType GhcRn)]
_, Located (HsType GhcRn)
head_ty') = LHsSigType GhcRn -> ([Name], LHsContext GhcRn, LHsType GhcRn)
splitLHsInstDeclTy HsImplicitBndrs GhcRn (Located (HsType GhcRn))
LHsSigType 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") Located (HsType GhcRn)
LHsType GhcRn
head_ty'
eith_cls :: Either (SrcSpan, SDoc) Name
eith_cls = case LHsType GhcRn -> Maybe (Located (IdP GhcRn))
forall (p :: Pass).
LHsType (GhcPass p) -> Maybe (Located (IdP (GhcPass p)))
hsTyGetAppHead_maybe Located (HsType GhcRn)
LHsType GhcRn
head_ty' of
Just (L SrcSpan
_ IdP GhcRn
cls) -> Name -> Either (SrcSpan, SDoc) Name
forall a b. b -> Either a b
Right Name
IdP GhcRn
cls
Maybe (Located (IdP GhcRn))
Nothing -> (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) Name
forall a b. a -> Either a b
Left
( Located (HsType GhcRn) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (HsType GhcRn)
head_ty'
, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal head of an instance declaration:"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (HsType 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 (SDoc -> SDoc) -> SDoc -> SDoc
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) -> Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
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 SrcSpan (HsBindLR GhcRn GhcRn))
mbinds', [Located (Sig GhcRn)]
uprags', NameSet
meth_fvs) <- Bool
-> Name
-> [Name]
-> LHsBinds GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], NameSet)
rnMethodBinds Bool
False Name
cls [Name]
ktv_names LHsBinds GhcPs
mbinds [LSig GhcPs]
uprags
; Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> TcRn ()
checkCanonicalInstances Name
cls HsImplicitBndrs GhcRn (Located (HsType GhcRn))
LHsSigType GhcRn
inst_ty' Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
LHsBinds GhcRn
mbinds'
; String -> SDoc -> TcRn ()
traceRn String
"rnSrcInstDecl" (HsImplicitBndrs GhcRn (Located (HsType GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsImplicitBndrs GhcRn (Located (HsType GhcRn))
inst_ty' SDoc -> SDoc -> SDoc
$$ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
ktv_names)
; (([Located (TyFamInstDecl GhcRn)]
ats', [Located (DataFamInstDecl GhcRn)]
adts'), NameSet
more_fvs)
<- [Name]
-> RnM
(([Located (TyFamInstDecl GhcRn)],
[Located (DataFamInstDecl GhcRn)]),
NameSet)
-> RnM
(([Located (TyFamInstDecl GhcRn)],
[Located (DataFamInstDecl GhcRn)]),
NameSet)
forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
extendTyVarEnvFVRn [Name]
ktv_names (RnM
(([Located (TyFamInstDecl GhcRn)],
[Located (DataFamInstDecl GhcRn)]),
NameSet)
-> RnM
(([Located (TyFamInstDecl GhcRn)],
[Located (DataFamInstDecl GhcRn)]),
NameSet))
-> RnM
(([Located (TyFamInstDecl GhcRn)],
[Located (DataFamInstDecl GhcRn)]),
NameSet)
-> RnM
(([Located (TyFamInstDecl GhcRn)],
[Located (DataFamInstDecl GhcRn)]),
NameSet)
forall a b. (a -> b) -> a -> b
$
do { ([Located (TyFamInstDecl GhcRn)]
ats', NameSet
at_fvs) <- (AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet))
-> Name
-> [Name]
-> [Located (TyFamInstDecl GhcPs)]
-> RnM ([Located (TyFamInstDecl GhcRn)], NameSet)
forall (decl :: * -> *).
(AssocTyFamInfo -> decl GhcPs -> RnM (decl GhcRn, NameSet))
-> Name
-> [Name]
-> [Located (decl GhcPs)]
-> RnM ([Located (decl GhcRn)], NameSet)
rnATInstDecls AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet)
rnTyFamInstDecl Name
cls [Name]
ktv_names [Located (TyFamInstDecl GhcPs)]
[LTyFamInstDecl GhcPs]
ats
; ([Located (DataFamInstDecl GhcRn)]
adts', NameSet
adt_fvs) <- (AssocTyFamInfo
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, NameSet))
-> Name
-> [Name]
-> [Located (DataFamInstDecl GhcPs)]
-> RnM ([Located (DataFamInstDecl GhcRn)], NameSet)
forall (decl :: * -> *).
(AssocTyFamInfo -> decl GhcPs -> RnM (decl GhcRn, NameSet))
-> Name
-> [Name]
-> [Located (decl GhcPs)]
-> RnM ([Located (decl GhcRn)], NameSet)
rnATInstDecls AssocTyFamInfo
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, NameSet)
rnDataFamInstDecl Name
cls [Name]
ktv_names [Located (DataFamInstDecl GhcPs)]
[LDataFamInstDecl GhcPs]
adts
; (([Located (TyFamInstDecl GhcRn)],
[Located (DataFamInstDecl GhcRn)]),
NameSet)
-> RnM
(([Located (TyFamInstDecl GhcRn)],
[Located (DataFamInstDecl GhcRn)]),
NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ( ([Located (TyFamInstDecl GhcRn)]
ats', [Located (DataFamInstDecl GhcRn)]
adts'), NameSet
at_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
adt_fvs) }
; let all_fvs :: NameSet
all_fvs = NameSet
meth_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
more_fvs
NameSet -> NameSet -> NameSet
`plusFV` NameSet
inst_fvs
; (ClsInstDecl GhcRn, NameSet) -> RnM (ClsInstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstDecl :: forall pass.
XCClsInstDecl pass
-> LHsSigType pass
-> LHsBinds pass
-> [LSig pass]
-> [LTyFamInstDecl pass]
-> [LDataFamInstDecl pass]
-> Maybe (XRec pass OverlapMode)
-> ClsInstDecl pass
ClsInstDecl { cid_ext :: XCClsInstDecl GhcRn
cid_ext = NoExtField
XCClsInstDecl GhcRn
noExtField
, cid_poly_ty :: LHsSigType GhcRn
cid_poly_ty = HsImplicitBndrs GhcRn (Located (HsType GhcRn))
LHsSigType GhcRn
inst_ty', cid_binds :: LHsBinds GhcRn
cid_binds = Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
LHsBinds GhcRn
mbinds'
, cid_sigs :: [LSig GhcRn]
cid_sigs = [Located (Sig GhcRn)]
[LSig GhcRn]
uprags', cid_tyfam_insts :: [LTyFamInstDecl GhcRn]
cid_tyfam_insts = [Located (TyFamInstDecl GhcRn)]
[LTyFamInstDecl GhcRn]
ats'
, cid_overlap_mode :: Maybe (XRec GhcRn OverlapMode)
cid_overlap_mode = Maybe (XRec GhcPs OverlapMode)
Maybe (XRec GhcRn OverlapMode)
oflag
, cid_datafam_insts :: [LDataFamInstDecl GhcRn]
cid_datafam_insts = [Located (DataFamInstDecl GhcRn)]
[LDataFamInstDecl GhcRn]
adts' },
NameSet
all_fvs) }
where
ctxt :: HsDocContext
ctxt = SDoc -> HsDocContext
GenericCtx (SDoc -> HsDocContext) -> SDoc -> HsDocContext
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"an instance declaration"
inf_err :: Maybe SDoc
inf_err = SDoc -> Maybe SDoc
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 (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ HsDocContext -> SDoc -> SDoc
withHsDocContext HsDocContext
ctxt SDoc
err_msg
Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a b. (a -> b) -> a -> b
$ OccName -> Name
mkUnboundName (CLabelString -> OccName
mkTcOccFS (String -> CLabelString
fsLit String
"<class>"))
rnFamInstEqn :: HsDocContext
-> AssocTyFamInfo
-> FreeKiTyVars
-> FamInstEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamInstEqn GhcRn rhs', FreeVars)
rnFamInstEqn :: HsDocContext
-> AssocTyFamInfo
-> [GenLocated SrcSpan RdrName]
-> FamInstEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet)
rnFamInstEqn HsDocContext
doc AssocTyFamInfo
atfi [GenLocated SrcSpan RdrName]
rhs_kvars
(HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = LIdP GhcPs
tycon
, feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> Maybe [LHsTyVarBndr () pass]
feqn_bndrs = Maybe [LHsTyVarBndr () GhcPs]
mb_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', NameSet)
rn_payload
= do { Located Name
tycon' <- Maybe Name -> GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupFamInstName Maybe Name
mb_cls GenLocated SrcSpan RdrName
LIdP GhcPs
tycon
; [GenLocated SrcSpan RdrName]
all_imp_vars <- Bool
-> [GenLocated SrcSpan RdrName] -> RnM [GenLocated SrcSpan RdrName]
forAllOrNothing (Maybe [Located (HsTyVarBndr () GhcPs)] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Located (HsTyVarBndr () GhcPs)]
Maybe [LHsTyVarBndr () GhcPs]
mb_bndrs) ([GenLocated SrcSpan RdrName] -> RnM [GenLocated SrcSpan RdrName])
-> [GenLocated SrcSpan RdrName] -> RnM [GenLocated SrcSpan RdrName]
forall a b. (a -> b) -> a -> b
$
[GenLocated SrcSpan RdrName]
pat_kity_vars_with_dups [GenLocated SrcSpan RdrName]
-> [GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpan RdrName]
rhs_kvars
; Maybe Name
-> [GenLocated SrcSpan RdrName]
-> ([Name] -> RnM (FamInstEqn GhcRn rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet)
forall assoc a.
Maybe assoc
-> [GenLocated SrcSpan RdrName]
-> ([Name] -> RnM (a, NameSet))
-> RnM (a, NameSet)
rnImplicitBndrs Maybe Name
mb_cls [GenLocated SrcSpan RdrName]
all_imp_vars (([Name] -> RnM (FamInstEqn GhcRn rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet))
-> ([Name] -> RnM (FamInstEqn GhcRn rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet)
forall a b. (a -> b) -> a -> b
$ \[Name]
all_imp_var_names' ->
HsDocContext
-> WarnUnusedForalls
-> Maybe Any
-> [LHsTyVarBndr () GhcPs]
-> ([LHsTyVarBndr () GhcRn]
-> RnM (FamInstEqn GhcRn rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet)
forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls
Maybe Any
forall a. Maybe a
Nothing ([Located (HsTyVarBndr () GhcPs)]
-> Maybe [Located (HsTyVarBndr () GhcPs)]
-> [Located (HsTyVarBndr () GhcPs)]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Located (HsTyVarBndr () GhcPs)]
Maybe [LHsTyVarBndr () GhcPs]
mb_bndrs) (([LHsTyVarBndr () GhcRn] -> RnM (FamInstEqn GhcRn rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet))
-> ([LHsTyVarBndr () GhcRn]
-> RnM (FamInstEqn GhcRn rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet)
forall a b. (a -> b) -> a -> b
$ \[LHsTyVarBndr () GhcRn]
bndrs' ->
do { ([HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn))]
pats', NameSet
pat_fvs) <- HsDocContext -> HsTyPats GhcPs -> RnM ([LHsTypeArg GhcRn], NameSet)
rnLHsTypeArgs (GenLocated SrcSpan RdrName -> HsDocContext
FamPatCtx GenLocated SrcSpan RdrName
LIdP GhcPs
tycon) HsTyPats GhcPs
pats
; (rhs'
payload', NameSet
rhs_fvs) <- HsDocContext -> rhs -> RnM (rhs', NameSet)
rn_payload HsDocContext
doc rhs
payload
; let
all_imp_var_names :: [Name]
all_imp_var_names = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> SrcSpan -> Name
`setNameLoc` SrcSpan
lhs_loc) [Name]
all_imp_var_names'
groups :: [NonEmpty (Located RdrName)]
groups :: [NonEmpty (GenLocated SrcSpan RdrName)]
groups = (GenLocated SrcSpan RdrName
-> GenLocated SrcSpan RdrName -> Ordering)
-> [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses GenLocated SrcSpan RdrName
-> GenLocated SrcSpan RdrName -> Ordering
forall a l. Ord a => GenLocated l a -> GenLocated l a -> Ordering
cmpLocated ([GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)])
-> [GenLocated SrcSpan RdrName]
-> [NonEmpty (GenLocated SrcSpan RdrName)]
forall a b. (a -> b) -> a -> b
$
[GenLocated SrcSpan RdrName]
pat_kity_vars_with_dups
; [Name]
nms_dups <- (GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupOccRn (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> (GenLocated SrcSpan RdrName -> RdrName)
-> GenLocated SrcSpan RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc) ([GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Name])
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall a b. (a -> b) -> a -> b
$
[ GenLocated SrcSpan RdrName
tv | (GenLocated SrcSpan RdrName
tv :| (GenLocated SrcSpan RdrName
_:[GenLocated SrcSpan RdrName]
_)) <- [NonEmpty (GenLocated SrcSpan RdrName)]
groups ]
; let nms_used :: NameSet
nms_used = NameSet -> [Name] -> NameSet
extendNameSetList NameSet
rhs_fvs ([Name] -> NameSet) -> [Name] -> NameSet
forall a b. (a -> b) -> a -> b
$
[Name]
inst_tvs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
nms_dups
all_nms :: [Name]
all_nms = [Name]
all_imp_var_names [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [LHsTyVarBndr () GhcRn] -> [IdP GhcRn]
forall flag (p :: Pass).
[LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]
hsLTyVarNames [LHsTyVarBndr () GhcRn]
bndrs'
; [Name] -> NameSet -> TcRn ()
warnUnusedTypePatterns [Name]
all_nms NameSet
nms_used
; let eqn_fvs :: NameSet
eqn_fvs = NameSet
rhs_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
pat_fvs
all_fvs :: NameSet
all_fvs = case AssocTyFamInfo
atfi of
NonAssocTyFamEqn ClosedTyFamInfo
ClosedTyFam
-> NameSet
eqn_fvs
AssocTyFamInfo
_ -> NameSet
eqn_fvs NameSet -> Name -> NameSet
`addOneFV` Located Name -> Name
forall l e. GenLocated l e -> e
unLoc Located Name
tycon'
; (FamInstEqn GhcRn rhs', NameSet)
-> RnM (FamInstEqn GhcRn rhs', NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsIB :: forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
HsIB { hsib_ext :: XHsIB GhcRn (FamEqn GhcRn rhs')
hsib_ext = [Name]
XHsIB GhcRn (FamEqn GhcRn rhs')
all_imp_var_names
, hsib_body :: FamEqn GhcRn rhs'
hsib_body
= FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> LIdP pass
-> Maybe [LHsTyVarBndr () pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcRn rhs'
feqn_ext = NoExtField
XCFamEqn GhcRn rhs'
noExtField
, feqn_tycon :: LIdP GhcRn
feqn_tycon = Located Name
LIdP GhcRn
tycon'
, feqn_bndrs :: Maybe [LHsTyVarBndr () GhcRn]
feqn_bndrs = [Located (HsTyVarBndr () GhcRn)]
[LHsTyVarBndr () GhcRn]
bndrs' [Located (HsTyVarBndr () GhcRn)]
-> Maybe [Located (HsTyVarBndr () GhcPs)]
-> Maybe [Located (HsTyVarBndr () GhcRn)]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe [Located (HsTyVarBndr () GhcPs)]
Maybe [LHsTyVarBndr () GhcPs]
mb_bndrs
, feqn_pats :: [LHsTypeArg GhcRn]
feqn_pats = [HsArg (Located (HsType GhcRn)) (Located (HsType GhcRn))]
[LHsTypeArg GhcRn]
pats'
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: rhs'
feqn_rhs = rhs'
payload' } },
NameSet
all_fvs) } }
where
mb_cls :: Maybe Name
mb_cls = case AssocTyFamInfo
atfi of
NonAssocTyFamEqn ClosedTyFamInfo
_ -> Maybe Name
forall a. Maybe a
Nothing
AssocTyFamDeflt Name
cls -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
cls
AssocTyFamInst Name
cls [Name]
_ -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
cls
inst_tvs :: [Name]
inst_tvs = case AssocTyFamInfo
atfi of
NonAssocTyFamEqn ClosedTyFamInfo
_ -> []
AssocTyFamDeflt Name
_ -> []
AssocTyFamInst Name
_ [Name]
inst_tvs -> [Name]
inst_tvs
pat_kity_vars_with_dups :: [GenLocated SrcSpan RdrName]
pat_kity_vars_with_dups = HsTyPats GhcPs -> [GenLocated SrcSpan RdrName]
extractHsTyArgRdrKiTyVars HsTyPats GhcPs
pats
lhs_loc :: SrcSpan
lhs_loc = case (HsArg (Located (HsType GhcPs)) (Located (HsType GhcPs))
-> SrcSpan)
-> [HsArg (Located (HsType GhcPs)) (Located (HsType GhcPs))]
-> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map HsArg (Located (HsType GhcPs)) (Located (HsType GhcPs)) -> SrcSpan
forall (pass :: Pass). LHsTypeArg (GhcPass pass) -> SrcSpan
lhsTypeArgSrcSpan [HsArg (Located (HsType GhcPs)) (Located (HsType GhcPs))]
HsTyPats GhcPs
pats [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ (GenLocated SrcSpan RdrName -> SrcSpan)
-> [GenLocated SrcSpan RdrName] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc [GenLocated SrcSpan RdrName]
rhs_kvars of
[] -> String -> SrcSpan
forall a. String -> a
panic String
"rnFamInstEqn.lhs_loc"
[SrcSpan
loc] -> SrcSpan
loc
(SrcSpan
loc:[SrcSpan]
locs) -> SrcSpan
loc SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` [SrcSpan] -> SrcSpan
forall a. [a] -> a
last [SrcSpan]
locs
rnTyFamInstDecl :: AssocTyFamInfo
-> TyFamInstDecl GhcPs
-> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl :: AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet)
rnTyFamInstDecl AssocTyFamInfo
atfi (TyFamInstDecl { tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn = TyFamInstEqn GhcPs
eqn })
= do { (FamInstEqn GhcRn (Located (HsType GhcRn))
eqn', NameSet
fvs) <- AssocTyFamInfo
-> TyFamInstEqn GhcPs -> RnM (TyFamInstEqn GhcRn, NameSet)
rnTyFamInstEqn AssocTyFamInfo
atfi TyFamInstEqn GhcPs
eqn
; (TyFamInstDecl GhcRn, NameSet)
-> RnM (TyFamInstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyFamInstDecl :: forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl { tfid_eqn :: TyFamInstEqn GhcRn
tfid_eqn = FamInstEqn GhcRn (Located (HsType GhcRn))
TyFamInstEqn GhcRn
eqn' }, NameSet
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, NameSet)
rnTyFamInstEqn AssocTyFamInfo
atfi
eqn :: TyFamInstEqn GhcPs
eqn@(HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = LIdP GhcPs
tycon
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = LHsType GhcPs
rhs }})
= HsDocContext
-> AssocTyFamInfo
-> [GenLocated SrcSpan RdrName]
-> FamInstEqn GhcPs (Located (HsType GhcPs))
-> (HsDocContext
-> Located (HsType GhcPs) -> RnM (Located (HsType GhcRn), NameSet))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(FamInstEqn GhcRn (Located (HsType GhcRn)), NameSet)
forall rhs rhs'.
HsDocContext
-> AssocTyFamInfo
-> [GenLocated SrcSpan RdrName]
-> FamInstEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet)
rnFamInstEqn (GenLocated SrcSpan RdrName -> HsDocContext
TySynCtx GenLocated SrcSpan RdrName
LIdP GhcPs
tycon) AssocTyFamInfo
atfi [GenLocated SrcSpan RdrName]
rhs_kvs FamInstEqn GhcPs (Located (HsType GhcPs))
TyFamInstEqn GhcPs
eqn HsDocContext
-> Located (HsType GhcPs) -> RnM (Located (HsType GhcRn), NameSet)
HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnTySyn
where
rhs_kvs :: [GenLocated SrcSpan RdrName]
rhs_kvs = LHsType GhcPs -> [GenLocated SrcSpan RdrName]
extractHsTyRdrTyVarsKindVars LHsType GhcPs
rhs
rnTyFamDefltDecl :: Name
-> TyFamDefltDecl GhcPs
-> RnM (TyFamDefltDecl GhcRn, FreeVars)
rnTyFamDefltDecl :: Name -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet)
rnTyFamDefltDecl Name
cls = AssocTyFamInfo
-> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet)
rnTyFamInstDecl (Name -> AssocTyFamInfo
AssocTyFamDeflt Name
cls)
rnDataFamInstDecl :: AssocTyFamInfo
-> DataFamInstDecl GhcPs
-> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl :: AssocTyFamInfo
-> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, NameSet)
rnDataFamInstDecl AssocTyFamInfo
atfi (DataFamInstDecl { dfid_eqn :: forall pass.
DataFamInstDecl pass -> FamInstEqn pass (HsDataDefn pass)
dfid_eqn = eqn :: FamInstEqn GhcPs (HsDataDefn GhcPs)
eqn@(HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body =
FamEqn { feqn_tycon :: forall pass 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 rhs_kvs :: [GenLocated SrcSpan RdrName]
rhs_kvs = HsDataDefn GhcPs -> [GenLocated SrcSpan RdrName]
extractDataDefnKindVars HsDataDefn GhcPs
rhs
; (FamInstEqn GhcRn (HsDataDefn GhcRn)
eqn', NameSet
fvs) <-
HsDocContext
-> AssocTyFamInfo
-> [GenLocated SrcSpan RdrName]
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
-> (HsDocContext
-> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, NameSet))
-> RnM (FamInstEqn GhcRn (HsDataDefn GhcRn), NameSet)
forall rhs rhs'.
HsDocContext
-> AssocTyFamInfo
-> [GenLocated SrcSpan RdrName]
-> FamInstEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', NameSet))
-> RnM (FamInstEqn GhcRn rhs', NameSet)
rnFamInstEqn (GenLocated SrcSpan RdrName -> HsDocContext
TyDataCtx GenLocated SrcSpan RdrName
LIdP GhcPs
tycon) AssocTyFamInfo
atfi [GenLocated SrcSpan RdrName]
rhs_kvs FamInstEqn GhcPs (HsDataDefn GhcPs)
eqn HsDocContext -> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, NameSet)
rnDataDefn
; (DataFamInstDecl GhcRn, NameSet)
-> RnM (DataFamInstDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataFamInstDecl :: forall pass.
FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass
DataFamInstDecl { dfid_eqn :: FamInstEqn GhcRn (HsDataDefn GhcRn)
dfid_eqn = FamInstEqn GhcRn (HsDataDefn GhcRn)
eqn' }, NameSet
fvs) }
rnATDecls :: Name
-> [LFamilyDecl GhcPs]
-> RnM ([LFamilyDecl GhcRn], FreeVars)
rnATDecls :: Name -> [LFamilyDecl GhcPs] -> RnM ([LFamilyDecl GhcRn], NameSet)
rnATDecls Name
cls [LFamilyDecl GhcPs]
at_decls
= (FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, NameSet))
-> [Located (FamilyDecl GhcPs)]
-> RnM ([Located (FamilyDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList (Maybe Name -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, NameSet)
rnFamDecl (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
cls)) [Located (FamilyDecl GhcPs)]
[LFamilyDecl GhcPs]
at_decls
rnATInstDecls :: (AssocTyFamInfo ->
decl GhcPs ->
RnM (decl GhcRn, FreeVars))
-> Name
-> [Name]
-> [Located (decl GhcPs)]
-> RnM ([Located (decl GhcRn)], FreeVars)
rnATInstDecls :: (AssocTyFamInfo -> decl GhcPs -> RnM (decl GhcRn, NameSet))
-> Name
-> [Name]
-> [Located (decl GhcPs)]
-> RnM ([Located (decl GhcRn)], NameSet)
rnATInstDecls AssocTyFamInfo -> decl GhcPs -> RnM (decl GhcRn, NameSet)
rnFun Name
cls [Name]
tv_ns [Located (decl GhcPs)]
at_insts
= (decl GhcPs -> RnM (decl GhcRn, NameSet))
-> [Located (decl GhcPs)] -> RnM ([Located (decl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList (AssocTyFamInfo -> decl GhcPs -> RnM (decl GhcRn, NameSet)
rnFun (Name -> [Name] -> AssocTyFamInfo
AssocTyFamInst Name
cls [Name]
tv_ns)) [Located (decl GhcPs)]
at_insts
rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, NameSet)
rnSrcDerivDecl (DerivDecl XCDerivDecl GhcPs
_ LHsSigWcType GhcPs
ty Maybe (LDerivStrategy GhcPs)
mds Maybe (XRec GhcPs OverlapMode)
overlap)
= do { Bool
standalone_deriv_ok <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.StandaloneDeriving
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
standalone_deriv_ok (SDoc -> TcRn ()
addErr SDoc
standaloneDerivErr)
; HsDocContext -> Maybe SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
ctxt Maybe SDoc
inf_err LHsSigType GhcPs
nowc_ty
; (Maybe (Located (DerivStrategy GhcRn))
mds', HsWildCardBndrs
GhcRn (HsImplicitBndrs GhcRn (Located (HsType GhcRn)))
ty', NameSet
fvs) <- HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM
(HsWildCardBndrs
GhcRn (HsImplicitBndrs GhcRn (Located (HsType GhcRn))),
NameSet)
-> RnM
(Maybe (LDerivStrategy GhcRn),
HsWildCardBndrs
GhcRn (HsImplicitBndrs GhcRn (Located (HsType GhcRn))),
NameSet)
forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, NameSet)
-> RnM (Maybe (LDerivStrategy GhcRn), a, NameSet)
rnLDerivStrategy HsDocContext
ctxt Maybe (LDerivStrategy GhcPs)
mds (RnM
(HsWildCardBndrs
GhcRn (HsImplicitBndrs GhcRn (Located (HsType GhcRn))),
NameSet)
-> RnM
(Maybe (LDerivStrategy GhcRn),
HsWildCardBndrs
GhcRn (HsImplicitBndrs GhcRn (Located (HsType GhcRn))),
NameSet))
-> RnM
(HsWildCardBndrs
GhcRn (HsImplicitBndrs GhcRn (Located (HsType GhcRn))),
NameSet)
-> RnM
(Maybe (LDerivStrategy GhcRn),
HsWildCardBndrs
GhcRn (HsImplicitBndrs GhcRn (Located (HsType GhcRn))),
NameSet)
forall a b. (a -> b) -> a -> b
$ HsDocContext
-> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, NameSet)
rnHsSigWcType HsDocContext
ctxt LHsSigWcType GhcPs
ty
; HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
ctxt
(String -> SDoc
text String
"Standalone-derived instance head")
(LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead (LHsSigType GhcRn -> LHsType GhcRn)
-> LHsSigType GhcRn -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ LHsSigWcType GhcRn -> LHsSigType GhcRn
forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards HsWildCardBndrs
GhcRn (HsImplicitBndrs GhcRn (Located (HsType GhcRn)))
LHsSigWcType GhcRn
ty')
; Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (Located (DerivStrategy GhcRn))
Maybe (LDerivStrategy GhcRn)
mds' SrcSpan
loc
; (DerivDecl GhcRn, NameSet) -> RnM (DerivDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCDerivDecl GhcRn
-> LHsSigWcType GhcRn
-> Maybe (LDerivStrategy GhcRn)
-> Maybe (XRec GhcRn OverlapMode)
-> DerivDecl GhcRn
forall pass.
XCDerivDecl pass
-> LHsSigWcType pass
-> Maybe (LDerivStrategy pass)
-> Maybe (XRec pass OverlapMode)
-> DerivDecl pass
DerivDecl NoExtField
XCDerivDecl GhcRn
noExtField HsWildCardBndrs
GhcRn (HsImplicitBndrs GhcRn (Located (HsType GhcRn)))
LHsSigWcType GhcRn
ty' Maybe (Located (DerivStrategy GhcRn))
Maybe (LDerivStrategy GhcRn)
mds' Maybe (XRec GhcPs OverlapMode)
Maybe (XRec GhcRn OverlapMode)
overlap, NameSet
fvs) }
where
ctxt :: HsDocContext
ctxt = HsDocContext
DerivDeclCtx
inf_err :: Maybe SDoc
inf_err = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
"Inferred type variables are not allowed")
loc :: SrcSpan
loc = Located (HsType GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (Located (HsType GhcPs) -> SrcSpan)
-> Located (HsType GhcPs) -> SrcSpan
forall a b. (a -> b) -> a -> b
$ HsImplicitBndrs GhcPs (Located (HsType GhcPs))
-> Located (HsType GhcPs)
forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body HsImplicitBndrs GhcPs (Located (HsType GhcPs))
LHsSigType GhcPs
nowc_ty
nowc_ty :: LHsSigType GhcPs
nowc_ty = LHsSigWcType GhcPs -> LHsSigType GhcPs
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, NameSet)
rnHsRuleDecls (HsRules { rds_src :: forall pass. RuleDecls pass -> SourceText
rds_src = SourceText
src
, rds_rules :: forall pass. RuleDecls pass -> [LRuleDecl pass]
rds_rules = [LRuleDecl GhcPs]
rules })
= do { ([Located (RuleDecl GhcRn)]
rn_rules,NameSet
fvs) <- (RuleDecl GhcPs -> RnM (RuleDecl GhcRn, NameSet))
-> [Located (RuleDecl GhcPs)]
-> RnM ([Located (RuleDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList RuleDecl GhcPs -> RnM (RuleDecl GhcRn, NameSet)
rnHsRuleDecl [Located (RuleDecl GhcPs)]
[LRuleDecl GhcPs]
rules
; (RuleDecls GhcRn, NameSet) -> RnM (RuleDecls GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsRules :: forall pass.
XCRuleDecls pass
-> SourceText -> [LRuleDecl pass] -> RuleDecls pass
HsRules { rds_ext :: XCRuleDecls GhcRn
rds_ext = NoExtField
XCRuleDecls GhcRn
noExtField
, rds_src :: SourceText
rds_src = SourceText
src
, rds_rules :: [LRuleDecl GhcRn]
rds_rules = [Located (RuleDecl GhcRn)]
[LRuleDecl GhcRn]
rn_rules }, NameSet
fvs) }
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, NameSet)
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 SrcSpan RdrName]
rdr_names_w_loc = (GenLocated SrcSpan (RuleBndr GhcPs) -> GenLocated SrcSpan RdrName)
-> [GenLocated SrcSpan (RuleBndr GhcPs)]
-> [GenLocated SrcSpan RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (RuleBndr GhcPs -> GenLocated SrcSpan RdrName
get_var (RuleBndr GhcPs -> GenLocated SrcSpan RdrName)
-> (GenLocated SrcSpan (RuleBndr GhcPs) -> RuleBndr GhcPs)
-> GenLocated SrcSpan (RuleBndr GhcPs)
-> GenLocated SrcSpan RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan (RuleBndr GhcPs) -> RuleBndr GhcPs
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpan (RuleBndr GhcPs)]
[LRuleBndr GhcPs]
tmvs
; [GenLocated SrcSpan RdrName] -> TcRn ()
checkDupRdrNames [GenLocated SrcSpan RdrName]
rdr_names_w_loc
; [GenLocated SrcSpan RdrName] -> TcRn ()
checkShadowedRdrNames [GenLocated SrcSpan RdrName]
rdr_names_w_loc
; [Name]
names <- [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Name]
newLocalBndrsRn [GenLocated SrcSpan RdrName]
rdr_names_w_loc
; let doc :: HsDocContext
doc = CLabelString -> HsDocContext
RuleCtx ((SourceText, CLabelString) -> CLabelString
forall a b. (a, b) -> b
snd ((SourceText, CLabelString) -> CLabelString)
-> (SourceText, CLabelString) -> CLabelString
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan (SourceText, CLabelString)
-> (SourceText, CLabelString)
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (SourceText, CLabelString)
XRec GhcPs (SourceText, CLabelString)
rule_name)
; HsDocContext
-> Maybe [LHsTyVarBndr () GhcPs]
-> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
-> RnM (RuleDecl GhcRn, NameSet)
forall b.
HsDocContext
-> Maybe [LHsTyVarBndr () GhcPs]
-> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindRuleTyVars HsDocContext
doc Maybe [LHsTyVarBndr () GhcPs]
Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
tyvs ((Maybe [LHsTyVarBndr () GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
-> RnM (RuleDecl GhcRn, NameSet))
-> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
-> RnM (RuleDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ Maybe [LHsTyVarBndr () GhcRn]
tyvs' ->
HsDocContext
-> Maybe [Located (HsTyVarBndr () GhcRn)]
-> [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
-> RnM (RuleDecl GhcRn, NameSet)
forall ty_bndrs a.
HsDocContext
-> Maybe ty_bndrs
-> [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, NameSet))
-> RnM (a, NameSet)
bindRuleTmVars HsDocContext
doc Maybe [Located (HsTyVarBndr () GhcRn)]
Maybe [LHsTyVarBndr () GhcRn]
tyvs' [LRuleBndr GhcPs]
tmvs [Name]
names (([LRuleBndr GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
-> RnM (RuleDecl GhcRn, NameSet))
-> ([LRuleBndr GhcRn] -> RnM (RuleDecl GhcRn, NameSet))
-> RnM (RuleDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ [LRuleBndr GhcRn]
tmvs' ->
do { (Located (HsExpr GhcRn)
lhs', NameSet
fv_lhs') <- XRec GhcPs (HsExpr GhcPs) -> RnM (LHsExpr GhcRn, NameSet)
rnLExpr XRec GhcPs (HsExpr GhcPs)
lhs
; (Located (HsExpr GhcRn)
rhs', NameSet
fv_rhs') <- XRec GhcPs (HsExpr GhcPs) -> RnM (LHsExpr GhcRn, NameSet)
rnLExpr XRec GhcPs (HsExpr GhcPs)
rhs
; CLabelString -> [Name] -> LHsExpr GhcRn -> NameSet -> TcRn ()
checkValidRule ((SourceText, CLabelString) -> CLabelString
forall a b. (a, b) -> b
snd ((SourceText, CLabelString) -> CLabelString)
-> (SourceText, CLabelString) -> CLabelString
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan (SourceText, CLabelString)
-> (SourceText, CLabelString)
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (SourceText, CLabelString)
XRec GhcPs (SourceText, CLabelString)
rule_name) [Name]
names Located (HsExpr GhcRn)
LHsExpr GhcRn
lhs' NameSet
fv_lhs'
; (RuleDecl GhcRn, NameSet) -> RnM (RuleDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsRule :: forall pass.
XHsRule pass
-> XRec pass (SourceText, CLabelString)
-> Activation
-> Maybe [LHsTyVarBndr () (NoGhcTc pass)]
-> [LRuleBndr pass]
-> XRec pass (HsExpr pass)
-> XRec pass (HsExpr pass)
-> RuleDecl pass
HsRule { rd_ext :: XHsRule GhcRn
rd_ext = NameSet -> NameSet -> HsRuleRn
HsRuleRn NameSet
fv_lhs' NameSet
fv_rhs'
, rd_name :: XRec GhcRn (SourceText, CLabelString)
rd_name = XRec GhcPs (SourceText, CLabelString)
XRec GhcRn (SourceText, CLabelString)
rule_name
, rd_act :: Activation
rd_act = Activation
act
, rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc GhcRn)]
rd_tyvs = Maybe [LHsTyVarBndr () GhcRn]
Maybe [LHsTyVarBndr () (NoGhcTc GhcRn)]
tyvs'
, rd_tmvs :: [LRuleBndr GhcRn]
rd_tmvs = [LRuleBndr GhcRn]
tmvs'
, rd_lhs :: LHsExpr GhcRn
rd_lhs = Located (HsExpr GhcRn)
LHsExpr GhcRn
lhs'
, rd_rhs :: LHsExpr GhcRn
rd_rhs = Located (HsExpr GhcRn)
LHsExpr GhcRn
rhs' }, NameSet
fv_lhs' NameSet -> NameSet -> NameSet
`plusFV` NameSet
fv_rhs') } }
where
get_var :: RuleBndr GhcPs -> Located RdrName
get_var :: RuleBndr GhcPs -> GenLocated SrcSpan RdrName
get_var (RuleBndrSig XRuleBndrSig GhcPs
_ LIdP GhcPs
v HsPatSigType GhcPs
_) = GenLocated SrcSpan RdrName
LIdP GhcPs
v
get_var (RuleBndr XCRuleBndr GhcPs
_ LIdP GhcPs
v) = GenLocated SrcSpan RdrName
LIdP GhcPs
v
bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
-> [LRuleBndr GhcPs] -> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindRuleTmVars :: HsDocContext
-> Maybe ty_bndrs
-> [LRuleBndr GhcPs]
-> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, NameSet))
-> RnM (a, NameSet)
bindRuleTmVars HsDocContext
doc Maybe ty_bndrs
tyvs [LRuleBndr GhcPs]
vars [Name]
names [LRuleBndr GhcRn] -> RnM (a, NameSet)
thing_inside
= [GenLocated SrcSpan (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet))
-> RnM (a, NameSet)
go [GenLocated SrcSpan (RuleBndr GhcPs)]
[LRuleBndr GhcPs]
vars [Name]
names (([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet))
-> RnM (a, NameSet))
-> ([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet))
-> RnM (a, NameSet)
forall a b. (a -> b) -> a -> b
$ \ [GenLocated SrcSpan (RuleBndr GhcRn)]
vars' ->
[Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
bindLocalNamesFV [Name]
names ([LRuleBndr GhcRn] -> RnM (a, NameSet)
thing_inside [GenLocated SrcSpan (RuleBndr GhcRn)]
[LRuleBndr GhcRn]
vars')
where
go :: [GenLocated SrcSpan (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet))
-> RnM (a, NameSet)
go ((L SrcSpan
l (RuleBndr XCRuleBndr GhcPs
_ (L loc _))) : [GenLocated SrcSpan (RuleBndr GhcPs)]
vars) (Name
n : [Name]
ns) [GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet)
thing_inside
= [GenLocated SrcSpan (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet))
-> RnM (a, NameSet)
go [GenLocated SrcSpan (RuleBndr GhcPs)]
vars [Name]
ns (([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet))
-> RnM (a, NameSet))
-> ([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet))
-> RnM (a, NameSet)
forall a b. (a -> b) -> a -> b
$ \ [GenLocated SrcSpan (RuleBndr GhcRn)]
vars' ->
[GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet)
thing_inside (SrcSpan -> RuleBndr GhcRn -> GenLocated SrcSpan (RuleBndr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XCRuleBndr GhcRn -> LIdP GhcRn -> RuleBndr GhcRn
forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass
RuleBndr NoExtField
XCRuleBndr GhcRn
noExtField (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
n)) GenLocated SrcSpan (RuleBndr GhcRn)
-> [GenLocated SrcSpan (RuleBndr GhcRn)]
-> [GenLocated SrcSpan (RuleBndr GhcRn)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpan (RuleBndr GhcRn)]
vars')
go ((L SrcSpan
l (RuleBndrSig XRuleBndrSig GhcPs
_ (L loc _) HsPatSigType GhcPs
bsig)) : [GenLocated SrcSpan (RuleBndr GhcPs)]
vars)
(Name
n : [Name]
ns) [GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet)
thing_inside
= HsSigWcTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, NameSet))
-> RnM (a, NameSet)
forall a.
HsSigWcTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, NameSet))
-> RnM (a, NameSet)
rnHsPatSigType HsSigWcTypeScoping
bind_free_tvs HsDocContext
doc HsPatSigType GhcPs
bsig ((HsPatSigType GhcRn -> RnM (a, NameSet)) -> RnM (a, NameSet))
-> (HsPatSigType GhcRn -> RnM (a, NameSet)) -> RnM (a, NameSet)
forall a b. (a -> b) -> a -> b
$ \ HsPatSigType GhcRn
bsig' ->
[GenLocated SrcSpan (RuleBndr GhcPs)]
-> [Name]
-> ([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet))
-> RnM (a, NameSet)
go [GenLocated SrcSpan (RuleBndr GhcPs)]
vars [Name]
ns (([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet))
-> RnM (a, NameSet))
-> ([GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet))
-> RnM (a, NameSet)
forall a b. (a -> b) -> a -> b
$ \ [GenLocated SrcSpan (RuleBndr GhcRn)]
vars' ->
[GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet)
thing_inside (SrcSpan -> RuleBndr GhcRn -> GenLocated SrcSpan (RuleBndr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XRuleBndrSig GhcRn
-> LIdP GhcRn -> HsPatSigType GhcRn -> RuleBndr GhcRn
forall pass.
XRuleBndrSig pass
-> LIdP pass -> HsPatSigType pass -> RuleBndr pass
RuleBndrSig NoExtField
XRuleBndrSig GhcRn
noExtField (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
n) HsPatSigType GhcRn
bsig') GenLocated SrcSpan (RuleBndr GhcRn)
-> [GenLocated SrcSpan (RuleBndr GhcRn)]
-> [GenLocated SrcSpan (RuleBndr GhcRn)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpan (RuleBndr GhcRn)]
vars')
go [] [] [GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet)
thing_inside = [GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet)
thing_inside []
go [GenLocated SrcSpan (RuleBndr GhcPs)]
vars [Name]
names [GenLocated SrcSpan (RuleBndr GhcRn)] -> RnM (a, NameSet)
_ = String -> SDoc -> RnM (a, NameSet)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"bindRuleVars" ([GenLocated SrcSpan (RuleBndr GhcPs)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan (RuleBndr GhcPs)]
vars SDoc -> SDoc -> SDoc
$$ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
names)
bind_free_tvs :: HsSigWcTypeScoping
bind_free_tvs = case Maybe ty_bndrs
tyvs of Maybe ty_bndrs
Nothing -> HsSigWcTypeScoping
AlwaysBind
Just ty_bndrs
_ -> HsSigWcTypeScoping
NeverBind
bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs]
-> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindRuleTyVars :: HsDocContext
-> Maybe [LHsTyVarBndr () GhcPs]
-> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindRuleTyVars HsDocContext
doc (Just [LHsTyVarBndr () GhcPs]
bndrs) Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, NameSet)
thing_inside
= HsDocContext
-> WarnUnusedForalls
-> Maybe Any
-> [LHsTyVarBndr () GhcPs]
-> ([LHsTyVarBndr () GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr () GhcPs]
bndrs (Maybe [Located (HsTyVarBndr () GhcRn)] -> RnM (b, NameSet)
Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, NameSet)
thing_inside (Maybe [Located (HsTyVarBndr () GhcRn)] -> RnM (b, NameSet))
-> ([Located (HsTyVarBndr () GhcRn)]
-> Maybe [Located (HsTyVarBndr () GhcRn)])
-> [Located (HsTyVarBndr () GhcRn)]
-> RnM (b, NameSet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Located (HsTyVarBndr () GhcRn)]
-> Maybe [Located (HsTyVarBndr () GhcRn)]
forall a. a -> Maybe a
Just)
bindRuleTyVars HsDocContext
_ Maybe [LHsTyVarBndr () GhcPs]
_ Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, NameSet)
thing_inside = Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, NameSet)
thing_inside Maybe [LHsTyVarBndr () GhcRn]
forall a. Maybe a
Nothing
checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
checkValidRule :: CLabelString -> [Name] -> LHsExpr GhcRn -> NameSet -> TcRn ()
checkValidRule CLabelString
rule_name [Name]
ids LHsExpr GhcRn
lhs' NameSet
fv_lhs'
= do {
case ([Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
validRuleLhs [Name]
ids LHsExpr GhcRn
lhs') of
Maybe (HsExpr GhcRn)
Nothing -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just HsExpr GhcRn
bad -> SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc (CLabelString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
badRuleLhsErr CLabelString
rule_name LHsExpr GhcRn
lhs' HsExpr GhcRn
bad)
; let bad_vars :: [Name]
bad_vars = [Name
var | Name
var <- [Name]
ids, Bool -> Bool
not (Name
var Name -> NameSet -> Bool
`elemNameSet` NameSet
fv_lhs')]
; (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> TcRn ()
addErr (SDoc -> TcRn ()) -> (Name -> SDoc) -> Name -> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLabelString -> Name -> SDoc
badRuleVar CLabelString
rule_name) [Name]
bad_vars }
validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
validRuleLhs [Name]
foralls LHsExpr GhcRn
lhs
= Located (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl Located (HsExpr GhcRn)
LHsExpr GhcRn
lhs
where
checkl :: Located (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl = HsExpr GhcRn -> Maybe (HsExpr GhcRn)
check (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> (Located (HsExpr GhcRn) -> HsExpr GhcRn)
-> Located (HsExpr GhcRn)
-> Maybe (HsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc
check :: HsExpr GhcRn -> Maybe (HsExpr GhcRn)
check (OpApp XOpApp GhcRn
_ LHsExpr GhcRn
e1 LHsExpr GhcRn
op LHsExpr GhcRn
e2) = Located (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl Located (HsExpr GhcRn)
LHsExpr GhcRn
op Maybe (HsExpr GhcRn)
-> Maybe (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Located (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall p a. p -> Maybe a
checkl_e Located (HsExpr GhcRn)
LHsExpr GhcRn
e1
Maybe (HsExpr GhcRn)
-> Maybe (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Located (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall p a. p -> Maybe a
checkl_e Located (HsExpr GhcRn)
LHsExpr GhcRn
e2
check (HsApp XApp GhcRn
_ LHsExpr GhcRn
e1 LHsExpr GhcRn
e2) = Located (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl Located (HsExpr GhcRn)
LHsExpr GhcRn
e1 Maybe (HsExpr GhcRn)
-> Maybe (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Located (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
forall p a. p -> Maybe a
checkl_e Located (HsExpr GhcRn)
LHsExpr GhcRn
e2
check (HsAppType XAppTypeE GhcRn
_ LHsExpr GhcRn
e LHsWcType (NoGhcTc GhcRn)
_) = Located (HsExpr GhcRn) -> Maybe (HsExpr GhcRn)
checkl Located (HsExpr GhcRn)
LHsExpr GhcRn
e
check (HsVar XVar GhcRn
_ LIdP GhcRn
lv)
| (Located Name -> Name
forall l e. GenLocated l e -> e
unLoc Located Name
LIdP GhcRn
lv) Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
foralls = Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing
check HsExpr GhcRn
other = HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
other
checkl_e :: p -> Maybe a
checkl_e p
_ = Maybe a
forall a. Maybe a
Nothing
badRuleVar :: FastString -> Name -> 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 (Name -> SDoc
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
<+> Located (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (HsExpr GhcRn)
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
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
bad_e
rnTyClDecls :: [TyClGroup GhcPs]
-> RnM ([TyClGroup GhcRn], FreeVars)
rnTyClDecls :: [TyClGroup GhcPs] -> RnM ([TyClGroup GhcRn], NameSet)
rnTyClDecls [TyClGroup GhcPs]
tycl_ds
= do {
; [(Located (TyClDecl GhcRn), NameSet)]
tycls_w_fvs <- (Located (TyClDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Located (TyClDecl GhcRn), NameSet))
-> [Located (TyClDecl GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [(Located (TyClDecl GhcRn), NameSet)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TyClDecl GhcPs -> TcM (TyClDecl GhcRn, NameSet))
-> Located (TyClDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Located (TyClDecl GhcRn), NameSet)
forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM TyClDecl GhcPs -> TcM (TyClDecl GhcRn, NameSet)
rnTyClDecl) ([TyClGroup GhcPs] -> [LTyClDecl GhcPs]
forall pass. [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls [TyClGroup GhcPs]
tycl_ds)
; let tc_names :: NameSet
tc_names = [Name] -> NameSet
mkNameSet (((Located (TyClDecl GhcRn), NameSet) -> Name)
-> [(Located (TyClDecl GhcRn), NameSet)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyClDecl GhcRn -> Name
forall (p :: Pass). TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (TyClDecl GhcRn -> Name)
-> ((Located (TyClDecl GhcRn), NameSet) -> TyClDecl GhcRn)
-> (Located (TyClDecl GhcRn), NameSet)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc (Located (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> ((Located (TyClDecl GhcRn), NameSet)
-> Located (TyClDecl GhcRn))
-> (Located (TyClDecl GhcRn), NameSet)
-> TyClDecl GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located (TyClDecl GhcRn), NameSet) -> Located (TyClDecl GhcRn)
forall a b. (a, b) -> a
fst) [(Located (TyClDecl GhcRn), NameSet)]
tycls_w_fvs)
; [(Located (StandaloneKindSig GhcRn), NameSet)]
kisigs_w_fvs <- NameSet
-> [LStandaloneKindSig GhcPs]
-> RnM [(LStandaloneKindSig GhcRn, NameSet)]
rnStandaloneKindSignatures NameSet
tc_names ([TyClGroup GhcPs] -> [LStandaloneKindSig GhcPs]
forall pass. [TyClGroup pass] -> [LStandaloneKindSig pass]
tyClGroupKindSigs [TyClGroup GhcPs]
tycl_ds)
; [(Located (InstDecl GhcRn), NameSet)]
instds_w_fvs <- (Located (InstDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Located (InstDecl GhcRn), NameSet))
-> [Located (InstDecl GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [(Located (InstDecl GhcRn), NameSet)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((InstDecl GhcPs -> RnM (InstDecl GhcRn, NameSet))
-> Located (InstDecl GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Located (InstDecl GhcRn), NameSet)
forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM InstDecl GhcPs -> RnM (InstDecl GhcRn, NameSet)
rnSrcInstDecl) ([TyClGroup GhcPs] -> [LInstDecl GhcPs]
forall pass. [TyClGroup pass] -> [LInstDecl pass]
tyClGroupInstDecls [TyClGroup GhcPs]
tycl_ds)
; [Located (RoleAnnotDecl GhcRn)]
role_annots <- NameSet -> [LRoleAnnotDecl GhcPs] -> RnM [LRoleAnnotDecl GhcRn]
rnRoleAnnots NameSet
tc_names ([TyClGroup GhcPs] -> [LRoleAnnotDecl GhcPs]
forall pass. [TyClGroup pass] -> [LRoleAnnotDecl pass]
tyClGroupRoleDecls [TyClGroup GhcPs]
tycl_ds)
; GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; let tycl_sccs :: [SCC (LTyClDecl GhcRn)]
tycl_sccs = GlobalRdrEnv
-> KindSig_FV_Env
-> [(LTyClDecl GhcRn, NameSet)]
-> [SCC (LTyClDecl GhcRn)]
depAnalTyClDecls GlobalRdrEnv
rdr_env KindSig_FV_Env
kisig_fv_env [(Located (TyClDecl GhcRn), NameSet)]
[(LTyClDecl GhcRn, NameSet)]
tycls_w_fvs
role_annot_env :: RoleAnnotEnv
role_annot_env = [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv
mkRoleAnnotEnv [Located (RoleAnnotDecl GhcRn)]
[LRoleAnnotDecl GhcRn]
role_annots
(NameEnv (Located (StandaloneKindSig GhcRn))
kisig_env, KindSig_FV_Env
kisig_fv_env) = [(LStandaloneKindSig GhcRn, NameSet)]
-> (KindSigEnv, KindSig_FV_Env)
mkKindSig_fv_env [(Located (StandaloneKindSig GhcRn), NameSet)]
[(LStandaloneKindSig GhcRn, NameSet)]
kisigs_w_fvs
inst_ds_map :: InstDeclFreeVarsMap
inst_ds_map = GlobalRdrEnv
-> NameSet -> InstDeclFreeVarsMap -> InstDeclFreeVarsMap
mkInstDeclFreeVarsMap GlobalRdrEnv
rdr_env NameSet
tc_names [(Located (InstDecl GhcRn), NameSet)]
InstDeclFreeVarsMap
instds_w_fvs
([Located (InstDecl GhcRn)]
init_inst_ds, [(Located (InstDecl GhcRn), NameSet)]
rest_inst_ds) = [Name]
-> InstDeclFreeVarsMap -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts [] InstDeclFreeVarsMap
inst_ds_map
first_group :: [TyClGroup GhcRn]
first_group
| [Located (InstDecl GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (InstDecl GhcRn)]
init_inst_ds = []
| Bool
otherwise = [TyClGroup :: forall pass.
XCTyClGroup pass
-> [LTyClDecl pass]
-> [LRoleAnnotDecl pass]
-> [LStandaloneKindSig pass]
-> [LInstDecl pass]
-> TyClGroup pass
TyClGroup { group_ext :: XCTyClGroup GhcRn
group_ext = NoExtField
XCTyClGroup GhcRn
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 = [Located (InstDecl GhcRn)]
[LInstDecl GhcRn]
init_inst_ds }]
([(Located (InstDecl GhcRn), NameSet)]
final_inst_ds, [TyClGroup GhcRn]
groups)
= ([(Located (InstDecl GhcRn), NameSet)]
-> SCC (Located (TyClDecl GhcRn))
-> ([(Located (InstDecl GhcRn), NameSet)], TyClGroup GhcRn))
-> [(Located (InstDecl GhcRn), NameSet)]
-> [SCC (Located (TyClDecl GhcRn))]
-> ([(Located (InstDecl GhcRn), NameSet)], [TyClGroup GhcRn])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (RoleAnnotEnv
-> KindSigEnv
-> InstDeclFreeVarsMap
-> SCC (LTyClDecl GhcRn)
-> (InstDeclFreeVarsMap, TyClGroup GhcRn)
mk_group RoleAnnotEnv
role_annot_env NameEnv (Located (StandaloneKindSig GhcRn))
KindSigEnv
kisig_env) [(Located (InstDecl GhcRn), NameSet)]
rest_inst_ds [SCC (Located (TyClDecl GhcRn))]
[SCC (LTyClDecl GhcRn)]
tycl_sccs
all_fvs :: NameSet
all_fvs = ((Located (TyClDecl GhcRn), NameSet) -> NameSet -> NameSet)
-> NameSet -> [(Located (TyClDecl GhcRn), NameSet)] -> NameSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameSet -> NameSet -> NameSet
plusFV (NameSet -> NameSet -> NameSet)
-> ((Located (TyClDecl GhcRn), NameSet) -> NameSet)
-> (Located (TyClDecl GhcRn), NameSet)
-> NameSet
-> NameSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located (TyClDecl GhcRn), NameSet) -> NameSet
forall a b. (a, b) -> b
snd) NameSet
emptyFVs [(Located (TyClDecl GhcRn), NameSet)]
tycls_w_fvs NameSet -> NameSet -> NameSet
`plusFV`
((Located (InstDecl GhcRn), NameSet) -> NameSet -> NameSet)
-> NameSet -> [(Located (InstDecl GhcRn), NameSet)] -> NameSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameSet -> NameSet -> NameSet
plusFV (NameSet -> NameSet -> NameSet)
-> ((Located (InstDecl GhcRn), NameSet) -> NameSet)
-> (Located (InstDecl GhcRn), NameSet)
-> NameSet
-> NameSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located (InstDecl GhcRn), NameSet) -> NameSet
forall a b. (a, b) -> b
snd) NameSet
emptyFVs [(Located (InstDecl GhcRn), NameSet)]
instds_w_fvs NameSet -> NameSet -> NameSet
`plusFV`
((Located (StandaloneKindSig GhcRn), NameSet)
-> NameSet -> NameSet)
-> NameSet
-> [(Located (StandaloneKindSig GhcRn), NameSet)]
-> NameSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameSet -> NameSet -> NameSet
plusFV (NameSet -> NameSet -> NameSet)
-> ((Located (StandaloneKindSig GhcRn), NameSet) -> NameSet)
-> (Located (StandaloneKindSig GhcRn), NameSet)
-> NameSet
-> NameSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located (StandaloneKindSig GhcRn), NameSet) -> NameSet
forall a b. (a, b) -> b
snd) NameSet
emptyFVs [(Located (StandaloneKindSig GhcRn), NameSet)]
kisigs_w_fvs
all_groups :: [TyClGroup GhcRn]
all_groups = [TyClGroup GhcRn]
first_group [TyClGroup GhcRn] -> [TyClGroup GhcRn] -> [TyClGroup GhcRn]
forall a. [a] -> [a] -> [a]
++ [TyClGroup GhcRn]
groups
; 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" ([TyClGroup GhcRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyClGroup GhcRn]
all_groups)
; ([TyClGroup GhcRn], NameSet) -> RnM ([TyClGroup GhcRn], NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyClGroup GhcRn]
all_groups, NameSet
all_fvs) }
where
mk_group :: 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
= ([(Located (InstDecl GhcRn), NameSet)]
InstDeclFreeVarsMap
inst_map', TyClGroup GhcRn
group)
where
tycl_ds :: [Located (TyClDecl GhcRn)]
tycl_ds = SCC (Located (TyClDecl GhcRn)) -> [Located (TyClDecl GhcRn)]
forall vertex. SCC vertex -> [vertex]
flattenSCC SCC (Located (TyClDecl GhcRn))
SCC (LTyClDecl GhcRn)
scc
bndrs :: [Name]
bndrs = (Located (TyClDecl GhcRn) -> Name)
-> [Located (TyClDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyClDecl GhcRn -> Name
forall (p :: Pass). TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (TyClDecl GhcRn -> Name)
-> (Located (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> Located (TyClDecl GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [Located (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
([Located (InstDecl GhcRn)]
inst_ds, [(Located (InstDecl GhcRn), NameSet)]
inst_map') = [Name]
-> InstDeclFreeVarsMap -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts [Name]
bndrs InstDeclFreeVarsMap
inst_map
group :: TyClGroup GhcRn
group = TyClGroup :: forall pass.
XCTyClGroup pass
-> [LTyClDecl pass]
-> [LRoleAnnotDecl pass]
-> [LStandaloneKindSig pass]
-> [LInstDecl pass]
-> TyClGroup pass
TyClGroup { group_ext :: XCTyClGroup GhcRn
group_ext = NoExtField
XCTyClGroup GhcRn
noExtField
, group_tyclds :: [LTyClDecl GhcRn]
group_tyclds = [Located (TyClDecl GhcRn)]
[LTyClDecl 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 = [Located (InstDecl GhcRn)]
[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 -> NameSet
lookupKindSig_FV_Env (KindSig_FV_Env NameEnv NameSet
e) Name
name
= NameSet -> Maybe NameSet -> NameSet
forall a. a -> Maybe a -> a
fromMaybe NameSet
emptyFVs (NameEnv NameSet -> Name -> Maybe NameSet
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv NameSet
e Name
name)
type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn)
mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env)
mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, NameSet)]
-> (KindSigEnv, KindSig_FV_Env)
mkKindSig_fv_env [(LStandaloneKindSig GhcRn, NameSet)]
kisigs_w_fvs = (NameEnv (Located (StandaloneKindSig GhcRn))
KindSigEnv
kisig_env, KindSig_FV_Env
kisig_fv_env)
where
kisig_env :: NameEnv (Located (StandaloneKindSig GhcRn))
kisig_env = ((Located (StandaloneKindSig GhcRn), NameSet)
-> Located (StandaloneKindSig GhcRn))
-> NameEnv (Located (StandaloneKindSig GhcRn), NameSet)
-> NameEnv (Located (StandaloneKindSig GhcRn))
forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv (Located (StandaloneKindSig GhcRn), NameSet)
-> Located (StandaloneKindSig GhcRn)
forall a b. (a, b) -> a
fst NameEnv (Located (StandaloneKindSig GhcRn), NameSet)
NameEnv (LStandaloneKindSig GhcRn, NameSet)
compound_env
kisig_fv_env :: KindSig_FV_Env
kisig_fv_env = NameEnv NameSet -> KindSig_FV_Env
KindSig_FV_Env (((Located (StandaloneKindSig GhcRn), NameSet) -> NameSet)
-> NameEnv (Located (StandaloneKindSig GhcRn), NameSet)
-> NameEnv NameSet
forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv (Located (StandaloneKindSig GhcRn), NameSet) -> NameSet
forall a b. (a, b) -> b
snd NameEnv (Located (StandaloneKindSig GhcRn), NameSet)
NameEnv (LStandaloneKindSig GhcRn, NameSet)
compound_env)
NameEnv (LStandaloneKindSig GhcRn, NameSet)
compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)
= ((Located (StandaloneKindSig GhcRn), NameSet) -> Name)
-> [(Located (StandaloneKindSig GhcRn), NameSet)]
-> NameEnv (Located (StandaloneKindSig GhcRn), NameSet)
forall a. (a -> Name) -> [a] -> NameEnv a
mkNameEnvWith (StandaloneKindSig GhcRn -> Name
forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName (StandaloneKindSig GhcRn -> Name)
-> ((Located (StandaloneKindSig GhcRn), NameSet)
-> StandaloneKindSig GhcRn)
-> (Located (StandaloneKindSig GhcRn), NameSet)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (StandaloneKindSig GhcRn) -> StandaloneKindSig GhcRn
forall l e. GenLocated l e -> e
unLoc (Located (StandaloneKindSig GhcRn) -> StandaloneKindSig GhcRn)
-> ((Located (StandaloneKindSig GhcRn), NameSet)
-> Located (StandaloneKindSig GhcRn))
-> (Located (StandaloneKindSig GhcRn), NameSet)
-> StandaloneKindSig GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located (StandaloneKindSig GhcRn), NameSet)
-> Located (StandaloneKindSig GhcRn)
forall a b. (a, b) -> a
fst) [(Located (StandaloneKindSig GhcRn), NameSet)]
[(LStandaloneKindSig GhcRn, NameSet)]
kisigs_w_fvs
getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
getKindSigs [Name]
bndrs KindSigEnv
kisig_env = (Name -> Maybe (Located (StandaloneKindSig GhcRn)))
-> [Name] -> [Located (StandaloneKindSig GhcRn)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameEnv (Located (StandaloneKindSig GhcRn))
-> Name -> Maybe (Located (StandaloneKindSig GhcRn))
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (Located (StandaloneKindSig GhcRn))
KindSigEnv
kisig_env) [Name]
bndrs
rnStandaloneKindSignatures
:: NameSet
-> [LStandaloneKindSig GhcPs]
-> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
rnStandaloneKindSignatures :: NameSet
-> [LStandaloneKindSig GhcPs]
-> RnM [(LStandaloneKindSig GhcRn, NameSet)]
rnStandaloneKindSignatures NameSet
tc_names [LStandaloneKindSig GhcPs]
kisigs
= do { let ([GenLocated SrcSpan (StandaloneKindSig GhcPs)]
no_dups, [NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))]
dup_kisigs) = (GenLocated SrcSpan (StandaloneKindSig GhcPs)
-> GenLocated SrcSpan (StandaloneKindSig GhcPs) -> Ordering)
-> [GenLocated SrcSpan (StandaloneKindSig GhcPs)]
-> ([GenLocated SrcSpan (StandaloneKindSig GhcPs)],
[NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (RdrName -> RdrName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RdrName -> RdrName -> Ordering)
-> (GenLocated SrcSpan (StandaloneKindSig GhcPs) -> RdrName)
-> GenLocated SrcSpan (StandaloneKindSig GhcPs)
-> GenLocated SrcSpan (StandaloneKindSig GhcPs)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` GenLocated SrcSpan (StandaloneKindSig GhcPs) -> RdrName
forall l (p :: Pass).
GenLocated l (StandaloneKindSig (GhcPass p)) -> IdGhcP p
get_name) [GenLocated SrcSpan (StandaloneKindSig GhcPs)]
[LStandaloneKindSig GhcPs]
kisigs
get_name :: GenLocated l (StandaloneKindSig (GhcPass p)) -> IdGhcP p
get_name = StandaloneKindSig (GhcPass p) -> IdGhcP p
forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName (StandaloneKindSig (GhcPass p) -> IdGhcP p)
-> (GenLocated l (StandaloneKindSig (GhcPass p))
-> StandaloneKindSig (GhcPass p))
-> GenLocated l (StandaloneKindSig (GhcPass p))
-> IdGhcP p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated l (StandaloneKindSig (GhcPass p))
-> StandaloneKindSig (GhcPass p)
forall l e. GenLocated l e -> e
unLoc
; (NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))
-> TcRn ())
-> [NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))]
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs)) -> TcRn ()
NonEmpty (LStandaloneKindSig GhcPs) -> TcRn ()
dupKindSig_Err [NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))]
dup_kisigs
; (GenLocated SrcSpan (StandaloneKindSig GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (StandaloneKindSig GhcRn), NameSet))
-> [GenLocated SrcSpan (StandaloneKindSig GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(Located (StandaloneKindSig GhcRn), NameSet)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((StandaloneKindSig GhcPs -> TcM (StandaloneKindSig GhcRn, NameSet))
-> GenLocated SrcSpan (StandaloneKindSig GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located (StandaloneKindSig GhcRn), NameSet)
forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM (NameSet
-> StandaloneKindSig GhcPs
-> TcM (StandaloneKindSig GhcRn, NameSet)
rnStandaloneKindSignature NameSet
tc_names)) [GenLocated SrcSpan (StandaloneKindSig GhcPs)]
no_dups
}
rnStandaloneKindSignature
:: NameSet
-> StandaloneKindSig GhcPs
-> RnM (StandaloneKindSig GhcRn, FreeVars)
rnStandaloneKindSignature :: NameSet
-> StandaloneKindSig GhcPs
-> TcM (StandaloneKindSig GhcRn, NameSet)
rnStandaloneKindSignature NameSet
tc_names (StandaloneKindSig XStandaloneKindSig GhcPs
_ LIdP GhcPs
v LHsSigType GhcPs
ki)
= do { Bool
standalone_ki_sig_ok <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.StandaloneKindSignatures
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
standalone_ki_sig_ok (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
addErr SDoc
standaloneKiSigErr
; Located Name
new_v <- HsSigCtxt
-> SDoc -> GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupSigCtxtOccRn (NameSet -> HsSigCtxt
TopSigCtxt NameSet
tc_names) (String -> SDoc
text String
"standalone kind signature") GenLocated SrcSpan RdrName
LIdP GhcPs
v
; let doc :: HsDocContext
doc = SDoc -> HsDocContext
StandaloneKindSigCtx (GenLocated SrcSpan RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan RdrName
LIdP GhcPs
v)
; (HsImplicitBndrs GhcRn (Located (HsType GhcRn))
new_ki, NameSet
fvs) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
doc TypeOrKind
KindLevel LHsSigType GhcPs
ki
; (StandaloneKindSig GhcRn, NameSet)
-> TcM (StandaloneKindSig GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XStandaloneKindSig GhcRn
-> LIdP GhcRn -> LHsSigType GhcRn -> StandaloneKindSig GhcRn
forall pass.
XStandaloneKindSig pass
-> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig NoExtField
XStandaloneKindSig GhcRn
noExtField Located Name
LIdP GhcRn
new_v HsImplicitBndrs GhcRn (Located (HsType GhcRn))
LHsSigType GhcRn
new_ki, NameSet
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, NameSet)]
-> [SCC (LTyClDecl GhcRn)]
depAnalTyClDecls GlobalRdrEnv
rdr_env KindSig_FV_Env
kisig_fv_env [(LTyClDecl GhcRn, NameSet)]
ds_w_fvs
= [Node Name (Located (TyClDecl GhcRn))]
-> [SCC (Located (TyClDecl GhcRn))]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Name (Located (TyClDecl GhcRn))]
[Node Name (LTyClDecl GhcRn)]
edges
where
edges :: [ Node Name (LTyClDecl GhcRn) ]
edges :: [Node Name (LTyClDecl GhcRn)]
edges = [ Located (TyClDecl GhcRn)
-> Name -> [Name] -> Node Name (Located (TyClDecl GhcRn))
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode Located (TyClDecl GhcRn)
d Name
IdP GhcRn
name ((Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (GlobalRdrEnv -> Name -> Name
getParent GlobalRdrEnv
rdr_env) (NameSet -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet NameSet
deps))
| (Located (TyClDecl GhcRn)
d, NameSet
fvs) <- [(Located (TyClDecl GhcRn), NameSet)]
[(LTyClDecl GhcRn, NameSet)]
ds_w_fvs,
let { name :: IdP GhcRn
name = TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass). TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (Located (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc Located (TyClDecl GhcRn)
d)
; kisig_fvs :: NameSet
kisig_fvs = KindSig_FV_Env -> Name -> NameSet
lookupKindSig_FV_Env KindSig_FV_Env
kisig_fv_env Name
IdP GhcRn
name
; deps :: NameSet
deps = NameSet
fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
kisig_fvs
}
]
toParents :: GlobalRdrEnv -> NameSet -> NameSet
toParents :: GlobalRdrEnv -> NameSet -> NameSet
toParents GlobalRdrEnv
rdr_env NameSet
ns
= (Name -> NameSet -> NameSet) -> NameSet -> NameSet -> NameSet
forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet Name -> NameSet -> NameSet
add NameSet
emptyNameSet NameSet
ns
where
add :: Name -> NameSet -> NameSet
add Name
n NameSet
s = NameSet -> Name -> NameSet
extendNameSet NameSet
s (GlobalRdrEnv -> Name -> Name
getParent GlobalRdrEnv
rdr_env Name
n)
getParent :: GlobalRdrEnv -> Name -> Name
getParent :: GlobalRdrEnv -> Name -> Name
getParent 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
FldParent { 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 :: NameSet -> [LRoleAnnotDecl GhcPs] -> RnM [LRoleAnnotDecl GhcRn]
rnRoleAnnots NameSet
tc_names [LRoleAnnotDecl GhcPs]
role_annots
= do {
let ([GenLocated SrcSpan (RoleAnnotDecl GhcPs)]
no_dups, [NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs))]
dup_annots) = (GenLocated SrcSpan (RoleAnnotDecl GhcPs)
-> GenLocated SrcSpan (RoleAnnotDecl GhcPs) -> Ordering)
-> [GenLocated SrcSpan (RoleAnnotDecl GhcPs)]
-> ([GenLocated SrcSpan (RoleAnnotDecl GhcPs)],
[NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs))])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (RdrName -> RdrName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RdrName -> RdrName -> Ordering)
-> (GenLocated SrcSpan (RoleAnnotDecl GhcPs) -> RdrName)
-> GenLocated SrcSpan (RoleAnnotDecl GhcPs)
-> GenLocated SrcSpan (RoleAnnotDecl GhcPs)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` GenLocated SrcSpan (RoleAnnotDecl GhcPs) -> RdrName
forall l (p :: Pass).
GenLocated l (RoleAnnotDecl (GhcPass p)) -> IdGhcP p
get_name) [GenLocated SrcSpan (RoleAnnotDecl GhcPs)]
[LRoleAnnotDecl GhcPs]
role_annots
get_name :: GenLocated l (RoleAnnotDecl (GhcPass p)) -> IdGhcP p
get_name = RoleAnnotDecl (GhcPass p) -> IdGhcP p
forall (p :: Pass). RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
roleAnnotDeclName (RoleAnnotDecl (GhcPass p) -> IdGhcP p)
-> (GenLocated l (RoleAnnotDecl (GhcPass p))
-> RoleAnnotDecl (GhcPass p))
-> GenLocated l (RoleAnnotDecl (GhcPass p))
-> IdGhcP p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated l (RoleAnnotDecl (GhcPass p))
-> RoleAnnotDecl (GhcPass p)
forall l e. GenLocated l e -> e
unLoc
; (NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs)) -> TcRn ())
-> [NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs))] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs)) -> TcRn ()
NonEmpty (LRoleAnnotDecl GhcPs) -> TcRn ()
dupRoleAnnotErr [NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs))]
dup_annots
; (GenLocated SrcSpan (RoleAnnotDecl GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (RoleAnnotDecl GhcRn)))
-> [GenLocated SrcSpan (RoleAnnotDecl GhcPs)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located (RoleAnnotDecl GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((RoleAnnotDecl GhcPs -> TcM (RoleAnnotDecl GhcRn))
-> GenLocated SrcSpan (RoleAnnotDecl GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (RoleAnnotDecl GhcRn))
forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM RoleAnnotDecl GhcPs -> TcM (RoleAnnotDecl GhcRn)
rn_role_annot1) [GenLocated SrcSpan (RoleAnnotDecl GhcPs)]
no_dups }
where
rn_role_annot1 :: RoleAnnotDecl GhcPs -> TcM (RoleAnnotDecl GhcRn)
rn_role_annot1 (RoleAnnotDecl XCRoleAnnotDecl GhcPs
_ LIdP GhcPs
tycon [XRec GhcPs (Maybe Role)]
roles)
= do {
Located Name
tycon' <- HsSigCtxt
-> SDoc -> GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupSigCtxtOccRn (NameSet -> HsSigCtxt
RoleAnnotCtxt NameSet
tc_names)
(String -> SDoc
text String
"role annotation")
GenLocated SrcSpan RdrName
LIdP GhcPs
tycon
; RoleAnnotDecl GhcRn -> TcM (RoleAnnotDecl GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (RoleAnnotDecl GhcRn -> TcM (RoleAnnotDecl GhcRn))
-> RoleAnnotDecl GhcRn -> TcM (RoleAnnotDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ XCRoleAnnotDecl GhcRn
-> LIdP GhcRn -> [XRec GhcRn (Maybe Role)] -> RoleAnnotDecl GhcRn
forall pass.
XCRoleAnnotDecl pass
-> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass
RoleAnnotDecl NoExtField
XCRoleAnnotDecl GhcRn
noExtField Located Name
LIdP GhcRn
tycon' [XRec GhcPs (Maybe Role)]
[XRec GhcRn (Maybe Role)]
roles }
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> TcRn ()
dupRoleAnnotErr NonEmpty (LRoleAnnotDecl GhcPs)
list
= SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
loc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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 (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RdrName -> SDoc) -> RdrName -> SDoc
forall a b. (a -> b) -> a -> b
$ RoleAnnotDecl GhcPs -> IdP GhcPs
forall (p :: Pass). RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
roleAnnotDeclName RoleAnnotDecl GhcPs
first_decl) SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpan (RoleAnnotDecl GhcPs) -> SDoc)
-> [GenLocated SrcSpan (RoleAnnotDecl GhcPs)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan (RoleAnnotDecl GhcPs) -> SDoc
forall a a. (Outputable a, Outputable a) => GenLocated a a -> SDoc
pp_role_annot ([GenLocated SrcSpan (RoleAnnotDecl GhcPs)] -> [SDoc])
-> [GenLocated SrcSpan (RoleAnnotDecl GhcPs)] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs))
-> [GenLocated SrcSpan (RoleAnnotDecl GhcPs)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs))
sorted_list)
where
sorted_list :: NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs))
sorted_list = (GenLocated SrcSpan (RoleAnnotDecl GhcPs)
-> GenLocated SrcSpan (RoleAnnotDecl GhcPs) -> Ordering)
-> NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs))
-> NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs))
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy GenLocated SrcSpan (RoleAnnotDecl GhcPs)
-> GenLocated SrcSpan (RoleAnnotDecl GhcPs) -> Ordering
forall e. GenLocated SrcSpan e -> GenLocated SrcSpan e -> Ordering
cmp_loc NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs))
NonEmpty (LRoleAnnotDecl GhcPs)
list
((L SrcSpan
loc RoleAnnotDecl GhcPs
first_decl) :| [GenLocated SrcSpan (RoleAnnotDecl GhcPs)]
_) = NonEmpty (GenLocated SrcSpan (RoleAnnotDecl GhcPs))
sorted_list
pp_role_annot :: GenLocated a a -> SDoc
pp_role_annot (L a
loc a
decl) = SDoc -> Int -> SDoc -> SDoc
hang (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
decl)
Int
4 (String -> SDoc
text String
"-- written at" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
loc)
cmp_loc :: GenLocated SrcSpan e -> GenLocated SrcSpan e -> Ordering
cmp_loc = SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest (SrcSpan -> SrcSpan -> Ordering)
-> (GenLocated SrcSpan e -> SrcSpan)
-> GenLocated SrcSpan e
-> GenLocated SrcSpan e
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` GenLocated SrcSpan e -> SrcSpan
forall l e. GenLocated l e -> l
getLoc
dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()
dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> TcRn ()
dupKindSig_Err NonEmpty (LStandaloneKindSig GhcPs)
list
= SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
loc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Duplicate standalone kind signatures for" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RdrName -> SDoc) -> RdrName -> SDoc
forall a b. (a -> b) -> a -> b
$ StandaloneKindSig GhcPs -> IdP GhcPs
forall (p :: Pass).
StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName StandaloneKindSig GhcPs
first_decl) SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpan (StandaloneKindSig GhcPs) -> SDoc)
-> [GenLocated SrcSpan (StandaloneKindSig GhcPs)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan (StandaloneKindSig GhcPs) -> SDoc
forall a a. (Outputable a, Outputable a) => GenLocated a a -> SDoc
pp_kisig ([GenLocated SrcSpan (StandaloneKindSig GhcPs)] -> [SDoc])
-> [GenLocated SrcSpan (StandaloneKindSig GhcPs)] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))
-> [GenLocated SrcSpan (StandaloneKindSig GhcPs)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))
sorted_list)
where
sorted_list :: NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))
sorted_list = (GenLocated SrcSpan (StandaloneKindSig GhcPs)
-> GenLocated SrcSpan (StandaloneKindSig GhcPs) -> Ordering)
-> NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))
-> NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy GenLocated SrcSpan (StandaloneKindSig GhcPs)
-> GenLocated SrcSpan (StandaloneKindSig GhcPs) -> Ordering
forall e. GenLocated SrcSpan e -> GenLocated SrcSpan e -> Ordering
cmp_loc NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))
NonEmpty (LStandaloneKindSig GhcPs)
list
((L SrcSpan
loc StandaloneKindSig GhcPs
first_decl) :| [GenLocated SrcSpan (StandaloneKindSig GhcPs)]
_) = NonEmpty (GenLocated SrcSpan (StandaloneKindSig GhcPs))
sorted_list
pp_kisig :: GenLocated a a -> SDoc
pp_kisig (L a
loc a
decl) =
SDoc -> Int -> SDoc -> SDoc
hang (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
decl) Int
4 (String -> SDoc
text String
"-- written at" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
loc)
cmp_loc :: GenLocated SrcSpan e -> GenLocated SrcSpan e -> Ordering
cmp_loc = SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest (SrcSpan -> SrcSpan -> Ordering)
-> (GenLocated SrcSpan e -> SrcSpan)
-> GenLocated SrcSpan e
-> GenLocated SrcSpan e
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` GenLocated SrcSpan e -> SrcSpan
forall l e. GenLocated l e -> l
getLoc
type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]
mkInstDeclFreeVarsMap :: GlobalRdrEnv
-> NameSet
-> [(LInstDecl GhcRn, FreeVars)]
-> InstDeclFreeVarsMap
mkInstDeclFreeVarsMap :: GlobalRdrEnv
-> NameSet -> InstDeclFreeVarsMap -> InstDeclFreeVarsMap
mkInstDeclFreeVarsMap GlobalRdrEnv
rdr_env NameSet
tycl_bndrs InstDeclFreeVarsMap
inst_ds_fvs
= [ (Located (InstDecl GhcRn)
LInstDecl GhcRn
inst_decl, GlobalRdrEnv -> NameSet -> NameSet
toParents GlobalRdrEnv
rdr_env NameSet
fvs NameSet -> NameSet -> NameSet
`intersectFVs` NameSet
tycl_bndrs)
| (Located (InstDecl GhcRn)
inst_decl, NameSet
fvs) <- [(Located (InstDecl GhcRn), NameSet)]
InstDeclFreeVarsMap
inst_ds_fvs ]
getInsts :: [Name] -> InstDeclFreeVarsMap
-> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts :: [Name]
-> InstDeclFreeVarsMap -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
getInsts [Name]
bndrs InstDeclFreeVarsMap
inst_decl_map
= ((Located (InstDecl GhcRn), NameSet)
-> Either
(Located (InstDecl GhcRn)) (Located (InstDecl GhcRn), NameSet))
-> [(Located (InstDecl GhcRn), NameSet)]
-> ([Located (InstDecl GhcRn)],
[(Located (InstDecl GhcRn), NameSet)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (Located (InstDecl GhcRn), NameSet)
-> Either
(Located (InstDecl GhcRn)) (Located (InstDecl GhcRn), NameSet)
(LInstDecl GhcRn, NameSet)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, NameSet)
pick_me [(Located (InstDecl GhcRn), NameSet)]
InstDeclFreeVarsMap
inst_decl_map
where
pick_me :: (LInstDecl GhcRn, FreeVars)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
pick_me :: (LInstDecl GhcRn, NameSet)
-> Either (LInstDecl GhcRn) (LInstDecl GhcRn, NameSet)
pick_me (LInstDecl GhcRn
decl, NameSet
fvs)
| NameSet -> Bool
isEmptyNameSet NameSet
depleted_fvs = Located (InstDecl GhcRn)
-> Either
(Located (InstDecl GhcRn)) (Located (InstDecl GhcRn), NameSet)
forall a b. a -> Either a b
Left Located (InstDecl GhcRn)
LInstDecl GhcRn
decl
| Bool
otherwise = (Located (InstDecl GhcRn), NameSet)
-> Either
(Located (InstDecl GhcRn)) (Located (InstDecl GhcRn), NameSet)
forall a b. b -> Either a b
Right (Located (InstDecl GhcRn)
LInstDecl GhcRn
decl, NameSet
depleted_fvs)
where
depleted_fvs :: NameSet
depleted_fvs = [Name] -> NameSet -> NameSet
delFVs [Name]
bndrs NameSet
fvs
rnTyClDecl :: TyClDecl GhcPs
-> RnM (TyClDecl GhcRn, FreeVars)
rnTyClDecl :: TyClDecl GhcPs -> TcM (TyClDecl GhcRn, NameSet)
rnTyClDecl (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcPs
fam })
= do { (FamilyDecl GhcRn
fam', NameSet
fvs) <- Maybe Name -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, NameSet)
rnFamDecl Maybe Name
forall a. Maybe a
Nothing FamilyDecl GhcPs
fam
; (TyClDecl GhcRn, NameSet) -> TcM (TyClDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XFamDecl GhcRn -> FamilyDecl GhcRn -> TyClDecl GhcRn
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
XFamDecl GhcRn
noExtField FamilyDecl GhcRn
fam', NameSet
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 { Located Name
tycon' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
LIdP GhcPs
tycon
; let kvs :: [GenLocated SrcSpan RdrName]
kvs = LHsType GhcPs -> [GenLocated SrcSpan RdrName]
extractHsTyRdrTyVarsKindVars LHsType GhcPs
rhs
doc :: HsDocContext
doc = GenLocated SrcSpan RdrName -> HsDocContext
TySynCtx GenLocated SrcSpan RdrName
LIdP GhcPs
tycon
; String -> SDoc -> TcRn ()
traceRn String
"rntycl-ty" (GenLocated SrcSpan RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan RdrName
LIdP GhcPs
tycon SDoc -> SDoc -> SDoc
<+> [GenLocated SrcSpan RdrName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan RdrName]
kvs)
; HsDocContext
-> Maybe Any
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, NameSet))
-> TcM (TyClDecl GhcRn, NameSet)
forall a b.
HsDocContext
-> Maybe a
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindHsQTyVars HsDocContext
doc Maybe Any
forall a. Maybe a
Nothing [GenLocated SrcSpan RdrName]
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, NameSet))
-> TcM (TyClDecl GhcRn, NameSet))
-> (LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, NameSet))
-> TcM (TyClDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
_ ->
do { (Located (HsType GhcRn)
rhs', NameSet
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnTySyn HsDocContext
doc LHsType GhcPs
rhs
; (TyClDecl GhcRn, NameSet) -> TcM (TyClDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (SynDecl :: forall pass.
XSynDecl pass
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> LHsType pass
-> TyClDecl pass
SynDecl { tcdLName :: LIdP GhcRn
tcdLName = Located Name
LIdP GhcRn
tycon', tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars'
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdRhs :: LHsType GhcRn
tcdRhs = Located (HsType GhcRn)
LHsType GhcRn
rhs', tcdSExt :: XSynDecl GhcRn
tcdSExt = NameSet
XSynDecl GhcRn
fvs }, NameSet
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 { Located Name
tycon' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
LIdP GhcPs
tycon
; let kvs :: [GenLocated SrcSpan RdrName]
kvs = HsDataDefn GhcPs -> [GenLocated SrcSpan RdrName]
extractDataDefnKindVars HsDataDefn GhcPs
defn
doc :: HsDocContext
doc = GenLocated SrcSpan RdrName -> HsDocContext
TyDataCtx GenLocated SrcSpan RdrName
LIdP GhcPs
tycon
; String -> SDoc -> TcRn ()
traceRn String
"rntycl-data" (GenLocated SrcSpan RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan RdrName
LIdP GhcPs
tycon SDoc -> SDoc -> SDoc
<+> [GenLocated SrcSpan RdrName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan RdrName]
kvs)
; HsDocContext
-> Maybe Any
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, NameSet))
-> TcM (TyClDecl GhcRn, NameSet)
forall a b.
HsDocContext
-> Maybe a
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindHsQTyVars HsDocContext
doc Maybe Any
forall a. Maybe a
Nothing [GenLocated SrcSpan RdrName]
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, NameSet))
-> TcM (TyClDecl GhcRn, NameSet))
-> (LHsQTyVars GhcRn -> Bool -> TcM (TyClDecl GhcRn, NameSet))
-> TcM (TyClDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
no_rhs_kvs ->
do { (HsDataDefn GhcRn
defn', NameSet
fvs) <- HsDocContext -> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, NameSet)
rnDataDefn HsDocContext
doc HsDataDefn GhcPs
defn
; Bool
cusk <- LHsQTyVars GhcRn
-> NewOrData -> Bool -> Maybe (LHsType GhcPs) -> TcRn Bool
forall (p :: Pass) (p' :: Pass).
LHsQTyVars (GhcPass p)
-> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> TcRn Bool
data_decl_has_cusk LHsQTyVars GhcRn
tyvars' NewOrData
new_or_data Bool
no_rhs_kvs Maybe (LHsType GhcPs)
kind_sig
; let rn_info :: DataDeclRn
rn_info = DataDeclRn :: Bool -> NameSet -> DataDeclRn
DataDeclRn { tcdDataCusk :: Bool
tcdDataCusk = Bool
cusk
, tcdFVs :: NameSet
tcdFVs = NameSet
fvs }
; String -> SDoc -> TcRn ()
traceRn String
"rndata" (GenLocated SrcSpan RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan RdrName
LIdP GhcPs
tycon SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
cusk SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
no_rhs_kvs)
; (TyClDecl GhcRn, NameSet) -> TcM (TyClDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataDecl :: forall pass.
XDataDecl pass
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl { tcdLName :: LIdP GhcRn
tcdLName = Located Name
LIdP GhcRn
tycon'
, tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars'
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity
, tcdDataDefn :: HsDataDefn GhcRn
tcdDataDefn = HsDataDefn GhcRn
defn'
, tcdDExt :: XDataDecl GhcRn
tcdDExt = DataDeclRn
XDataDecl GhcRn
rn_info }, NameSet
fvs) } }
rnTyClDecl (ClassDecl { tcdCtxt :: forall pass. TyClDecl pass -> LHsContext pass
tcdCtxt = 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]
tcdDocs = [LDocDecl]
docs})
= do { Located Name
lcls' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
LIdP GhcPs
lcls
; let cls' :: Name
cls' = Located Name -> Name
forall l e. GenLocated l e -> e
unLoc Located Name
lcls'
kvs :: [a]
kvs = []
; ((LHsQTyVars GhcRn
tyvars', Located [Located (HsType GhcRn)]
context', [Located ([Located Name], [Located Name])]
fds', [Located (FamilyDecl GhcRn)]
ats'), NameSet
stuff_fvs)
<- HsDocContext
-> Maybe Any
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn, Located [Located (HsType GhcRn)],
[Located ([Located Name], [Located Name])],
[Located (FamilyDecl GhcRn)]),
NameSet))
-> RnM
((LHsQTyVars GhcRn, Located [Located (HsType GhcRn)],
[Located ([Located Name], [Located Name])],
[Located (FamilyDecl GhcRn)]),
NameSet)
forall a b.
HsDocContext
-> Maybe a
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindHsQTyVars HsDocContext
cls_doc Maybe Any
forall a. Maybe a
Nothing [GenLocated SrcSpan RdrName]
forall a. [a]
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn, Located [Located (HsType GhcRn)],
[Located ([Located Name], [Located Name])],
[Located (FamilyDecl GhcRn)]),
NameSet))
-> RnM
((LHsQTyVars GhcRn, Located [Located (HsType GhcRn)],
[Located ([Located Name], [Located Name])],
[Located (FamilyDecl GhcRn)]),
NameSet))
-> (LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn, Located [Located (HsType GhcRn)],
[Located ([Located Name], [Located Name])],
[Located (FamilyDecl GhcRn)]),
NameSet))
-> RnM
((LHsQTyVars GhcRn, Located [Located (HsType GhcRn)],
[Located ([Located Name], [Located Name])],
[Located (FamilyDecl GhcRn)]),
NameSet)
forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
_ -> do
{ (Located [Located (HsType GhcRn)]
context', NameSet
cxt_fvs) <- HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, NameSet)
rnContext HsDocContext
cls_doc LHsContext GhcPs
context
; [Located ([Located Name], [Located Name])]
fds' <- [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds [LHsFunDep GhcPs]
fds
; ([Located (FamilyDecl GhcRn)]
ats', NameSet
fv_ats) <- Name -> [LFamilyDecl GhcPs] -> RnM ([LFamilyDecl GhcRn], NameSet)
rnATDecls Name
cls' [LFamilyDecl GhcPs]
ats
; let fvs :: NameSet
fvs = NameSet
cxt_fvs NameSet -> NameSet -> NameSet
`plusFV`
NameSet
fv_ats
; ((LHsQTyVars GhcRn, Located [Located (HsType GhcRn)],
[Located ([Located Name], [Located Name])],
[Located (FamilyDecl GhcRn)]),
NameSet)
-> RnM
((LHsQTyVars GhcRn, Located [Located (HsType GhcRn)],
[Located ([Located Name], [Located Name])],
[Located (FamilyDecl GhcRn)]),
NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((LHsQTyVars GhcRn
tyvars', Located [Located (HsType GhcRn)]
context', [Located ([Located Name], [Located Name])]
fds', [Located (FamilyDecl GhcRn)]
ats'), NameSet
fvs) }
; ([Located (TyFamInstDecl GhcRn)]
at_defs', NameSet
fv_at_defs) <- (TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet))
-> [Located (TyFamInstDecl GhcPs)]
-> RnM ([Located (TyFamInstDecl GhcRn)], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList (Name -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, NameSet)
rnTyFamDefltDecl Name
cls') [Located (TyFamInstDecl GhcPs)]
[LTyFamInstDecl GhcPs]
at_defs
; let sig_rdr_names_w_locs :: [GenLocated SrcSpan RdrName]
sig_rdr_names_w_locs =
[GenLocated SrcSpan RdrName
op | L SrcSpan
_ (ClassOpSig XClassOpSig GhcPs
_ Bool
False [LIdP GhcPs]
ops LHsSigType GhcPs
_) <- [GenLocated SrcSpan (Sig GhcPs)]
[LSig GhcPs]
sigs
, GenLocated SrcSpan RdrName
op <- [GenLocated SrcSpan RdrName]
[LIdP GhcPs]
ops]
; [GenLocated SrcSpan RdrName] -> TcRn ()
checkDupRdrNames [GenLocated SrcSpan RdrName]
sig_rdr_names_w_locs
; (Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
mbinds', [Located (Sig GhcRn)]
sigs', NameSet
meth_fvs)
<- Bool
-> Name
-> [Name]
-> LHsBinds GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], NameSet)
rnMethodBinds Bool
True Name
cls' (LHsQTyVars GhcRn -> [Name]
hsAllLTyVarNames LHsQTyVars GhcRn
tyvars') LHsBinds GhcPs
mbinds [LSig GhcPs]
sigs
; let all_fvs :: NameSet
all_fvs = NameSet
meth_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
stuff_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
fv_at_defs
; (TyClDecl GhcRn, NameSet) -> TcM (TyClDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassDecl :: forall pass.
XClassDecl pass
-> LHsContext pass
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> [LHsFunDep pass]
-> [LSig pass]
-> LHsBinds pass
-> [LFamilyDecl pass]
-> [LTyFamDefltDecl pass]
-> [LDocDecl]
-> TyClDecl pass
ClassDecl { tcdCtxt :: LHsContext GhcRn
tcdCtxt = Located [Located (HsType GhcRn)]
LHsContext GhcRn
context', tcdLName :: LIdP GhcRn
tcdLName = Located Name
LIdP GhcRn
lcls',
tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars', tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
fixity,
tcdFDs :: [LHsFunDep GhcRn]
tcdFDs = [Located ([Located Name], [Located Name])]
[LHsFunDep GhcRn]
fds', tcdSigs :: [LSig GhcRn]
tcdSigs = [Located (Sig GhcRn)]
[LSig GhcRn]
sigs',
tcdMeths :: LHsBinds GhcRn
tcdMeths = Bag (GenLocated SrcSpan (HsBindLR GhcRn GhcRn))
LHsBinds GhcRn
mbinds', tcdATs :: [LFamilyDecl GhcRn]
tcdATs = [Located (FamilyDecl GhcRn)]
[LFamilyDecl GhcRn]
ats', tcdATDefs :: [LTyFamInstDecl GhcRn]
tcdATDefs = [Located (TyFamInstDecl GhcRn)]
[LTyFamInstDecl GhcRn]
at_defs',
tcdDocs :: [LDocDecl]
tcdDocs = [LDocDecl]
docs, tcdCExt :: XClassDecl GhcRn
tcdCExt = NameSet
XClassDecl GhcRn
all_fvs },
NameSet
all_fvs ) }
where
cls_doc :: HsDocContext
cls_doc = GenLocated SrcSpan RdrName -> HsDocContext
ClassDeclCtx GenLocated SrcSpan RdrName
LIdP GhcPs
lcls
data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool
data_decl_has_cusk :: LHsQTyVars (GhcPass p)
-> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> TcRn Bool
data_decl_has_cusk LHsQTyVars (GhcPass p)
tyvars NewOrData
new_or_data Bool
no_rhs_kvs Maybe (LHsKind (GhcPass p'))
kind_sig = do
{
; Bool
unlifted_newtypes <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UnliftedNewtypes
; let non_cusk_newtype :: Bool
non_cusk_newtype
| NewOrData
NewType <- NewOrData
new_or_data =
Bool
unlifted_newtypes Bool -> Bool -> Bool
&& Maybe (Located (HsType (GhcPass p'))) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Located (HsType (GhcPass p')))
Maybe (LHsKind (GhcPass p'))
kind_sig
| Bool
otherwise = Bool
False
; Bool -> TcRn Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> TcRn Bool) -> Bool -> TcRn Bool
forall a b. (a -> b) -> a -> b
$ LHsQTyVars (GhcPass p) -> Bool
forall (p :: Pass). LHsQTyVars (GhcPass p) -> Bool
hsTvbAllKinded LHsQTyVars (GhcPass p)
tyvars Bool -> Bool -> Bool
&& Bool
no_rhs_kvs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
non_cusk_newtype
}
rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnTySyn HsDocContext
doc LHsType GhcPs
rhs = HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsType HsDocContext
doc LHsType GhcPs
rhs
rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
-> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn :: HsDocContext -> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, NameSet)
rnDataDefn 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 -> LHsContext pass
dd_ctxt = LHsContext GhcPs
context, dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcPs]
condecls
, dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsType GhcPs)
m_sig, dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcPs
derivs })
= do { Bool -> SDoc -> TcRn ()
checkTc (Bool
h98_style Bool -> Bool -> Bool
|| [Located (HsType GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (GenLocated SrcSpan [Located (HsType GhcPs)]
-> [Located (HsType GhcPs)]
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan [Located (HsType GhcPs)]
LHsContext GhcPs
context))
(HsDocContext -> SDoc
badGadtStupidTheta HsDocContext
doc)
; (Maybe (Located (HsType GhcRn))
m_sig', NameSet
sig_fvs) <- case Maybe (LHsType GhcPs)
m_sig of
Just LHsType GhcPs
sig -> (Located (HsType GhcRn) -> Maybe (Located (HsType GhcRn)))
-> (Located (HsType GhcRn), NameSet)
-> (Maybe (Located (HsType GhcRn)), NameSet)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Located (HsType GhcRn) -> Maybe (Located (HsType GhcRn))
forall a. a -> Maybe a
Just ((Located (HsType GhcRn), NameSet)
-> (Maybe (Located (HsType GhcRn)), NameSet))
-> RnM (Located (HsType GhcRn), NameSet)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe (Located (HsType GhcRn)), NameSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsKind HsDocContext
doc LHsType GhcPs
sig
Maybe (LHsType GhcPs)
Nothing -> (Maybe (Located (HsType GhcRn)), NameSet)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe (Located (HsType GhcRn)), NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Located (HsType GhcRn))
forall a. Maybe a
Nothing, NameSet
emptyFVs)
; (Located [Located (HsType GhcRn)]
context', NameSet
fvs1) <- HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, NameSet)
rnContext HsDocContext
doc LHsContext GhcPs
context
; (GenLocated SrcSpan [Located (HsDerivingClause GhcRn)]
derivs', NameSet
fvs3) <- GenLocated SrcSpan [Located (HsDerivingClause GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpan [Located (HsDerivingClause GhcRn)], NameSet)
rn_derivs GenLocated SrcSpan [Located (HsDerivingClause GhcPs)]
HsDeriving GhcPs
derivs
; let { zap_lcl_env :: RnM ([Located (ConDecl GhcRn)], NameSet)
-> RnM ([Located (ConDecl GhcRn)], NameSet)
zap_lcl_env | Bool
h98_style = \ RnM ([Located (ConDecl GhcRn)], NameSet)
thing -> RnM ([Located (ConDecl GhcRn)], NameSet)
thing
| Bool
otherwise = LocalRdrEnv
-> RnM ([Located (ConDecl GhcRn)], NameSet)
-> RnM ([Located (ConDecl GhcRn)], NameSet)
forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
emptyLocalRdrEnv }
; ([Located (ConDecl GhcRn)]
condecls', NameSet
con_fvs) <- RnM ([Located (ConDecl GhcRn)], NameSet)
-> RnM ([Located (ConDecl GhcRn)], NameSet)
zap_lcl_env (RnM ([Located (ConDecl GhcRn)], NameSet)
-> RnM ([Located (ConDecl GhcRn)], NameSet))
-> RnM ([Located (ConDecl GhcRn)], NameSet)
-> RnM ([Located (ConDecl GhcRn)], NameSet)
forall a b. (a -> b) -> a -> b
$ [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], NameSet)
rnConDecls [LConDecl GhcPs]
condecls
; let all_fvs :: NameSet
all_fvs = NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs3 NameSet -> NameSet -> NameSet
`plusFV`
NameSet
con_fvs NameSet -> NameSet -> NameSet
`plusFV` NameSet
sig_fvs
; (HsDataDefn GhcRn, NameSet) -> RnM (HsDataDefn GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (XRec pass CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcRn
dd_ext = NoExtField
XCHsDataDefn GhcRn
noExtField
, dd_ND :: NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: Maybe (XRec GhcRn CType)
dd_cType = Maybe (XRec GhcPs CType)
Maybe (XRec GhcRn CType)
cType
, dd_ctxt :: LHsContext GhcRn
dd_ctxt = Located [Located (HsType GhcRn)]
LHsContext GhcRn
context', dd_kindSig :: Maybe (LHsType GhcRn)
dd_kindSig = Maybe (Located (HsType GhcRn))
Maybe (LHsType GhcRn)
m_sig'
, dd_cons :: [LConDecl GhcRn]
dd_cons = [Located (ConDecl GhcRn)]
[LConDecl GhcRn]
condecls'
, dd_derivs :: HsDeriving GhcRn
dd_derivs = GenLocated SrcSpan [Located (HsDerivingClause GhcRn)]
HsDeriving GhcRn
derivs' }
, NameSet
all_fvs )
}
where
h98_style :: Bool
h98_style = case [LConDecl GhcPs]
condecls of
(L _ (ConDeclGADT {})) : [LConDecl GhcPs]
_ -> Bool
False
[LConDecl GhcPs]
_ -> Bool
True
rn_derivs :: GenLocated SrcSpan [Located (HsDerivingClause GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpan [Located (HsDerivingClause GhcRn)], NameSet)
rn_derivs (L SrcSpan
loc [Located (HsDerivingClause GhcPs)]
ds)
= do { Bool
deriv_strats_ok <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DerivingStrategies
; Bool -> SDoc -> TcRn ()
failIfTc ([Located (HsDerivingClause GhcPs)] -> Int -> Bool
forall a. [a] -> Int -> Bool
lengthExceeds [Located (HsDerivingClause GhcPs)]
ds Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
deriv_strats_ok)
SDoc
multipleDerivClausesErr
; ([Located (HsDerivingClause GhcRn)]
ds', NameSet
fvs) <- (Located (HsDerivingClause GhcPs)
-> RnM (Located (HsDerivingClause GhcRn), NameSet))
-> [Located (HsDerivingClause GhcPs)]
-> RnM ([Located (HsDerivingClause GhcRn)], NameSet)
forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn (HsDocContext
-> LHsDerivingClause GhcPs
-> RnM (LHsDerivingClause GhcRn, NameSet)
rnLHsDerivingClause HsDocContext
doc) [Located (HsDerivingClause GhcPs)]
ds
; (GenLocated SrcSpan [Located (HsDerivingClause GhcRn)], NameSet)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpan [Located (HsDerivingClause GhcRn)], NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> [Located (HsDerivingClause GhcRn)]
-> GenLocated SrcSpan [Located (HsDerivingClause GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc [Located (HsDerivingClause GhcRn)]
ds', NameSet
fvs) }
warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
-> SrcSpan
-> RnM ()
warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (LDerivStrategy GhcRn)
mds SrcSpan
loc
= do { DynFlags
dyn_flags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingDerivingStrategies DynFlags
dyn_flags) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
case Maybe (LDerivStrategy GhcRn)
mds of
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)
_ -> () -> TcRn ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
}
where
no_strat_warning :: SDoc
no_strat_warning :: SDoc
no_strat_warning = String -> SDoc
text 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, NameSet)
rnLHsDerivingClause HsDocContext
doc
(L loc (HsDerivingClause
{ deriv_clause_ext = noExtField
, deriv_clause_strategy = dcs
, deriv_clause_tys = dct }))
= do { (Maybe (Located (DerivStrategy GhcRn))
dcs', Located (DerivClauseTys GhcRn)
dct', NameSet
fvs)
<- HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (Located (DerivClauseTys GhcRn), NameSet)
-> RnM
(Maybe (LDerivStrategy GhcRn), Located (DerivClauseTys GhcRn),
NameSet)
forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, NameSet)
-> RnM (Maybe (LDerivStrategy GhcRn), a, NameSet)
rnLDerivStrategy HsDocContext
doc Maybe (LDerivStrategy GhcPs)
dcs (RnM (Located (DerivClauseTys GhcRn), NameSet)
-> RnM
(Maybe (LDerivStrategy GhcRn), Located (DerivClauseTys GhcRn),
NameSet))
-> RnM (Located (DerivClauseTys GhcRn), NameSet)
-> RnM
(Maybe (LDerivStrategy GhcRn), Located (DerivClauseTys GhcRn),
NameSet)
forall a b. (a -> b) -> a -> b
$ LDerivClauseTys GhcPs -> RnM (LDerivClauseTys GhcRn, NameSet)
rn_deriv_clause_tys LDerivClauseTys GhcPs
dct
; Maybe (LDerivStrategy GhcRn) -> SrcSpan -> TcRn ()
warnNoDerivStrat Maybe (Located (DerivStrategy GhcRn))
Maybe (LDerivStrategy GhcRn)
dcs' SrcSpan
loc
; (Located (HsDerivingClause GhcRn), NameSet)
-> RnM (Located (HsDerivingClause GhcRn), NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( SrcSpan
-> HsDerivingClause GhcRn -> Located (HsDerivingClause GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsDerivingClause :: forall pass.
XCHsDerivingClause pass
-> Maybe (LDerivStrategy pass)
-> LDerivClauseTys pass
-> HsDerivingClause pass
HsDerivingClause { deriv_clause_ext :: XCHsDerivingClause GhcRn
deriv_clause_ext = XCHsDerivingClause GhcPs
XCHsDerivingClause GhcRn
noExtField
, deriv_clause_strategy :: Maybe (LDerivStrategy GhcRn)
deriv_clause_strategy = Maybe (Located (DerivStrategy GhcRn))
Maybe (LDerivStrategy GhcRn)
dcs'
, deriv_clause_tys :: LDerivClauseTys GhcRn
deriv_clause_tys = Located (DerivClauseTys GhcRn)
LDerivClauseTys GhcRn
dct' })
, NameSet
fvs ) }
where
rn_deriv_clause_tys :: LDerivClauseTys GhcPs
-> RnM (LDerivClauseTys GhcRn, FreeVars)
rn_deriv_clause_tys :: LDerivClauseTys GhcPs -> RnM (LDerivClauseTys GhcRn, NameSet)
rn_deriv_clause_tys (L l dct) = case DerivClauseTys GhcPs
dct of
DctSingle XDctSingle GhcPs
x LHsSigType GhcPs
ty -> do
(HsImplicitBndrs GhcRn (Located (HsType GhcRn))
ty', NameSet
fvs) <- LHsSigType GhcPs -> RnM (LHsSigType GhcRn, NameSet)
rn_clause_pred LHsSigType GhcPs
ty
(Located (DerivClauseTys GhcRn), NameSet)
-> RnM (Located (DerivClauseTys GhcRn), NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan -> DerivClauseTys GhcRn -> Located (DerivClauseTys GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XDctSingle GhcRn -> LHsSigType GhcRn -> DerivClauseTys GhcRn
forall pass.
XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass
DctSingle XDctSingle GhcPs
XDctSingle GhcRn
x HsImplicitBndrs GhcRn (Located (HsType GhcRn))
LHsSigType GhcRn
ty'), NameSet
fvs)
DctMulti XDctMulti GhcPs
x [LHsSigType GhcPs]
tys -> do
([HsImplicitBndrs GhcRn (Located (HsType GhcRn))]
tys', NameSet
fvs) <- (HsImplicitBndrs GhcPs (Located (HsType GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsImplicitBndrs GhcRn (Located (HsType GhcRn)), NameSet))
-> [HsImplicitBndrs GhcPs (Located (HsType GhcPs))]
-> RnM ([HsImplicitBndrs GhcRn (Located (HsType GhcRn))], NameSet)
forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn HsImplicitBndrs GhcPs (Located (HsType GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsImplicitBndrs GhcRn (Located (HsType GhcRn)), NameSet)
LHsSigType GhcPs -> RnM (LHsSigType GhcRn, NameSet)
rn_clause_pred [HsImplicitBndrs GhcPs (Located (HsType GhcPs))]
[LHsSigType GhcPs]
tys
(Located (DerivClauseTys GhcRn), NameSet)
-> RnM (Located (DerivClauseTys GhcRn), NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan -> DerivClauseTys GhcRn -> Located (DerivClauseTys GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XDctMulti GhcRn -> [LHsSigType GhcRn] -> DerivClauseTys GhcRn
forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti XDctMulti GhcPs
XDctMulti GhcRn
x [HsImplicitBndrs GhcRn (Located (HsType GhcRn))]
[LHsSigType GhcRn]
tys'), NameSet
fvs)
rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, NameSet)
rn_clause_pred LHsSigType GhcPs
pred_ty = do
let inf_err :: Maybe SDoc
inf_err = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
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 :: (HsImplicitBndrs GhcRn (Located (HsType GhcRn)), NameSet)
ret@(HsImplicitBndrs GhcRn (Located (HsType GhcRn))
pred_ty', NameSet
_) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
doc TypeOrKind
TypeLevel LHsSigType GhcPs
pred_ty
HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
doc (String -> SDoc
text String
"Derived class type")
(LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead HsImplicitBndrs GhcRn (Located (HsType GhcRn))
LHsSigType GhcRn
pred_ty')
(HsImplicitBndrs GhcRn (Located (HsType GhcRn)), NameSet)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsImplicitBndrs GhcRn (Located (HsType GhcRn)), NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsImplicitBndrs GhcRn (Located (HsType GhcRn)), NameSet)
ret
rnLDerivStrategy :: forall a.
HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, FreeVars)
-> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
rnLDerivStrategy :: HsDocContext
-> Maybe (LDerivStrategy GhcPs)
-> RnM (a, NameSet)
-> RnM (Maybe (LDerivStrategy GhcRn), a, NameSet)
rnLDerivStrategy HsDocContext
doc Maybe (LDerivStrategy GhcPs)
mds RnM (a, NameSet)
thing_inside
= case Maybe (LDerivStrategy GhcPs)
mds of
Maybe (LDerivStrategy GhcPs)
Nothing -> Maybe (Located (DerivStrategy GhcRn))
-> RnM (Maybe (Located (DerivStrategy GhcRn)), a, NameSet)
forall ds. ds -> RnM (ds, a, NameSet)
boring_case Maybe (Located (DerivStrategy GhcRn))
forall a. Maybe a
Nothing
Just (L loc ds) ->
SrcSpan
-> RnM (Maybe (Located (DerivStrategy GhcRn)), a, NameSet)
-> RnM (Maybe (Located (DerivStrategy GhcRn)), a, NameSet)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (RnM (Maybe (Located (DerivStrategy GhcRn)), a, NameSet)
-> RnM (Maybe (Located (DerivStrategy GhcRn)), a, NameSet))
-> RnM (Maybe (Located (DerivStrategy GhcRn)), a, NameSet)
-> RnM (Maybe (Located (DerivStrategy GhcRn)), a, NameSet)
forall a b. (a -> b) -> a -> b
$ do
(DerivStrategy GhcRn
ds', a
thing, NameSet
fvs) <- DerivStrategy GhcPs -> RnM (DerivStrategy GhcRn, a, NameSet)
rn_deriv_strat DerivStrategy GhcPs
ds
(Maybe (Located (DerivStrategy GhcRn)), a, NameSet)
-> RnM (Maybe (Located (DerivStrategy GhcRn)), a, NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located (DerivStrategy GhcRn)
-> Maybe (Located (DerivStrategy GhcRn))
forall a. a -> Maybe a
Just (SrcSpan -> DerivStrategy GhcRn -> Located (DerivStrategy GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc DerivStrategy GhcRn
ds'), a
thing, NameSet
fvs)
where
rn_deriv_strat :: DerivStrategy GhcPs
-> RnM (DerivStrategy GhcRn, a, FreeVars)
rn_deriv_strat :: DerivStrategy GhcPs -> RnM (DerivStrategy GhcRn, a, NameSet)
rn_deriv_strat DerivStrategy GhcPs
ds = do
let extNeeded :: LangExt.Extension
extNeeded :: Extension
extNeeded
| ViaStrategy{} <- DerivStrategy GhcPs
ds
= Extension
LangExt.DerivingVia
| Bool
otherwise
= Extension
LangExt.DerivingStrategies
Extension -> TcRn () -> TcRn ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
extNeeded (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWith (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DerivStrategy GhcPs -> SDoc
illegalDerivStrategyErr DerivStrategy GhcPs
ds
case DerivStrategy GhcPs
ds of
DerivStrategy GhcPs
StockStrategy -> DerivStrategy GhcRn -> RnM (DerivStrategy GhcRn, a, NameSet)
forall ds. ds -> RnM (ds, a, NameSet)
boring_case DerivStrategy GhcRn
forall pass. DerivStrategy pass
StockStrategy
DerivStrategy GhcPs
AnyclassStrategy -> DerivStrategy GhcRn -> RnM (DerivStrategy GhcRn, a, NameSet)
forall ds. ds -> RnM (ds, a, NameSet)
boring_case DerivStrategy GhcRn
forall pass. DerivStrategy pass
AnyclassStrategy
DerivStrategy GhcPs
NewtypeStrategy -> DerivStrategy GhcRn -> RnM (DerivStrategy GhcRn, a, NameSet)
forall ds. ds -> RnM (ds, a, NameSet)
boring_case DerivStrategy GhcRn
forall pass. DerivStrategy pass
NewtypeStrategy
ViaStrategy XViaStrategy GhcPs
via_ty ->
do HsDocContext -> Maybe SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
doc Maybe SDoc
inf_err LHsSigType GhcPs
XViaStrategy GhcPs
via_ty
(HsImplicitBndrs GhcRn (Located (HsType GhcRn))
via_ty', NameSet
fvs1) <- HsDocContext
-> TypeOrKind
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, NameSet)
rnHsSigType HsDocContext
doc TypeOrKind
TypeLevel LHsSigType GhcPs
XViaStrategy GhcPs
via_ty
let HsIB { hsib_ext :: forall pass thing. HsImplicitBndrs pass thing -> XHsIB pass thing
hsib_ext = XHsIB GhcRn (Located (HsType GhcRn))
via_imp_tvs
, hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = Located (HsType GhcRn)
via_body } = HsImplicitBndrs GhcRn (Located (HsType GhcRn))
via_ty'
(Maybe [Located (HsTyVarBndr Specificity GhcRn)]
via_exp_tv_bndrs, Located (HsType GhcRn)
via_rho) = LHsType GhcRn
-> (Maybe [LHsTyVarBndr Specificity GhcRn], LHsType GhcRn)
forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe [LHsTyVarBndr Specificity (GhcPass pass)],
LHsType (GhcPass pass))
splitLHsForAllTyInvis_KP Located (HsType GhcRn)
LHsType GhcRn
via_body
via_exp_tvs :: [Name]
via_exp_tvs = [Name]
-> ([Located (HsTyVarBndr Specificity GhcRn)] -> [Name])
-> Maybe [Located (HsTyVarBndr Specificity GhcRn)]
-> [Name]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Located (HsTyVarBndr Specificity GhcRn)] -> [Name]
forall flag (p :: Pass).
[LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]
hsLTyVarNames Maybe [Located (HsTyVarBndr Specificity GhcRn)]
via_exp_tv_bndrs
via_tvs :: [Name]
via_tvs = [Name]
XHsIB GhcRn (Located (HsType GhcRn))
via_imp_tvs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
via_exp_tvs
HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
doc
(SDoc -> SDoc
quotes (String -> SDoc
text String
"via") SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"type") Located (HsType GhcRn)
LHsType GhcRn
via_rho
(a
thing, NameSet
fvs2) <- [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
forall a. [Name] -> RnM (a, NameSet) -> RnM (a, NameSet)
extendTyVarEnvFVRn [Name]
via_tvs RnM (a, NameSet)
thing_inside
(DerivStrategy GhcRn, a, NameSet)
-> RnM (DerivStrategy GhcRn, a, NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XViaStrategy GhcRn -> DerivStrategy GhcRn
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy HsImplicitBndrs GhcRn (Located (HsType GhcRn))
XViaStrategy GhcRn
via_ty', a
thing, NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs2)
inf_err :: Maybe SDoc
inf_err = SDoc -> Maybe SDoc
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 :: ds -> RnM (ds, a, NameSet)
boring_case ds
ds = do
(a
thing, NameSet
fvs) <- RnM (a, NameSet)
thing_inside
(ds, a, NameSet) -> RnM (ds, a, NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ds
ds, a
thing, NameSet
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
<+> DerivStrategy GhcPs -> SDoc
forall a. DerivStrategy a -> SDoc
derivStrategyName DerivStrategy GhcPs
ds
, String -> SDoc
text String
enableStrategy ]
where
enableStrategy :: String
enableStrategy :: String
enableStrategy
| ViaStrategy{} <- DerivStrategy GhcPs
ds
= 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, NameSet)
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
, fdFixity :: forall pass. FamilyDecl pass -> LexicalFixity
fdFixity = LexicalFixity
fixity
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcPs
info, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = LFamilyResultSig GhcPs
res_sig
, fdInjectivityAnn :: forall pass. FamilyDecl pass -> Maybe (LInjectivityAnn pass)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcPs)
injectivity })
= do { Located Name
tycon' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
LIdP GhcPs
tycon
; ((LHsQTyVars GhcRn
tyvars', Located (FamilyResultSig GhcRn)
res_sig', Maybe (Located (InjectivityAnn GhcRn))
injectivity'), NameSet
fv1) <-
HsDocContext
-> Maybe Name
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn, Located (FamilyResultSig GhcRn),
Maybe (Located (InjectivityAnn GhcRn))),
NameSet))
-> RnM
((LHsQTyVars GhcRn, Located (FamilyResultSig GhcRn),
Maybe (Located (InjectivityAnn GhcRn))),
NameSet)
forall a b.
HsDocContext
-> Maybe a
-> [GenLocated SrcSpan RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindHsQTyVars HsDocContext
doc Maybe Name
mb_cls [GenLocated SrcSpan RdrName]
kvs LHsQTyVars GhcPs
tyvars ((LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn, Located (FamilyResultSig GhcRn),
Maybe (Located (InjectivityAnn GhcRn))),
NameSet))
-> RnM
((LHsQTyVars GhcRn, Located (FamilyResultSig GhcRn),
Maybe (Located (InjectivityAnn GhcRn))),
NameSet))
-> (LHsQTyVars GhcRn
-> Bool
-> RnM
((LHsQTyVars GhcRn, Located (FamilyResultSig GhcRn),
Maybe (Located (InjectivityAnn GhcRn))),
NameSet))
-> RnM
((LHsQTyVars GhcRn, Located (FamilyResultSig GhcRn),
Maybe (Located (InjectivityAnn GhcRn))),
NameSet)
forall a b. (a -> b) -> a -> b
$ \ LHsQTyVars GhcRn
tyvars' Bool
_ ->
do { let rn_sig :: FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, NameSet)
rn_sig = HsDocContext
-> FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, NameSet)
rnFamResultSig HsDocContext
doc
; (Located (FamilyResultSig GhcRn)
res_sig', NameSet
fv_kind) <- (FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, NameSet))
-> Located (FamilyResultSig GhcPs)
-> TcM (Located (FamilyResultSig GhcRn), NameSet)
forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, NameSet)
rn_sig Located (FamilyResultSig GhcPs)
LFamilyResultSig GhcPs
res_sig
; Maybe (Located (InjectivityAnn GhcRn))
injectivity' <- (Located (InjectivityAnn GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn)))
-> Maybe (Located (InjectivityAnn GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe (Located (InjectivityAnn GhcRn)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (LHsQTyVars GhcRn
-> LFamilyResultSig GhcRn
-> LInjectivityAnn GhcPs
-> RnM (LInjectivityAnn GhcRn)
rnInjectivityAnn LHsQTyVars GhcRn
tyvars' Located (FamilyResultSig GhcRn)
LFamilyResultSig GhcRn
res_sig')
Maybe (Located (InjectivityAnn GhcPs))
Maybe (LInjectivityAnn GhcPs)
injectivity
; ((LHsQTyVars GhcRn, Located (FamilyResultSig GhcRn),
Maybe (Located (InjectivityAnn GhcRn))),
NameSet)
-> RnM
((LHsQTyVars GhcRn, Located (FamilyResultSig GhcRn),
Maybe (Located (InjectivityAnn GhcRn))),
NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ( (LHsQTyVars GhcRn
tyvars', Located (FamilyResultSig GhcRn)
res_sig', Maybe (Located (InjectivityAnn GhcRn))
injectivity') , NameSet
fv_kind ) }
; (FamilyInfo GhcRn
info', NameSet
fv2) <- FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, NameSet)
rn_info FamilyInfo GhcPs
info
; (FamilyDecl GhcRn, NameSet) -> RnM (FamilyDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (FamilyDecl :: forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl { fdExt :: XCFamilyDecl GhcRn
fdExt = NoExtField
XCFamilyDecl GhcRn
noExtField
, fdLName :: LIdP GhcRn
fdLName = Located Name
LIdP GhcRn
tycon', fdTyVars :: LHsQTyVars GhcRn
fdTyVars = LHsQTyVars GhcRn
tyvars'
, fdFixity :: LexicalFixity
fdFixity = LexicalFixity
fixity
, fdInfo :: FamilyInfo GhcRn
fdInfo = FamilyInfo GhcRn
info', fdResultSig :: LFamilyResultSig GhcRn
fdResultSig = Located (FamilyResultSig GhcRn)
LFamilyResultSig GhcRn
res_sig'
, fdInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
fdInjectivityAnn = Maybe (Located (InjectivityAnn GhcRn))
Maybe (LInjectivityAnn GhcRn)
injectivity' }
, NameSet
fv1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fv2) }
where
doc :: HsDocContext
doc = GenLocated SrcSpan RdrName -> HsDocContext
TyFamilyCtx GenLocated SrcSpan RdrName
LIdP GhcPs
tycon
kvs :: [GenLocated SrcSpan RdrName]
kvs = LFamilyResultSig GhcPs -> [GenLocated SrcSpan RdrName]
extractRdrKindSigVars LFamilyResultSig GhcPs
res_sig
rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, NameSet)
rn_info (ClosedTypeFamily (Just [LTyFamInstEqn GhcPs]
eqns))
= do { ([Located (FamInstEqn GhcRn (Located (HsType GhcRn)))]
eqns', NameSet
fvs)
<- (FamInstEqn GhcPs (Located (HsType GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(FamInstEqn GhcRn (Located (HsType GhcRn)), NameSet))
-> [Located (FamInstEqn GhcPs (Located (HsType GhcPs)))]
-> RnM
([Located (FamInstEqn GhcRn (Located (HsType GhcRn)))], NameSet)
forall a b.
(a -> RnM (b, NameSet))
-> [Located a] -> RnM ([Located b], NameSet)
rnList (AssocTyFamInfo
-> TyFamInstEqn GhcPs -> RnM (TyFamInstEqn GhcRn, NameSet)
rnTyFamInstEqn (ClosedTyFamInfo -> AssocTyFamInfo
NonAssocTyFamEqn ClosedTyFamInfo
ClosedTyFam)) [Located (FamInstEqn GhcPs (Located (HsType GhcPs)))]
[LTyFamInstEqn GhcPs]
eqns
; (FamilyInfo GhcRn, NameSet) -> RnM (FamilyInfo GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily ([Located (FamInstEqn GhcRn (Located (HsType GhcRn)))]
-> Maybe [Located (FamInstEqn GhcRn (Located (HsType GhcRn)))]
forall a. a -> Maybe a
Just [Located (FamInstEqn GhcRn (Located (HsType GhcRn)))]
eqns'), NameSet
fvs) }
rn_info (ClosedTypeFamily Maybe [LTyFamInstEqn GhcPs]
Nothing)
= (FamilyInfo GhcRn, NameSet) -> RnM (FamilyInfo GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily Maybe [LTyFamInstEqn GhcRn]
forall a. Maybe a
Nothing, NameSet
emptyFVs)
rn_info FamilyInfo GhcPs
OpenTypeFamily = (FamilyInfo GhcRn, NameSet) -> RnM (FamilyInfo GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (FamilyInfo GhcRn
forall pass. FamilyInfo pass
OpenTypeFamily, NameSet
emptyFVs)
rn_info FamilyInfo GhcPs
DataFamily = (FamilyInfo GhcRn, NameSet) -> RnM (FamilyInfo GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (FamilyInfo GhcRn
forall pass. FamilyInfo pass
DataFamily, NameSet
emptyFVs)
rnFamResultSig :: HsDocContext
-> FamilyResultSig GhcPs
-> RnM (FamilyResultSig GhcRn, FreeVars)
rnFamResultSig :: HsDocContext
-> FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, NameSet)
rnFamResultSig HsDocContext
_ (NoSig XNoSig GhcPs
_)
= (FamilyResultSig GhcRn, NameSet)
-> RnM (FamilyResultSig GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XNoSig GhcRn -> FamilyResultSig GhcRn
forall pass. XNoSig pass -> FamilyResultSig pass
NoSig NoExtField
XNoSig GhcRn
noExtField, NameSet
emptyFVs)
rnFamResultSig HsDocContext
doc (KindSig XCKindSig GhcPs
_ LHsType GhcPs
kind)
= do { (Located (HsType GhcRn)
rndKind, NameSet
ftvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsKind HsDocContext
doc LHsType GhcPs
kind
; (FamilyResultSig GhcRn, NameSet)
-> RnM (FamilyResultSig GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCKindSig GhcRn -> LHsType GhcRn -> FamilyResultSig GhcRn
forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
KindSig NoExtField
XCKindSig GhcRn
noExtField Located (HsType GhcRn)
LHsType GhcRn
rndKind, NameSet
ftvs) }
rnFamResultSig HsDocContext
doc (TyVarSig XTyVarSig GhcPs
_ LHsTyVarBndr () GhcPs
tvbndr)
= do {
LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
; let resName :: IdP GhcPs
resName = LHsTyVarBndr () GhcPs -> IdP GhcPs
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcPs
tvbndr
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RdrName
IdP GhcPs
resName RdrName -> LocalRdrEnv -> Bool
`elemLocalRdrEnv` LocalRdrEnv
rdr_env) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> TcRn ()
addErrAt (Located (HsTyVarBndr () GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (HsTyVarBndr () GhcPs)
LHsTyVarBndr () GhcPs
tvbndr) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
([SDoc] -> SDoc
hsep [ String -> SDoc
text String
"Type variable", SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
IdP GhcPs
resName) SDoc -> SDoc -> SDoc
<> SDoc
comma
, String -> SDoc
text String
"naming a type family result,"
] SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"shadows an already bound type variable")
; HsDocContext
-> Maybe Any
-> LHsTyVarBndr () GhcPs
-> (LHsTyVarBndr () GhcRn -> RnM (FamilyResultSig GhcRn, NameSet))
-> RnM (FamilyResultSig GhcRn, NameSet)
forall a flag b.
HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindLHsTyVarBndr HsDocContext
doc Maybe Any
forall a. Maybe a
Nothing
LHsTyVarBndr () GhcPs
tvbndr ((LHsTyVarBndr () GhcRn -> RnM (FamilyResultSig GhcRn, NameSet))
-> RnM (FamilyResultSig GhcRn, NameSet))
-> (LHsTyVarBndr () GhcRn -> RnM (FamilyResultSig GhcRn, NameSet))
-> RnM (FamilyResultSig GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ LHsTyVarBndr () GhcRn
tvbndr' ->
(FamilyResultSig GhcRn, NameSet)
-> RnM (FamilyResultSig GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTyVarSig GhcRn -> LHsTyVarBndr () GhcRn -> FamilyResultSig GhcRn
forall pass.
XTyVarSig pass -> LHsTyVarBndr () pass -> FamilyResultSig pass
TyVarSig NoExtField
XTyVarSig GhcRn
noExtField LHsTyVarBndr () GhcRn
tvbndr', Name -> NameSet
unitFV (LHsTyVarBndr () GhcRn -> IdP GhcRn
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
tvbndr')) }
rnInjectivityAnn :: LHsQTyVars GhcRn
-> LFamilyResultSig GhcRn
-> LInjectivityAnn GhcPs
-> RnM (LInjectivityAnn GhcRn)
rnInjectivityAnn :: LHsQTyVars GhcRn
-> LFamilyResultSig GhcRn
-> LInjectivityAnn GhcPs
-> RnM (LInjectivityAnn GhcRn)
rnInjectivityAnn LHsQTyVars GhcRn
tvBndrs (L _ (TyVarSig _ resTv))
(L srcSpan (InjectivityAnn injFrom injTo))
= do
{ (injDecl' :: Located (InjectivityAnn GhcRn)
injDecl'@(L SrcSpan
_ (InjectivityAnn LIdP GhcRn
injFrom' [LIdP GhcRn]
injTo')), Bool
noRnErrors)
<- IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> TcRn (Located (InjectivityAnn GhcRn), Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs (IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> TcRn (Located (InjectivityAnn GhcRn), Bool))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> TcRn (Located (InjectivityAnn GhcRn), Bool)
forall a b. (a -> b) -> a -> b
$
[Name]
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [LHsTyVarBndr () GhcRn -> IdP GhcRn
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
resTv] (IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn)))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
forall a b. (a -> b) -> a -> b
$
do { Located Name
injFrom' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
rnLTyVar GenLocated SrcSpan RdrName
LIdP GhcPs
injFrom
; [Located Name]
injTo' <- (GenLocated SrcSpan RdrName -> RnM (Located Name))
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan RdrName -> RnM (Located Name)
rnLTyVar [GenLocated SrcSpan RdrName]
[LIdP GhcPs]
injTo
; Located (InjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (InjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn)))
-> Located (InjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> InjectivityAnn GhcRn -> Located (InjectivityAnn GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
srcSpan (LIdP GhcRn -> [LIdP GhcRn] -> InjectivityAnn GhcRn
forall pass. LIdP pass -> [LIdP pass] -> InjectivityAnn pass
InjectivityAnn Located Name
LIdP GhcRn
injFrom' [Located Name]
[LIdP GhcRn]
injTo') }
; let tvNames :: Set Name
tvNames = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ LHsQTyVars GhcRn -> [Name]
hsAllLTyVarNames LHsQTyVars GhcRn
tvBndrs
resName :: IdP GhcRn
resName = LHsTyVarBndr () GhcRn -> IdP GhcRn
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName LHsTyVarBndr () GhcRn
resTv
lhsValid :: Bool
lhsValid = Ordering
EQ Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== (Name -> Name -> Ordering
stableNameCmp Name
IdP GhcRn
resName (Located Name -> Name
forall l e. GenLocated l e -> e
unLoc Located Name
LIdP GhcRn
injFrom'))
rhsValid :: Set Name
rhsValid = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall l e. GenLocated l e -> e
unLoc [Located Name]
[LIdP GhcRn]
injTo') Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Name
tvNames
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
noRnErrors Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
lhsValid) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> TcRn ()
addErrAt (GenLocated SrcSpan RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpan RdrName
LIdP GhcPs
injFrom)
( [SDoc] -> SDoc
vcat [ String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"Incorrect type variable on the LHS of "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"injectivity condition"
, Int -> SDoc -> SDoc
nest Int
5
( [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Expected :" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
IdP GhcRn
resName
, String -> SDoc
text String
"Actual :" SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpan RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan RdrName
LIdP GhcPs
injFrom ])])
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
noRnErrors Bool -> Bool -> Bool
&& Bool -> Bool
not (Set Name -> Bool
forall a. Set a -> Bool
Set.null Set Name
rhsValid)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { let errorVars :: [Name]
errorVars = Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Set Name
rhsValid
; SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
srcSpan (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ ( [SDoc] -> SDoc
hsep
[ String -> SDoc
text String
"Unknown type variable" SDoc -> SDoc -> SDoc
<> [Name] -> SDoc
forall a. [a] -> SDoc
plural [Name]
errorVars
, String -> SDoc
text String
"on the RHS of injectivity condition:"
, [Name] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [Name]
errorVars ] ) }
; Located (InjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
forall (m :: * -> *) a. Monad m => a -> m a
return Located (InjectivityAnn GhcRn)
injDecl' }
rnInjectivityAnn LHsQTyVars GhcRn
_ LFamilyResultSig GhcRn
_ (L srcSpan (InjectivityAnn injFrom injTo)) =
SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
srcSpan (IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn)))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
forall a b. (a -> b) -> a -> b
$ do
(Located (InjectivityAnn GhcRn)
injDecl', Bool
_) <- IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> TcRn (Located (InjectivityAnn GhcRn), Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs (IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> TcRn (Located (InjectivityAnn GhcRn), Bool))
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
-> TcRn (Located (InjectivityAnn GhcRn), Bool)
forall a b. (a -> b) -> a -> b
$ do
Located Name
injFrom' <- GenLocated SrcSpan RdrName -> RnM (Located Name)
rnLTyVar GenLocated SrcSpan RdrName
LIdP GhcPs
injFrom
[Located Name]
injTo' <- (GenLocated SrcSpan RdrName -> RnM (Located Name))
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan RdrName -> RnM (Located Name)
rnLTyVar [GenLocated SrcSpan RdrName]
[LIdP GhcPs]
injTo
Located (InjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (InjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn)))
-> Located (InjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> InjectivityAnn GhcRn -> Located (InjectivityAnn GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
srcSpan (LIdP GhcRn -> [LIdP GhcRn] -> InjectivityAnn GhcRn
forall pass. LIdP pass -> [LIdP pass] -> InjectivityAnn pass
InjectivityAnn Located Name
LIdP GhcRn
injFrom' [Located Name]
[LIdP GhcRn]
injTo')
Located (InjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (InjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn)))
-> Located (InjectivityAnn GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located (InjectivityAnn GhcRn))
forall a b. (a -> b) -> a -> b
$ Located (InjectivityAnn GhcRn)
injDecl'
rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], NameSet)
rnConDecls = (Located (ConDecl GhcPs) -> RnM (Located (ConDecl GhcRn), NameSet))
-> [Located (ConDecl GhcPs)]
-> RnM ([Located (ConDecl GhcRn)], NameSet)
forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn ((ConDecl GhcPs -> TcM (ConDecl GhcRn, NameSet))
-> Located (ConDecl GhcPs)
-> RnM (Located (ConDecl GhcRn), NameSet)
forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM ConDecl GhcPs -> TcM (ConDecl GhcRn, NameSet)
rnConDecl)
rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl :: ConDecl GhcPs -> TcM (ConDecl GhcRn, NameSet)
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 -> XRec pass Bool
con_forall = XRec GhcPs Bool
forall })
= do { ()
_ <- (RdrName -> TcRn ()) -> GenLocated SrcSpan RdrName -> TcRn ()
forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM RdrName -> TcRn ()
checkConName GenLocated SrcSpan RdrName
LIdP GhcPs
name
; Located Name
new_name <- GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn GenLocated SrcSpan RdrName
LIdP GhcPs
name
; let ctxt :: HsDocContext
ctxt = [Located Name] -> HsDocContext
ConDeclCtx [Located Name
new_name]
; HsDocContext
-> WarnUnusedForalls
-> Maybe Any
-> [LHsTyVarBndr Specificity GhcPs]
-> ([LHsTyVarBndr Specificity GhcRn]
-> TcM (ConDecl GhcRn, NameSet))
-> TcM (ConDecl GhcRn, NameSet)
forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindLHsTyVarBndrs HsDocContext
ctxt WarnUnusedForalls
WarnUnusedForalls
Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr Specificity GhcPs]
ex_tvs (([LHsTyVarBndr Specificity GhcRn] -> TcM (ConDecl GhcRn, NameSet))
-> TcM (ConDecl GhcRn, NameSet))
-> ([LHsTyVarBndr Specificity GhcRn]
-> TcM (ConDecl GhcRn, NameSet))
-> TcM (ConDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr Specificity GhcRn]
new_ex_tvs ->
do { (Maybe (Located [Located (HsType GhcRn)])
new_context, NameSet
fvs1) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), NameSet)
rnMbContext HsDocContext
ctxt Maybe (LHsContext GhcPs)
mcxt
; (HsConDetails
(HsScaled GhcRn (Located (HsType GhcRn)))
(Located [Located (ConDeclField GhcRn)])
new_args, NameSet
fvs2) <- Name
-> HsDocContext
-> HsConDeclH98Details GhcPs
-> RnM (HsConDeclH98Details GhcRn, NameSet)
rnConDeclH98Details (Located Name -> Name
forall l e. GenLocated l e -> e
unLoc Located Name
new_name) HsDocContext
ctxt HsConDeclH98Details GhcPs
args
; let all_fvs :: NameSet
all_fvs = NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs2
; String -> SDoc -> TcRn ()
traceRn String
"rnConDecl (ConDeclH98)" (GenLocated SrcSpan RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan RdrName
LIdP GhcPs
name SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"ex_tvs:" SDoc -> SDoc -> SDoc
<+> [Located (HsTyVarBndr Specificity GhcPs)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located (HsTyVarBndr Specificity GhcPs)]
[LHsTyVarBndr Specificity GhcPs]
ex_tvs
, String -> SDoc
text String
"new_ex_dqtvs':" SDoc -> SDoc -> SDoc
<+> [Located (HsTyVarBndr Specificity GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located (HsTyVarBndr Specificity GhcRn)]
[LHsTyVarBndr Specificity GhcRn]
new_ex_tvs ])
; (ConDecl GhcRn, NameSet) -> TcM (ConDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConDecl GhcPs
decl { con_ext :: XConDeclH98 GhcRn
con_ext = NoExtField
XConDeclH98 GhcRn
noExtField
, con_name :: LIdP GhcRn
con_name = Located Name
LIdP GhcRn
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 (Located [Located (HsType GhcRn)])
Maybe (LHsContext GhcRn)
new_context, con_args :: HsConDeclH98Details GhcRn
con_args = HsConDetails
(HsScaled GhcRn (Located (HsType GhcRn)))
(Located [Located (ConDeclField GhcRn)])
HsConDeclH98Details GhcRn
new_args
, con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
mb_doc
, con_forall :: XRec GhcRn Bool
con_forall = XRec GhcPs Bool
XRec GhcRn Bool
forall },
NameSet
all_fvs) }}
rnConDecl decl :: ConDecl GhcPs
decl@(ConDeclGADT { con_names :: forall pass. ConDecl pass -> [LIdP pass]
con_names = [LIdP GhcPs]
names
, con_forall :: forall pass. ConDecl pass -> XRec pass Bool
con_forall = forall :: XRec GhcPs Bool
forall@(L _ explicit_forall)
, con_qvars :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_qvars = [LHsTyVarBndr Specificity GhcPs]
explicit_tkvs
, 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 { (GenLocated SrcSpan RdrName -> TcRn ())
-> [GenLocated SrcSpan RdrName] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((RdrName -> TcRn ()) -> GenLocated SrcSpan RdrName -> TcRn ()
forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM RdrName -> TcRn ()
checkConName) [GenLocated SrcSpan RdrName]
[LIdP GhcPs]
names
; [Located Name]
new_names <- (GenLocated SrcSpan RdrName -> RnM (Located Name))
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn [GenLocated SrcSpan RdrName]
[LIdP GhcPs]
names
; [GenLocated SrcSpan RdrName]
implicit_bndrs <- Bool
-> [GenLocated SrcSpan RdrName] -> RnM [GenLocated SrcSpan RdrName]
forAllOrNothing Bool
explicit_forall
([GenLocated SrcSpan RdrName] -> RnM [GenLocated SrcSpan RdrName])
-> [GenLocated SrcSpan RdrName] -> RnM [GenLocated SrcSpan RdrName]
forall a b. (a -> b) -> a -> b
$ [LHsTyVarBndr Specificity GhcPs]
-> [GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName]
forall flag.
[LHsTyVarBndr flag GhcPs]
-> [GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName]
extractHsTvBndrs [LHsTyVarBndr Specificity GhcPs]
explicit_tkvs
([GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName])
-> [GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName]
forall a b. (a -> b) -> a -> b
$ [LHsType GhcPs]
-> [GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName]
extractHsTysRdrTyVars (Maybe (LHsContext GhcPs) -> [LHsType GhcPs]
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)]
hsConDeclTheta Maybe (LHsContext GhcPs)
mcxt)
([GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName])
-> [GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName]
forall a b. (a -> b) -> a -> b
$ HsConDeclGADTDetails GhcPs
-> [GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName]
extractConDeclGADTDetailsTyVars HsConDeclGADTDetails GhcPs
args
([GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName])
-> [GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName]
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> [GenLocated SrcSpan RdrName]
extractHsTyRdrTyVars LHsType GhcPs
res_ty
; let ctxt :: HsDocContext
ctxt = [Located Name] -> HsDocContext
ConDeclCtx [Located Name]
new_names
; Maybe Any
-> [GenLocated SrcSpan RdrName]
-> ([Name] -> TcM (ConDecl GhcRn, NameSet))
-> TcM (ConDecl GhcRn, NameSet)
forall assoc a.
Maybe assoc
-> [GenLocated SrcSpan RdrName]
-> ([Name] -> RnM (a, NameSet))
-> RnM (a, NameSet)
rnImplicitBndrs Maybe Any
forall a. Maybe a
Nothing [GenLocated SrcSpan RdrName]
implicit_bndrs (([Name] -> TcM (ConDecl GhcRn, NameSet))
-> TcM (ConDecl GhcRn, NameSet))
-> ([Name] -> TcM (ConDecl GhcRn, NameSet))
-> TcM (ConDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ [Name]
implicit_tkvs ->
HsDocContext
-> WarnUnusedForalls
-> Maybe Any
-> [LHsTyVarBndr Specificity GhcPs]
-> ([LHsTyVarBndr Specificity GhcRn]
-> TcM (ConDecl GhcRn, NameSet))
-> TcM (ConDecl GhcRn, NameSet)
forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, NameSet))
-> RnM (b, NameSet)
bindLHsTyVarBndrs HsDocContext
ctxt WarnUnusedForalls
WarnUnusedForalls
Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr Specificity GhcPs]
explicit_tkvs (([LHsTyVarBndr Specificity GhcRn] -> TcM (ConDecl GhcRn, NameSet))
-> TcM (ConDecl GhcRn, NameSet))
-> ([LHsTyVarBndr Specificity GhcRn]
-> TcM (ConDecl GhcRn, NameSet))
-> TcM (ConDecl GhcRn, NameSet)
forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr Specificity GhcRn]
explicit_tkvs ->
do { (Maybe (Located [Located (HsType GhcRn)])
new_cxt, NameSet
fvs1) <- HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), NameSet)
rnMbContext HsDocContext
ctxt Maybe (LHsContext GhcPs)
mcxt
; (HsConDeclGADTDetails GhcRn
new_args, NameSet
fvs2) <- Name
-> HsDocContext
-> HsConDeclGADTDetails GhcPs
-> RnM (HsConDeclGADTDetails GhcRn, NameSet)
rnConDeclGADTDetails (Located Name -> Name
forall l e. GenLocated l e -> e
unLoc ([Located Name] -> Located Name
forall a. [a] -> a
head [Located Name]
new_names)) HsDocContext
ctxt HsConDeclGADTDetails GhcPs
args
; (Located (HsType GhcRn)
new_res_ty, NameSet
fvs3) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, NameSet)
rnLHsType HsDocContext
ctxt LHsType GhcPs
res_ty
; HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
ctxt
(String -> SDoc
text String
"GADT constructor type signature") Located (HsType GhcRn)
LHsType GhcRn
new_res_ty
; let all_fvs :: NameSet
all_fvs = NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs2 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs3
; String -> SDoc -> TcRn ()
traceRn String
"rnConDecl (ConDeclGADT)"
([GenLocated SrcSpan RdrName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan RdrName]
[LIdP GhcPs]
names SDoc -> SDoc -> SDoc
$$ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
implicit_tkvs SDoc -> SDoc -> SDoc
$$ [Located (HsTyVarBndr Specificity GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located (HsTyVarBndr Specificity GhcRn)]
[LHsTyVarBndr Specificity GhcRn]
explicit_tkvs)
; (ConDecl GhcRn, NameSet) -> TcM (ConDecl GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConDecl GhcPs
decl { con_g_ext :: XConDeclGADT GhcRn
con_g_ext = [Name]
XConDeclGADT GhcRn
implicit_tkvs, con_names :: [LIdP GhcRn]
con_names = [Located Name]
[LIdP GhcRn]
new_names
, con_qvars :: [LHsTyVarBndr Specificity GhcRn]
con_qvars = [LHsTyVarBndr Specificity GhcRn]
explicit_tkvs, con_mb_cxt :: Maybe (LHsContext GhcRn)
con_mb_cxt = Maybe (Located [Located (HsType GhcRn)])
Maybe (LHsContext GhcRn)
new_cxt
, con_g_args :: HsConDeclGADTDetails GhcRn
con_g_args = HsConDeclGADTDetails GhcRn
new_args, con_res_ty :: LHsType GhcRn
con_res_ty = Located (HsType GhcRn)
LHsType GhcRn
new_res_ty
, con_doc :: Maybe LHsDocString
con_doc = Maybe LHsDocString
mb_doc
, con_forall :: XRec GhcRn Bool
con_forall = XRec GhcPs Bool
XRec GhcRn Bool
forall },
NameSet
all_fvs) } }
rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
rnMbContext :: HsDocContext
-> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), NameSet)
rnMbContext HsDocContext
_ Maybe (LHsContext GhcPs)
Nothing = (Maybe (Located [Located (HsType GhcRn)]), NameSet)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (Located [Located (HsType GhcRn)]), NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Located [Located (HsType GhcRn)])
forall a. Maybe a
Nothing, NameSet
emptyFVs)
rnMbContext HsDocContext
doc (Just LHsContext GhcPs
cxt) = do { (Located [Located (HsType GhcRn)]
ctx',NameSet
fvs) <- HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, NameSet)
rnContext HsDocContext
doc LHsContext GhcPs
cxt
; (Maybe (Located [Located (HsType GhcRn)]), NameSet)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (Located [Located (HsType GhcRn)]), NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located [Located (HsType GhcRn)]
-> Maybe (Located [Located (HsType GhcRn)])
forall a. a -> Maybe a
Just Located [Located (HsType GhcRn)]
ctx',NameSet
fvs) }
rnConDeclH98Details ::
Name
-> HsDocContext
-> HsConDeclH98Details GhcPs
-> RnM (HsConDeclH98Details GhcRn, FreeVars)
rnConDeclH98Details :: Name
-> HsDocContext
-> HsConDeclH98Details GhcPs
-> RnM (HsConDeclH98Details GhcRn, NameSet)
rnConDeclH98Details Name
_ HsDocContext
doc (PrefixCon [HsScaled GhcPs (LHsType GhcPs)]
tys)
= do { ([HsScaled GhcRn (Located (HsType GhcRn))]
new_tys, NameSet
fvs) <- (HsScaled GhcPs (Located (HsType GhcPs))
-> RnM (HsScaled GhcRn (Located (HsType GhcRn)), NameSet))
-> [HsScaled GhcPs (Located (HsType GhcPs))]
-> RnM ([HsScaled GhcRn (Located (HsType GhcRn))], NameSet)
forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn (HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), NameSet)
rnScaledLHsType HsDocContext
doc) [HsScaled GhcPs (Located (HsType GhcPs))]
[HsScaled GhcPs (LHsType GhcPs)]
tys
; (HsConDetails
(HsScaled GhcRn (Located (HsType GhcRn)))
(Located [Located (ConDeclField GhcRn)]),
NameSet)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsConDetails
(HsScaled GhcRn (Located (HsType GhcRn)))
(Located [Located (ConDeclField GhcRn)]),
NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsScaled GhcRn (Located (HsType GhcRn))]
-> HsConDetails
(HsScaled GhcRn (Located (HsType GhcRn)))
(Located [Located (ConDeclField GhcRn)])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [HsScaled GhcRn (Located (HsType GhcRn))]
new_tys, NameSet
fvs) }
rnConDeclH98Details Name
_ HsDocContext
doc (InfixCon HsScaled GhcPs (LHsType GhcPs)
ty1 HsScaled GhcPs (LHsType GhcPs)
ty2)
= do { (HsScaled GhcRn (Located (HsType GhcRn))
new_ty1, NameSet
fvs1) <- HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), NameSet)
rnScaledLHsType HsDocContext
doc HsScaled GhcPs (LHsType GhcPs)
ty1
; (HsScaled GhcRn (Located (HsType GhcRn))
new_ty2, NameSet
fvs2) <- HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), NameSet)
rnScaledLHsType HsDocContext
doc HsScaled GhcPs (LHsType GhcPs)
ty2
; (HsConDetails
(HsScaled GhcRn (Located (HsType GhcRn)))
(Located [Located (ConDeclField GhcRn)]),
NameSet)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsConDetails
(HsScaled GhcRn (Located (HsType GhcRn)))
(Located [Located (ConDeclField GhcRn)]),
NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsScaled GhcRn (Located (HsType GhcRn))
-> HsScaled GhcRn (Located (HsType GhcRn))
-> HsConDetails
(HsScaled GhcRn (Located (HsType GhcRn)))
(Located [Located (ConDeclField GhcRn)])
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon HsScaled GhcRn (Located (HsType GhcRn))
new_ty1 HsScaled GhcRn (Located (HsType GhcRn))
new_ty2, NameSet
fvs1 NameSet -> NameSet -> NameSet
`plusFV` NameSet
fvs2) }
rnConDeclH98Details Name
con HsDocContext
doc (RecCon XRec GhcPs [LConDeclField GhcPs]
flds)
= do { (Located [Located (ConDeclField GhcRn)]
new_flds, NameSet
fvs) <- Name
-> HsDocContext
-> Located [LConDeclField GhcPs]
-> RnM (Located [LConDeclField GhcRn], NameSet)
rnRecConDeclFields Name
con HsDocContext
doc Located [LConDeclField GhcPs]
XRec GhcPs [LConDeclField GhcPs]
flds
; (HsConDetails
(HsScaled GhcRn (Located (HsType GhcRn)))
(Located [Located (ConDeclField GhcRn)]),
NameSet)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsConDetails
(HsScaled GhcRn (Located (HsType GhcRn)))
(Located [Located (ConDeclField GhcRn)]),
NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located [Located (ConDeclField GhcRn)]
-> HsConDetails
(HsScaled GhcRn (Located (HsType GhcRn)))
(Located [Located (ConDeclField GhcRn)])
forall arg rec. rec -> HsConDetails arg rec
RecCon Located [Located (ConDeclField GhcRn)]
new_flds, NameSet
fvs) }
rnConDeclGADTDetails ::
Name
-> HsDocContext
-> HsConDeclGADTDetails GhcPs
-> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
rnConDeclGADTDetails :: Name
-> HsDocContext
-> HsConDeclGADTDetails GhcPs
-> RnM (HsConDeclGADTDetails GhcRn, NameSet)
rnConDeclGADTDetails Name
_ HsDocContext
doc (PrefixConGADT [HsScaled GhcPs (LHsType GhcPs)]
tys)
= do { ([HsScaled GhcRn (Located (HsType GhcRn))]
new_tys, NameSet
fvs) <- (HsScaled GhcPs (Located (HsType GhcPs))
-> RnM (HsScaled GhcRn (Located (HsType GhcRn)), NameSet))
-> [HsScaled GhcPs (Located (HsType GhcPs))]
-> RnM ([HsScaled GhcRn (Located (HsType GhcRn))], NameSet)
forall a b. (a -> RnM (b, NameSet)) -> [a] -> RnM ([b], NameSet)
mapFvRn (HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), NameSet)
rnScaledLHsType HsDocContext
doc) [HsScaled GhcPs (Located (HsType GhcPs))]
[HsScaled GhcPs (LHsType GhcPs)]
tys
; (HsConDeclGADTDetails GhcRn, NameSet)
-> RnM (HsConDeclGADTDetails GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsScaled GhcRn (LHsType GhcRn)] -> HsConDeclGADTDetails GhcRn
forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT [HsScaled GhcRn (Located (HsType GhcRn))]
[HsScaled GhcRn (LHsType GhcRn)]
new_tys, NameSet
fvs) }
rnConDeclGADTDetails Name
con HsDocContext
doc (RecConGADT XRec GhcPs [LConDeclField GhcPs]
flds)
= do { (Located [Located (ConDeclField GhcRn)]
new_flds, NameSet
fvs) <- Name
-> HsDocContext
-> Located [LConDeclField GhcPs]
-> RnM (Located [LConDeclField GhcRn], NameSet)
rnRecConDeclFields Name
con HsDocContext
doc Located [LConDeclField GhcPs]
XRec GhcPs [LConDeclField GhcPs]
flds
; (HsConDeclGADTDetails GhcRn, NameSet)
-> RnM (HsConDeclGADTDetails GhcRn, NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (XRec GhcRn [LConDeclField GhcRn] -> HsConDeclGADTDetails GhcRn
forall pass.
XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass
RecConGADT Located [Located (ConDeclField GhcRn)]
XRec GhcRn [LConDeclField GhcRn]
new_flds, NameSet
fvs) }
rnRecConDeclFields ::
Name
-> HsDocContext
-> Located [LConDeclField GhcPs]
-> RnM (Located [LConDeclField GhcRn], FreeVars)
rnRecConDeclFields :: Name
-> HsDocContext
-> Located [LConDeclField GhcPs]
-> RnM (Located [LConDeclField GhcRn], NameSet)
rnRecConDeclFields Name
con HsDocContext
doc (L SrcSpan
l [LConDeclField GhcPs]
fields)
= do { [FieldLabel]
fls <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
con
; ([Located (ConDeclField GhcRn)]
new_fields, NameSet
fvs) <- HsDocContext
-> [FieldLabel]
-> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], NameSet)
rnConDeclFields HsDocContext
doc [FieldLabel]
fls [LConDeclField GhcPs]
fields
; (Located [Located (ConDeclField GhcRn)], NameSet)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Located [Located (ConDeclField GhcRn)], NameSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan
-> [Located (ConDeclField GhcRn)]
-> Located [Located (ConDeclField GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [Located (ConDeclField GhcRn)]
new_fields, NameSet
fvs) }
extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv
-> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
extendPatSynEnv :: HsValBinds GhcPs
-> MiniFixityEnv
-> ([Name] -> TcRnIf TcGblEnv TcLclEnv a)
-> TcRnIf TcGblEnv TcLclEnv a
extendPatSynEnv HsValBinds GhcPs
val_decls MiniFixityEnv
local_fix_env [Name] -> TcRnIf TcGblEnv TcLclEnv a
thing = do {
[(Name, [FieldLabel])]
names_with_fls <- HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
new_ps HsValBinds GhcPs
val_decls
; let pat_syn_bndrs :: [Name]
pat_syn_bndrs = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Name
nameName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector [FieldLabel]
fields
| (Name
name, [FieldLabel]
fields) <- [(Name, [FieldLabel])]
names_with_fls ]
; let avails :: [AvailInfo]
avails = (Name -> AvailInfo) -> [Name] -> [AvailInfo]
forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail [Name]
pat_syn_bndrs
; (TcGblEnv
gbl_env, TcLclEnv
lcl_env) <- [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn [AvailInfo]
avails MiniFixityEnv
local_fix_env
; let field_env' :: NameEnv [FieldLabel]
field_env' = NameEnv [FieldLabel]
-> [(Name, [FieldLabel])] -> NameEnv [FieldLabel]
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcGblEnv -> NameEnv [FieldLabel]
tcg_field_env TcGblEnv
gbl_env) [(Name, [FieldLabel])]
names_with_fls
final_gbl_env :: TcGblEnv
final_gbl_env = TcGblEnv
gbl_env { tcg_field_env :: NameEnv [FieldLabel]
tcg_field_env = NameEnv [FieldLabel]
field_env' }
; (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
final_gbl_env, TcLclEnv
lcl_env) ([Name] -> TcRnIf TcGblEnv TcLclEnv a
thing [Name]
pat_syn_bndrs) }
where
new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
new_ps (ValBinds XValBinds GhcPs GhcPs
_ LHsBinds GhcPs
binds [LSig GhcPs]
_) = (Located (HsBindLR GhcPs GhcPs)
-> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])])
-> [(Name, [FieldLabel])]
-> Bag (Located (HsBindLR GhcPs GhcPs))
-> TcM [(Name, [FieldLabel])]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Located (HsBindLR GhcPs GhcPs)
-> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
LHsBindLR GhcPs GhcPs
-> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
new_ps' [] Bag (Located (HsBindLR GhcPs GhcPs))
LHsBinds GhcPs
binds
new_ps HsValBinds GhcPs
_ = String -> TcM [(Name, [FieldLabel])]
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 bind_loc (PatSynBind _ (PSB { psb_id = L _ n
, psb_args = RecCon as }))) <- LHsBindLR GhcPs GhcPs
bind
= do
Name
bnd_name <- GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTopSrcBinder (SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
bind_loc RdrName
n)
let rnames :: [GenLocated SrcSpan RdrName]
rnames = (RecordPatSynField (GenLocated SrcSpan RdrName)
-> GenLocated SrcSpan RdrName)
-> [RecordPatSynField (GenLocated SrcSpan RdrName)]
-> [GenLocated SrcSpan RdrName]
forall a b. (a -> b) -> [a] -> [b]
map RecordPatSynField (GenLocated SrcSpan RdrName)
-> GenLocated SrcSpan RdrName
forall fld. RecordPatSynField fld -> fld
recordPatSynSelectorId [RecordPatSynField (GenLocated SrcSpan RdrName)]
[RecordPatSynField (LIdP GhcPs)]
as
mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs
mkFieldOcc :: GenLocated SrcSpan RdrName -> LFieldOcc GhcPs
mkFieldOcc (L SrcSpan
l RdrName
name) = SrcSpan -> FieldOcc GhcPs -> GenLocated SrcSpan (FieldOcc GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XCFieldOcc GhcPs -> GenLocated SrcSpan RdrName -> FieldOcc GhcPs
forall pass.
XCFieldOcc pass -> GenLocated SrcSpan RdrName -> FieldOcc pass
FieldOcc NoExtField
XCFieldOcc GhcPs
noExtField (SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
name))
field_occs :: [GenLocated SrcSpan (FieldOcc GhcPs)]
field_occs = (GenLocated SrcSpan RdrName -> GenLocated SrcSpan (FieldOcc GhcPs))
-> [GenLocated SrcSpan RdrName]
-> [GenLocated SrcSpan (FieldOcc GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan RdrName -> GenLocated SrcSpan (FieldOcc GhcPs)
GenLocated SrcSpan RdrName -> LFieldOcc GhcPs
mkFieldOcc [GenLocated SrcSpan RdrName]
rnames
[FieldLabel]
flds <- (GenLocated SrcSpan (FieldOcc GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) FieldLabel)
-> [GenLocated SrcSpan (FieldOcc GhcPs)] -> RnM [FieldLabel]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool
-> [Name]
-> LFieldOcc GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) FieldLabel
newRecordSelector Bool
False [Name
bnd_name]) [GenLocated SrcSpan (FieldOcc GhcPs)]
field_occs
[(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
bnd_name, [FieldLabel]
flds)(Name, [FieldLabel])
-> [(Name, [FieldLabel])] -> [(Name, [FieldLabel])]
forall a. a -> [a] -> [a]
: [(Name, [FieldLabel])]
names)
| L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- LHsBindLR GhcPs GhcPs
bind
= do
Name
bnd_name <- GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTopSrcBinder (SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
bind_loc RdrName
n)
[(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
bnd_name, [])(Name, [FieldLabel])
-> [(Name, [FieldLabel])] -> [(Name, [FieldLabel])]
forall a. a -> [a] -> [a]
: [(Name, [FieldLabel])]
names)
| Bool
otherwise
= [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name, [FieldLabel])]
names
rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds [LHsFunDep GhcPs]
fds
= (Located
([GenLocated SrcSpan RdrName], [GenLocated SrcSpan RdrName])
-> IOEnv
(Env TcGblEnv TcLclEnv) (Located ([Located Name], [Located Name])))
-> [Located
([GenLocated SrcSpan RdrName], [GenLocated SrcSpan RdrName])]
-> IOEnv
(Env TcGblEnv TcLclEnv) [Located ([Located Name], [Located Name])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((([GenLocated SrcSpan RdrName], [GenLocated SrcSpan RdrName])
-> TcM ([Located Name], [Located Name]))
-> Located
([GenLocated SrcSpan RdrName], [GenLocated SrcSpan RdrName])
-> IOEnv
(Env TcGblEnv TcLclEnv) (Located ([Located Name], [Located Name]))
forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM ([GenLocated SrcSpan RdrName], [GenLocated SrcSpan RdrName])
-> TcM ([Located Name], [Located Name])
rn_fds) [Located
([GenLocated SrcSpan RdrName], [GenLocated SrcSpan RdrName])]
[LHsFunDep GhcPs]
fds
where
rn_fds :: ([GenLocated SrcSpan RdrName], [GenLocated SrcSpan RdrName])
-> TcM ([Located Name], [Located Name])
rn_fds ([GenLocated SrcSpan RdrName]
tys1, [GenLocated SrcSpan RdrName]
tys2)
= do { [Located Name]
tys1' <- [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
rnHsTyVars [GenLocated SrcSpan RdrName]
tys1
; [Located Name]
tys2' <- [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
rnHsTyVars [GenLocated SrcSpan RdrName]
tys2
; ([Located Name], [Located Name])
-> TcM ([Located Name], [Located Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Located Name]
tys1', [Located Name]
tys2') }
rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
rnHsTyVars :: [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
rnHsTyVars [GenLocated SrcSpan RdrName]
tvs = (GenLocated SrcSpan RdrName -> RnM (Located Name))
-> [GenLocated SrcSpan RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan RdrName -> RnM (Located Name)
rnHsTyVar [GenLocated SrcSpan RdrName]
tvs
rnHsTyVar :: Located RdrName -> RnM (Located Name)
rnHsTyVar :: GenLocated SrcSpan RdrName -> RnM (Located Name)
rnHsTyVar (L SrcSpan
l RdrName
tyvar) = do
Name
tyvar' <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupOccRn RdrName
tyvar
Located Name -> RnM (Located Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l Name
tyvar')
findSplice :: [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice :: [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
ds = HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl HsGroup GhcPs
forall (p :: Pass). HsGroup (GhcPass p)
emptyRdrGroup [LHsDecl GhcPs]
ds
addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl :: HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl HsGroup GhcPs
gp [] = (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [Located (HsDecl GhcPs)]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [Located (HsDecl GhcPs)]))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsGroup GhcPs
gp, Maybe (SpliceDecl GhcPs, [Located (HsDecl GhcPs)])
forall a. Maybe a
Nothing)
addl HsGroup GhcPs
gp (L l d : [LHsDecl GhcPs]
ds) = HsGroup GhcPs
-> SrcSpan
-> HsDecl GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
add HsGroup GhcPs
gp SrcSpan
l HsDecl GhcPs
d [LHsDecl GhcPs]
ds
add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
add :: HsGroup GhcPs
-> SrcSpan
-> HsDecl GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
add HsGroup GhcPs
gp SrcSpan
_ (SpliceD XSpliceD GhcPs
_ (SpliceDecl XSpliceDecl GhcPs
_ (L _ qq@HsQuasiQuote{}) SpliceExplicitFlag
_)) [LHsDecl GhcPs]
ds
= do { ([Located (HsDecl GhcPs)]
ds', NameSet
_) <- HsSplice GhcPs -> RnM ([LHsDecl GhcPs], NameSet)
rnTopSpliceDecls HsSplice GhcPs
qq
; HsGroup GhcPs
-> [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
addl HsGroup GhcPs
gp ([Located (HsDecl GhcPs)]
ds' [Located (HsDecl GhcPs)]
-> [Located (HsDecl GhcPs)] -> [Located (HsDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Located (HsDecl GhcPs)]
[LHsDecl GhcPs]
ds)
}
add HsGroup GhcPs
gp SrcSpan
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 -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
SpliceExplicitFlag
ImplicitSplice -> do { Bool
th_on <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TemplateHaskell
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
th_on (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWith SDoc
badImplicitSplice }
; (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [Located (HsDecl GhcPs)]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [Located (HsDecl GhcPs)]))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsGroup GhcPs
gp, (SpliceDecl GhcPs, [Located (HsDecl GhcPs)])
-> Maybe (SpliceDecl GhcPs, [Located (HsDecl GhcPs)])
forall a. a -> Maybe a
Just (SpliceDecl GhcPs
splice, [Located (HsDecl GhcPs)]
[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}) SrcSpan
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 = LTyClDecl GhcPs -> [TyClGroup GhcPs] -> [TyClGroup GhcPs]
forall (p :: Pass).
LTyClDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_tycld (SrcSpan -> TyClDecl GhcPs -> Located (TyClDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
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}) SrcSpan
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 = SrcSpan -> FixitySig GhcPs -> GenLocated SrcSpan (FixitySig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l FixitySig GhcPs
f GenLocated SrcSpan (FixitySig GhcPs)
-> [GenLocated SrcSpan (FixitySig GhcPs)]
-> [GenLocated SrcSpan (FixitySig GhcPs)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpan (FixitySig GhcPs)]
[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}) SrcSpan
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 = LStandaloneKindSig GhcPs -> [TyClGroup GhcPs] -> [TyClGroup GhcPs]
forall (p :: Pass).
LStandaloneKindSig (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_kisig (SrcSpan
-> StandaloneKindSig GhcPs
-> GenLocated SrcSpan (StandaloneKindSig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
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}) SrcSpan
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 = LSig GhcPs -> HsValBinds GhcPs -> HsValBinds GhcPs
forall (a :: Pass).
LSig (GhcPass a)
-> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig (SrcSpan -> Sig GhcPs -> GenLocated SrcSpan (Sig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
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}) SrcSpan
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 = LHsBindLR GhcPs GhcPs -> HsValBinds GhcPs -> HsValBinds GhcPs
forall a. LHsBind a -> HsValBinds a -> HsValBinds a
add_bind (SrcSpan -> HsBindLR GhcPs GhcPs -> Located (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
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}) SrcSpan
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 = LRoleAnnotDecl GhcPs -> [TyClGroup GhcPs] -> [TyClGroup GhcPs]
forall (p :: Pass).
LRoleAnnotDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_role_annot (SrcSpan
-> RoleAnnotDecl GhcPs -> GenLocated SrcSpan (RoleAnnotDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
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}) SrcSpan
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 = LInstDecl GhcPs -> [TyClGroup GhcPs] -> [TyClGroup GhcPs]
forall (p :: Pass).
LInstDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_instd (SrcSpan -> InstDecl GhcPs -> Located (InstDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
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}) SrcSpan
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 = SrcSpan -> DerivDecl GhcPs -> Located (DerivDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l DerivDecl GhcPs
d Located (DerivDecl GhcPs)
-> [Located (DerivDecl GhcPs)] -> [Located (DerivDecl GhcPs)]
forall a. a -> [a] -> [a]
: [Located (DerivDecl GhcPs)]
[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}) SrcSpan
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 = SrcSpan -> DefaultDecl GhcPs -> Located (DefaultDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l DefaultDecl GhcPs
d Located (DefaultDecl GhcPs)
-> [Located (DefaultDecl GhcPs)] -> [Located (DefaultDecl GhcPs)]
forall a. a -> [a] -> [a]
: [Located (DefaultDecl GhcPs)]
[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}) SrcSpan
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 = SrcSpan -> ForeignDecl GhcPs -> Located (ForeignDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l ForeignDecl GhcPs
d Located (ForeignDecl GhcPs)
-> [Located (ForeignDecl GhcPs)] -> [Located (ForeignDecl GhcPs)]
forall a. a -> [a] -> [a]
: [Located (ForeignDecl GhcPs)]
[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}) SrcSpan
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 = SrcSpan -> WarnDecls GhcPs -> GenLocated SrcSpan (WarnDecls GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l WarnDecls GhcPs
d GenLocated SrcSpan (WarnDecls GhcPs)
-> [GenLocated SrcSpan (WarnDecls GhcPs)]
-> [GenLocated SrcSpan (WarnDecls GhcPs)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpan (WarnDecls GhcPs)]
[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}) SrcSpan
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 = SrcSpan -> AnnDecl GhcPs -> Located (AnnDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l AnnDecl GhcPs
d Located (AnnDecl GhcPs)
-> [Located (AnnDecl GhcPs)] -> [Located (AnnDecl GhcPs)]
forall a. a -> [a] -> [a]
: [Located (AnnDecl GhcPs)]
[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}) SrcSpan
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 = SrcSpan -> RuleDecls GhcPs -> Located (RuleDecls GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RuleDecls GhcPs
d Located (RuleDecls GhcPs)
-> [Located (RuleDecls GhcPs)] -> [Located (RuleDecls GhcPs)]
forall a. a -> [a] -> [a]
: [Located (RuleDecls GhcPs)]
[LRuleDecls GhcPs]
ts }) [LHsDecl GhcPs]
ds
add HsGroup GhcPs
gp SrcSpan
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]
hs_docs = (SrcSpan -> DocDecl -> LDocDecl
forall l e. l -> e -> GenLocated l e
L SrcSpan
l DocDecl
d) LDocDecl -> [LDocDecl] -> [LDocDecl]
forall a. a -> [a] -> [a]
: (HsGroup GhcPs -> [LDocDecl]
forall p. HsGroup p -> [LDocDecl]
hs_docs HsGroup GhcPs
gp) }) [LHsDecl GhcPs]
ds
add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
add_tycld :: LTyClDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_tycld LTyClDecl (GhcPass p)
d [] = [TyClGroup :: forall pass.
XCTyClGroup pass
-> [LTyClDecl pass]
-> [LRoleAnnotDecl pass]
-> [LStandaloneKindSig pass]
-> [LInstDecl pass]
-> TyClGroup pass
TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext = NoExtField
XCTyClGroup (GhcPass p)
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 = Located (TyClDecl (GhcPass p))
LTyClDecl (GhcPass p)
d Located (TyClDecl (GhcPass p))
-> [Located (TyClDecl (GhcPass p))]
-> [Located (TyClDecl (GhcPass p))]
forall a. a -> [a] -> [a]
: [Located (TyClDecl (GhcPass p))]
[LTyClDecl (GhcPass p)]
tyclds } TyClGroup (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
dss
add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
add_instd :: LInstDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_instd LInstDecl (GhcPass p)
d [] = [TyClGroup :: forall pass.
XCTyClGroup pass
-> [LTyClDecl pass]
-> [LRoleAnnotDecl pass]
-> [LStandaloneKindSig pass]
-> [LInstDecl pass]
-> TyClGroup pass
TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext = NoExtField
XCTyClGroup (GhcPass p)
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 = Located (InstDecl (GhcPass p))
LInstDecl (GhcPass p)
d Located (InstDecl (GhcPass p))
-> [Located (InstDecl (GhcPass p))]
-> [Located (InstDecl (GhcPass p))]
forall a. a -> [a] -> [a]
: [Located (InstDecl (GhcPass p))]
[LInstDecl (GhcPass p)]
instds } TyClGroup (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
dss
add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
add_role_annot :: LRoleAnnotDecl (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_role_annot LRoleAnnotDecl (GhcPass p)
d [] = [TyClGroup :: forall pass.
XCTyClGroup pass
-> [LTyClDecl pass]
-> [LRoleAnnotDecl pass]
-> [LStandaloneKindSig pass]
-> [LInstDecl pass]
-> TyClGroup pass
TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext = NoExtField
XCTyClGroup (GhcPass p)
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 = Located (RoleAnnotDecl (GhcPass p))
LRoleAnnotDecl (GhcPass p)
d Located (RoleAnnotDecl (GhcPass p))
-> [Located (RoleAnnotDecl (GhcPass p))]
-> [Located (RoleAnnotDecl (GhcPass p))]
forall a. a -> [a] -> [a]
: [Located (RoleAnnotDecl (GhcPass p))]
[LRoleAnnotDecl (GhcPass p)]
roles } TyClGroup (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
rest
add_kisig :: LStandaloneKindSig (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_kisig :: LStandaloneKindSig (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
add_kisig LStandaloneKindSig (GhcPass p)
d [] = [TyClGroup :: forall pass.
XCTyClGroup pass
-> [LTyClDecl pass]
-> [LRoleAnnotDecl pass]
-> [LStandaloneKindSig pass]
-> [LInstDecl pass]
-> TyClGroup pass
TyClGroup { group_ext :: XCTyClGroup (GhcPass p)
group_ext = NoExtField
XCTyClGroup (GhcPass p)
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 = Located (StandaloneKindSig (GhcPass p))
LStandaloneKindSig (GhcPass p)
d Located (StandaloneKindSig (GhcPass p))
-> [Located (StandaloneKindSig (GhcPass p))]
-> [Located (StandaloneKindSig (GhcPass p))]
forall a. a -> [a] -> [a]
: [Located (StandaloneKindSig (GhcPass p))]
[LStandaloneKindSig (GhcPass p)]
kisigs } TyClGroup (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
forall a. a -> [a] -> [a]
: [TyClGroup (GhcPass p)]
rest
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind LHsBind a
b (ValBinds XValBinds a a
x LHsBindsLR a a
bs [LSig a]
sigs) = XValBinds a a -> LHsBindsLR a a -> [LSig a] -> HsValBinds a
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds a a
x (LHsBindsLR a a
bs LHsBindsLR a a -> LHsBind a -> LHsBindsLR a a
forall a. Bag a -> a -> Bag a
`snocBag` LHsBind a
b) [LSig a]
sigs
add_bind LHsBind a
_ (XValBindsLR {}) = String -> HsValBinds a
forall a. String -> a
panic String
"GHC.Rename.Module.add_bind"
add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig :: LSig (GhcPass a)
-> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig LSig (GhcPass a)
s (ValBinds XValBinds (GhcPass a) (GhcPass a)
x LHsBindsLR (GhcPass a) (GhcPass a)
bs [LSig (GhcPass a)]
sigs) = XValBinds (GhcPass a) (GhcPass a)
-> LHsBindsLR (GhcPass a) (GhcPass a)
-> [LSig (GhcPass a)]
-> HsValBinds (GhcPass a)
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds (GhcPass a) (GhcPass a)
x LHsBindsLR (GhcPass a) (GhcPass a)
bs (Located (Sig (GhcPass a))
LSig (GhcPass a)
sLocated (Sig (GhcPass a))
-> [Located (Sig (GhcPass a))] -> [Located (Sig (GhcPass a))]
forall a. a -> [a] -> [a]
:[Located (Sig (GhcPass a))]
[LSig (GhcPass a)]
sigs)
add_sig LSig (GhcPass a)
_ (XValBindsLR {}) = String -> HsValBinds (GhcPass a)
forall a. String -> a
panic String
"GHC.Rename.Module.add_sig"