{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Utils.Backpack (
findExtraSigImports,
implicitRequirements,
implicitRequirementsShallow,
checkUnit,
tcRnCheckUnit,
tcRnMergeSignatures,
mergeSignatures,
tcRnInstantiateSignature,
instantiateSignature,
) where
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Types.Basic (TypeOrKind(..))
import GHC.Types.Fixity (defaultFixity)
import GHC.Types.Fixity.Env
import GHC.Types.TypeEnv
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Avail
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.Var
import GHC.Types.Id( idType )
import GHC.Types.Unique.DSet
import GHC.Types.Name.Shape
import GHC.Types.PkgQual
import GHC.Unit
import GHC.Unit.Finder
import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Tc.Errors.Types
import GHC.Tc.Gen.Export
import GHC.Tc.Solver
import GHC.Tc.TyCl.Utils
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Hs
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.IfaceToCore
import GHC.Iface.Load
import GHC.Iface.Rename
import GHC.Iface.Syntax
import GHC.Rename.Names
import GHC.Rename.Fixity ( lookupFixityRn )
import GHC.Tc.Utils.Env
import GHC.Tc.Errors
import GHC.Tc.Utils.Unify
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Data.Maybe
import Control.Monad
import Data.List (find)
import {-# SOURCE #-} GHC.Tc.Module
fixityMisMatch :: TyThing -> Fixity -> Fixity -> TcRnMessage
fixityMisMatch :: TyThing -> Fixity -> Fixity -> TcRnMessage
fixityMisMatch TyThing
real_thing Fixity
real_fixity Fixity
sig_fixity =
DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
real_thing SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has conflicting fixities in the module",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and its hsig file",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Main module:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Fixity -> SDoc
ppr_fix Fixity
real_fixity,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Hsig file:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Fixity -> SDoc
ppr_fix Fixity
sig_fixity]
where
ppr_fix :: Fixity -> SDoc
ppr_fix Fixity
f =
Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fixity
f SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
(if Fixity
f Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity
defaultFixity
then SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"default")
else SDoc
forall doc. IsOutput doc => doc
empty)
checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM ModIface
sig_iface TyThing
sig_thing TyThing
real_thing = do
let name :: Name
name = TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
real_thing
Bool -> TyThing -> TyThing -> TcRn ()
checkBootDeclM Bool
False TyThing
sig_thing TyThing
real_thing
Fixity
real_fixity <- Name -> RnM Fixity
lookupFixityRn Name
name
let sig_fixity :: Fixity
sig_fixity = case ModIfaceBackend -> OccName -> Maybe Fixity
mi_fix_fn (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
sig_iface) (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
name) of
Maybe Fixity
Nothing -> Fixity
defaultFixity
Just Fixity
f -> Fixity
f
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Fixity
real_fixity Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
/= Fixity
sig_fixity) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (Name -> SrcSpan
nameSrcSpan Name
name)
(TyThing -> Fixity -> Fixity -> TcRnMessage
fixityMisMatch TyThing
real_thing Fixity
real_fixity Fixity
sig_fixity)
checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
checkHsigIface TcGblEnv
tcg_env GlobalRdrEnv
gr ModIface
sig_iface
ModDetails { md_insts :: ModDetails -> InstEnv
md_insts = InstEnv
sig_insts, md_fam_insts :: ModDetails -> [FamInst]
md_fam_insts = [FamInst]
sig_fam_insts,
md_types :: ModDetails -> TypeEnv
md_types = TypeEnv
sig_type_env, md_exports :: ModDetails -> [AvailInfo]
md_exports = [AvailInfo]
sig_exports } = do
String -> SDoc -> TcRn ()
traceTc String
"checkHsigIface" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeEnv
sig_type_env, InstEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstEnv
sig_insts, [AvailInfo] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AvailInfo]
sig_exports ]
(Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> TcRn ()
check_export ((AvailInfo -> Name) -> [AvailInfo] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map AvailInfo -> Name
availName [AvailInfo]
sig_exports)
TcRn ()
failIfErrsM
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FamInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FamInst]
sig_fam_insts) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
String -> TcRn ()
forall a. HasCallStack => String -> a
panic (String
"GHC.Tc.Module.checkHsigIface: Cannot handle family " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"instances in hsig files yet...")
TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
TcGblEnv -> TcRn () -> TcRn ()
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env { tcg_inst_env = emptyInstEnv,
tcg_fam_inst_env = emptyFamInstEnv,
tcg_insts = [],
tcg_fam_insts = [] } (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
(ClsInst -> TcRn ()) -> [ClsInst] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ClsInst -> TcRn ()
check_inst (InstEnv -> [ClsInst]
instEnvElts InstEnv
sig_insts)
TcRn ()
failIfErrsM
where
sig_type_occ_env :: OccEnv TyThing
sig_type_occ_env = [(OccName, TyThing)] -> OccEnv TyThing
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv
([(OccName, TyThing)] -> OccEnv TyThing)
-> ([TyThing] -> [(OccName, TyThing)])
-> [TyThing]
-> OccEnv TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyThing -> (OccName, TyThing))
-> [TyThing] -> [(OccName, TyThing)]
forall a b. (a -> b) -> [a] -> [b]
map (\TyThing
t -> (Name -> OccName
nameOccName (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
t), TyThing
t))
([TyThing] -> OccEnv TyThing) -> [TyThing] -> OccEnv TyThing
forall a b. (a -> b) -> a -> b
$ TypeEnv -> [TyThing]
forall a. NameEnv a -> [a]
nonDetNameEnvElts TypeEnv
sig_type_env
dfun_names :: [Name]
dfun_names = (ClsInst -> Name) -> [ClsInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> Name
forall a. NamedThing a => a -> Name
getName (InstEnv -> [ClsInst]
instEnvElts InstEnv
sig_insts)
check_export :: Name -> TcRn ()
check_export Name
name
| Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dfun_names = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just TyThing
sig_thing <- OccEnv TyThing -> OccName -> Maybe TyThing
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv TyThing
sig_type_occ_env (Name -> OccName
nameOccName Name
name) = do
MaybeErr SDoc TyThing
r <- Name -> TcM (MaybeErr SDoc TyThing)
tcLookupImported_maybe Name
name
case MaybeErr SDoc TyThing
r of
Failed SDoc
err -> TcRnMessage -> TcRn ()
addErr (Name -> SDoc -> TcRnMessage
TcRnInterfaceLookupError Name
name SDoc
err)
Succeeded TyThing
real_thing -> ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM ModIface
sig_iface TyThing
sig_thing TyThing
real_thing
| [GlobalRdrElt
gre] <- GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
gr (Name -> OccName
nameOccName Name
name) = do
let name' :: Name
name' = GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
name') (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
let p :: GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed))
-> Bool
p (L SrcSpanAnn' (EpAnn AnnListItem)
_ IE (GhcPass 'Renamed)
ie) = Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IE (GhcPass 'Renamed) -> [IdP (GhcPass 'Renamed)]
forall (p :: Pass). IE (GhcPass p) -> [IdP (GhcPass p)]
ieNames IE (GhcPass 'Renamed)
ie
loc :: SrcSpan
loc = case TcGblEnv -> Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])]
tcg_rn_exports TcGblEnv
tcg_env of
Just [(LIE (GhcPass 'Renamed), [AvailInfo])]
es | Just GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed))
e <- (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed))
-> Bool)
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed))]
-> Maybe
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed))
-> Bool
p (((GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)))
-> [(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])]
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed))]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed))
forall a b. (a, b) -> a
fst [(LIE (GhcPass 'Renamed), [AvailInfo])]
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])]
es)
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed))
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed))
e
Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])]
_ -> Name -> SrcSpan
nameSrcSpan Name
name
SrcSpan -> TcRnMessage -> TcRn ()
addErrAt SrcSpan
loc
(Bool -> Name -> Name -> TcRnMessage
badReexportedBootThing Bool
False Name
name Name
name')
| Bool
otherwise =
SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (Name -> SrcSpan
nameSrcSpan Name
name)
(Bool -> Name -> String -> TcRnMessage
missingBootThing Bool
False Name
name String
"exported by")
check_inst :: ClsInst -> TcM ()
check_inst :: ClsInst -> TcRn ()
check_inst sig_inst :: ClsInst
sig_inst@(ClsInst { is_dfun :: ClsInst -> DFunId
is_dfun = DFunId
dfun_id }) = do
TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
(Name -> TcM (MaybeErr SDoc TyThing)) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> TcM (MaybeErr SDoc TyThing)
tcLookupImported_maybe (NameSet -> [Name]
nameSetElemsStable (ClsInst -> NameSet
orphNamesOfClsInst ClsInst
sig_inst))
let origin :: CtOrigin
origin = Module -> ClsInst -> CtOrigin
InstProvidedOrigin (TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env) ClsInst
sig_inst
(SkolemInfoAnon
skol_info, [DFunId]
tvs_skols, TcThetaType
inst_theta, Class
cls, TcThetaType
inst_tys) <- Type
-> TcM (SkolemInfoAnon, [DFunId], TcThetaType, Class, TcThetaType)
tcSkolDFunType (DFunId -> Type
idType DFunId
dfun_id)
(TcLevel
tclvl,[CtEvidence]
cts) <- TcM [CtEvidence] -> TcM (TcLevel, [CtEvidence])
forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM (TcM [CtEvidence] -> TcM (TcLevel, [CtEvidence]))
-> TcM [CtEvidence] -> TcM (TcLevel, [CtEvidence])
forall a b. (a -> b) -> a -> b
$ do
CtEvidence
wanted <- CtOrigin -> Maybe TypeOrKind -> Type -> TcM CtEvidence
newWanted CtOrigin
origin (TypeOrKind -> Maybe TypeOrKind
forall a. a -> Maybe a
Just TypeOrKind
TypeLevel) (Class -> TcThetaType -> Type
mkClassPred Class
cls TcThetaType
inst_tys)
[CtEvidence]
givens <- TcThetaType -> (Type -> TcM CtEvidence) -> TcM [CtEvidence]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM TcThetaType
inst_theta ((Type -> TcM CtEvidence) -> TcM [CtEvidence])
-> (Type -> TcM CtEvidence) -> TcM [CtEvidence]
forall a b. (a -> b) -> a -> b
$ \Type
given -> do
CtLoc
loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
origin (TypeOrKind -> Maybe TypeOrKind
forall a. a -> Maybe a
Just TypeOrKind
TypeLevel)
DFunId
new_ev <- Type -> TcRnIf TcGblEnv TcLclEnv DFunId
forall gbl lcl. Type -> TcRnIf gbl lcl DFunId
newEvVar Type
given
CtEvidence -> TcM CtEvidence
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CtGiven { ctev_pred :: Type
ctev_pred = Type
given
, ctev_evar :: DFunId
ctev_evar = DFunId
new_ev
, ctev_loc :: CtLoc
ctev_loc = CtLoc
loc
}
[CtEvidence] -> TcM [CtEvidence]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CtEvidence] -> TcM [CtEvidence])
-> [CtEvidence] -> TcM [CtEvidence]
forall a b. (a -> b) -> a -> b
$ CtEvidence
wanted CtEvidence -> [CtEvidence] -> [CtEvidence]
forall a. a -> [a] -> [a]
: [CtEvidence]
givens
WantedConstraints
unsolved <- [CtEvidence] -> TcM WantedConstraints
simplifyWantedsTcM [CtEvidence]
cts
(Bag Implication
implic, TcEvBinds
_) <- TcLevel
-> SkolemInfoAnon
-> [DFunId]
-> [DFunId]
-> WantedConstraints
-> TcM (Bag Implication, TcEvBinds)
buildImplicationFor TcLevel
tclvl SkolemInfoAnon
skol_info [DFunId]
tvs_skols [] WantedConstraints
unsolved
WantedConstraints -> TcRn ()
reportAllUnsolved (Bag Implication -> WantedConstraints
mkImplicWC Bag Implication
implic)
findExtraSigImports :: HscEnv
-> HscSource
-> ModuleName
-> IO [ModuleName]
HscEnv
hsc_env HscSource
HsigFile ModuleName
modname = do
let
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle
unit_state :: UnitState
unit_state = (() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
reqs :: [InstantiatedModule]
reqs = UnitState -> ModuleName -> [InstantiatedModule]
requirementMerges UnitState
unit_state ModuleName
modname
[UniqDSet ModuleName]
holes <- [InstantiatedModule]
-> (InstantiatedModule -> IO (UniqDSet ModuleName))
-> IO [UniqDSet ModuleName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [InstantiatedModule]
reqs ((InstantiatedModule -> IO (UniqDSet ModuleName))
-> IO [UniqDSet ModuleName])
-> (InstantiatedModule -> IO (UniqDSet ModuleName))
-> IO [UniqDSet ModuleName]
forall a b. (a -> b) -> a -> b
$ \(Module InstantiatedUnit
iuid ModuleName
mod_name) -> do
HscEnv -> IfG (UniqDSet ModuleName) -> IO (UniqDSet ModuleName)
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env
(IfG (UniqDSet ModuleName) -> IO (UniqDSet ModuleName))
-> (IOEnv (Env IfGblEnv ()) (MaybeErr SDoc (UniqDSet ModuleName))
-> IfG (UniqDSet ModuleName))
-> IOEnv (Env IfGblEnv ()) (MaybeErr SDoc (UniqDSet ModuleName))
-> IO (UniqDSet ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext
-> IOEnv (Env IfGblEnv ()) (MaybeErr SDoc (UniqDSet ModuleName))
-> IfG (UniqDSet ModuleName)
forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr SDoc a) -> m a
withException SDocContext
ctx
(IOEnv (Env IfGblEnv ()) (MaybeErr SDoc (UniqDSet ModuleName))
-> IO (UniqDSet ModuleName))
-> IOEnv (Env IfGblEnv ()) (MaybeErr SDoc (UniqDSet ModuleName))
-> IO (UniqDSet ModuleName)
forall a b. (a -> b) -> a -> b
$ SDoc
-> Module
-> IOEnv (Env IfGblEnv ()) (MaybeErr SDoc (UniqDSet ModuleName))
forall gbl lcl.
SDoc
-> Module -> TcRnIf gbl lcl (MaybeErr SDoc (UniqDSet ModuleName))
moduleFreeHolesPrecise (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"findExtraSigImports")
(Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (InstantiatedUnit -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid) ModuleName
mod_name)
[ModuleName] -> IO [ModuleName]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqDSet ModuleName -> [ModuleName]
forall a. UniqDSet a -> [a]
uniqDSetToList ([UniqDSet ModuleName] -> UniqDSet ModuleName
forall a. [UniqDSet a] -> UniqDSet a
unionManyUniqDSets [UniqDSet ModuleName]
holes))
findExtraSigImports HscEnv
_ HscSource
_ ModuleName
_ = [ModuleName] -> IO [ModuleName]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
implicitRequirements :: HscEnv
-> [(PkgQual, Located ModuleName)]
-> IO [ModuleName]
implicitRequirements :: HscEnv -> [(PkgQual, Located ModuleName)] -> IO [ModuleName]
implicitRequirements HscEnv
hsc_env [(PkgQual, Located ModuleName)]
normal_imports
= ([[ModuleName]] -> [ModuleName])
-> IO [[ModuleName]] -> IO [ModuleName]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ModuleName]] -> [ModuleName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[ModuleName]] -> IO [ModuleName])
-> IO [[ModuleName]] -> IO [ModuleName]
forall a b. (a -> b) -> a -> b
$
[(PkgQual, Located ModuleName)]
-> ((PkgQual, Located ModuleName) -> IO [ModuleName])
-> IO [[ModuleName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PkgQual, Located ModuleName)]
normal_imports (((PkgQual, Located ModuleName) -> IO [ModuleName])
-> IO [[ModuleName]])
-> ((PkgQual, Located ModuleName) -> IO [ModuleName])
-> IO [[ModuleName]]
forall a b. (a -> b) -> a -> b
$ \(PkgQual
mb_pkg, L SrcSpan
_ ModuleName
imp) -> do
FindResult
found <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
imp PkgQual
mb_pkg
case FindResult
found of
Found ModLocation
_ Module
mod | Maybe HomeUnit -> Module -> Bool
notHomeModuleMaybe Maybe HomeUnit
mhome_unit Module
mod ->
[ModuleName] -> IO [ModuleName]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqDSet ModuleName -> [ModuleName]
forall a. UniqDSet a -> [a]
uniqDSetToList (Module -> UniqDSet ModuleName
forall u. GenModule (GenUnit u) -> UniqDSet ModuleName
moduleFreeHoles Module
mod))
FindResult
_ -> [ModuleName] -> IO [ModuleName]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
where
mhome_unit :: Maybe HomeUnit
mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
implicitRequirementsShallow
:: HscEnv
-> [(PkgQual, Located ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow :: HscEnv
-> [(PkgQual, Located ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow HscEnv
hsc_env [(PkgQual, Located ModuleName)]
normal_imports = ([ModuleName], [InstantiatedUnit])
-> [(PkgQual, Located ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
go ([], []) [(PkgQual, Located ModuleName)]
normal_imports
where
mhome_unit :: Maybe HomeUnit
mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
go :: ([ModuleName], [InstantiatedUnit])
-> [(PkgQual, Located ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
go ([ModuleName], [InstantiatedUnit])
acc [] = ([ModuleName], [InstantiatedUnit])
-> IO ([ModuleName], [InstantiatedUnit])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleName], [InstantiatedUnit])
acc
go ([ModuleName]
accL, [InstantiatedUnit]
accR) ((PkgQual
mb_pkg, L SrcSpan
_ ModuleName
imp):[(PkgQual, Located ModuleName)]
imports) = do
FindResult
found <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
imp PkgQual
mb_pkg
let acc' :: ([ModuleName], [InstantiatedUnit])
acc' = case FindResult
found of
Found ModLocation
_ Module
mod | Maybe HomeUnit -> Module -> Bool
notHomeModuleMaybe Maybe HomeUnit
mhome_unit Module
mod ->
case Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod of
Unit
HoleUnit -> (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName]
accL, [InstantiatedUnit]
accR)
RealUnit Definite UnitId
_ -> ([ModuleName]
accL, [InstantiatedUnit]
accR)
VirtUnit InstantiatedUnit
u -> ([ModuleName]
accL, InstantiatedUnit
uInstantiatedUnit -> [InstantiatedUnit] -> [InstantiatedUnit]
forall a. a -> [a] -> [a]
:[InstantiatedUnit]
accR)
FindResult
_ -> ([ModuleName]
accL, [InstantiatedUnit]
accR)
([ModuleName], [InstantiatedUnit])
-> [(PkgQual, Located ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
go ([ModuleName], [InstantiatedUnit])
acc' [(PkgQual, Located ModuleName)]
imports
checkUnit :: Unit -> TcM ()
checkUnit :: Unit -> TcRn ()
checkUnit Unit
HoleUnit = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkUnit (RealUnit Definite UnitId
_) = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkUnit (VirtUnit InstantiatedUnit
indef) = do
let insts :: GenInstantiations UnitId
insts = InstantiatedUnit -> GenInstantiations UnitId
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts InstantiatedUnit
indef
GenInstantiations UnitId
-> ((ModuleName, Module) -> TcRn ()) -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ GenInstantiations UnitId
insts (((ModuleName, Module) -> TcRn ()) -> TcRn ())
-> ((ModuleName, Module) -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \(ModuleName
mod_name, Module
mod) ->
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
mod)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
Unit -> TcRn ()
checkUnit (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod)
TcGblEnv
_ <- Module
mod Module -> InstantiatedModule -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
`checkImplements` InstantiatedUnit -> ModuleName -> InstantiatedModule
forall u. u -> ModuleName -> GenModule u
Module InstantiatedUnit
indef ModuleName
mod_name
() -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tcRnCheckUnit ::
HscEnv -> Unit ->
IO (Messages TcRnMessage, Maybe ())
tcRnCheckUnit :: HscEnv -> Unit -> IO (Messages TcRnMessage, Maybe ())
tcRnCheckUnit HscEnv
hsc_env Unit
uid =
Logger
-> SDoc
-> ((Messages TcRnMessage, Maybe ()) -> ())
-> IO (Messages TcRnMessage, Maybe ())
-> IO (Messages TcRnMessage, Maybe ())
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Check unit id" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
uid)
(() -> (Messages TcRnMessage, Maybe ()) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages TcRnMessage, Maybe ())
-> IO (Messages TcRnMessage, Maybe ()))
-> IO (Messages TcRnMessage, Maybe ())
-> IO (Messages TcRnMessage, Maybe ())
forall a b. (a -> b) -> a -> b
$
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcRn ()
-> IO (Messages TcRnMessage, Maybe ())
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc HscEnv
hsc_env
HscSource
HsigFile
Bool
False
(HomeUnitEnv -> Module
mainModIs (HscEnv -> HomeUnitEnv
hsc_HUE HscEnv
hsc_env))
(RealSrcLoc -> RealSrcSpan
realSrcLocSpan (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit String
loc_str) Int
0 Int
0))
(TcRn () -> IO (Messages TcRnMessage, Maybe ()))
-> TcRn () -> IO (Messages TcRnMessage, Maybe ())
forall a b. (a -> b) -> a -> b
$ Unit -> TcRn ()
checkUnit Unit
uid
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
loc_str :: String
loc_str = String
"Command line argument: -unit-id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
uid)
tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv -> ModIface
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnMergeSignatures :: HscEnv
-> HsParsedModule
-> TcGblEnv
-> ModIface
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnMergeSignatures HscEnv
hsc_env HsParsedModule
hpm TcGblEnv
orig_tcg_env ModIface
iface =
Logger
-> SDoc
-> ((Messages TcRnMessage, Maybe TcGblEnv) -> ())
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Signature merging" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(() -> (Messages TcRnMessage, Maybe TcGblEnv) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc HscEnv
hsc_env HscSource
HsigFile Bool
False Module
this_mod RealSrcSpan
real_loc (TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
HsParsedModule
-> TcGblEnv -> ModIface -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
mergeSignatures HsParsedModule
hpm TcGblEnv
orig_tcg_env ModIface
iface
where
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
this_mod :: Module
this_mod = ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface
real_loc :: RealSrcSpan
real_loc = TcGblEnv -> RealSrcSpan
tcg_top_loc TcGblEnv
orig_tcg_env
thinModIface :: [AvailInfo] -> ModIface -> ModIface
thinModIface :: [AvailInfo] -> ModIface -> ModIface
thinModIface [AvailInfo]
avails ModIface
iface =
ModIface
iface {
mi_exports = avails,
mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls
}
where
decl_pred :: OccSet -> IfaceDecl -> Bool
decl_pred OccSet
occs IfaceDecl
decl = Name -> OccName
nameOccName (IfaceDecl -> Name
ifName IfaceDecl
decl) OccName -> OccSet -> Bool
`elemOccSet` OccSet
occs
filter_decls :: OccSet -> [(Fingerprint, IfaceDecl)]
filter_decls OccSet
occs = ((Fingerprint, IfaceDecl) -> Bool)
-> [(Fingerprint, IfaceDecl)] -> [(Fingerprint, IfaceDecl)]
forall a. (a -> Bool) -> [a] -> [a]
filter (OccSet -> IfaceDecl -> Bool
decl_pred OccSet
occs (IfaceDecl -> Bool)
-> ((Fingerprint, IfaceDecl) -> IfaceDecl)
-> (Fingerprint, IfaceDecl)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fingerprint, IfaceDecl) -> IfaceDecl
forall a b. (a, b) -> b
snd) (ModIface -> [IfaceDeclExts 'ModIfaceFinal]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls ModIface
iface)
exported_occs :: OccSet
exported_occs = [OccName] -> OccSet
mkOccSet [ Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
n
| AvailInfo
a <- [AvailInfo]
avails
, Name
n <- AvailInfo -> [Name]
availNames AvailInfo
a ]
exported_decls :: [(Fingerprint, IfaceDecl)]
exported_decls = OccSet -> [(Fingerprint, IfaceDecl)]
filter_decls OccSet
exported_occs
non_exported_occs :: OccSet
non_exported_occs = [OccName] -> OccSet
mkOccSet [ Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
n
| (Fingerprint
_, IfaceDecl
d) <- [(Fingerprint, IfaceDecl)]
exported_decls
, Name
n <- IfaceDecl -> [Name]
ifaceDeclNeverExportedRefs IfaceDecl
d ]
non_exported_decls :: [(Fingerprint, IfaceDecl)]
non_exported_decls = OccSet -> [(Fingerprint, IfaceDecl)]
filter_decls OccSet
non_exported_occs
dfun_pred :: IfaceDecl -> Bool
dfun_pred IfaceId{ ifIdDetails :: IfaceDecl -> IfaceIdDetails
ifIdDetails = IfaceIdDetails
IfDFunId } = Bool
True
dfun_pred IfaceDecl
_ = Bool
False
dfun_decls :: [(Fingerprint, IfaceDecl)]
dfun_decls = ((Fingerprint, IfaceDecl) -> Bool)
-> [(Fingerprint, IfaceDecl)] -> [(Fingerprint, IfaceDecl)]
forall a. (a -> Bool) -> [a] -> [a]
filter (IfaceDecl -> Bool
dfun_pred (IfaceDecl -> Bool)
-> ((Fingerprint, IfaceDecl) -> IfaceDecl)
-> (Fingerprint, IfaceDecl)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fingerprint, IfaceDecl) -> IfaceDecl
forall a b. (a, b) -> b
snd) (ModIface -> [IfaceDeclExts 'ModIfaceFinal]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls ModIface
iface)
ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]
ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]
ifaceDeclNeverExportedRefs d :: IfaceDecl
d@IfaceFamily{} =
case IfaceDecl -> IfaceFamTyConFlav
ifFamFlav IfaceDecl
d of
IfaceClosedSynFamilyTyCon (Just (Name
n, [IfaceAxBranch]
_))
-> [Name
n]
IfaceFamTyConFlav
_ -> []
ifaceDeclNeverExportedRefs IfaceDecl
_ = []
merge_msg :: ModuleName -> [InstantiatedModule] -> SDoc
merge_msg :: ModuleName -> [InstantiatedModule] -> SDoc
merge_msg ModuleName
mod_name [] =
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"while checking the local signature" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"for consistency"
merge_msg ModuleName
mod_name [InstantiatedModule]
reqs =
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"while merging the signatures from" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc
bullet SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InstantiatedModule -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstantiatedModule
req | InstantiatedModule
req <- [InstantiatedModule]
reqs ] SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
SDoc
bullet SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"...and the local signature for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name)
mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv
mergeSignatures :: HsParsedModule
-> TcGblEnv -> ModIface -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
mergeSignatures
(HsParsedModule { hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module = L SrcSpan
loc (HsModule { hsmodExports :: forall p. HsModule p -> Maybe (XRec p [LIE p])
hsmodExports = Maybe (XRec GhcPs [LIE GhcPs])
mb_exports }),
hpm_src_files :: HsParsedModule -> [String]
hpm_src_files = [String]
src_files })
TcGblEnv
orig_tcg_env ModIface
lcl_iface0 = SrcSpan
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
(TcGblEnv -> TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
env -> TcGblEnv
env {
tcg_rn_imports = tcg_rn_imports orig_tcg_env,
tcg_rn_decls = tcg_rn_decls orig_tcg_env,
tcg_ann_env = tcg_ann_env orig_tcg_env,
tcg_doc_hdr = tcg_doc_hdr orig_tcg_env
}) (TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let outer_mod :: Module
outer_mod = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
let inner_mod :: Module
inner_mod = TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env
let mod_name :: ModuleName
mod_name = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env)
let unit_state :: UnitState
unit_state = (() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let reqs :: [InstantiatedModule]
reqs = UnitState -> ModuleName -> [InstantiatedModule]
requirementMerges UnitState
unit_state ModuleName
mod_name
SDoc
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ModuleName -> [InstantiatedModule] -> SDoc
merge_msg ModuleName
mod_name [InstantiatedModule]
reqs) (TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
[ModIface]
ireq_ifaces0 <- IO [ModIface] -> IOEnv (Env TcGblEnv TcLclEnv) [ModIface]
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ModIface] -> IOEnv (Env TcGblEnv TcLclEnv) [ModIface])
-> IO [ModIface] -> IOEnv (Env TcGblEnv TcLclEnv) [ModIface]
forall a b. (a -> b) -> a -> b
$ [InstantiatedModule]
-> (InstantiatedModule -> IO ModIface) -> IO [ModIface]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [InstantiatedModule]
reqs ((InstantiatedModule -> IO ModIface) -> IO [ModIface])
-> (InstantiatedModule -> IO ModIface) -> IO [ModIface]
forall a b. (a -> b) -> a -> b
$ \(Module InstantiatedUnit
iuid ModuleName
mod_name) -> do
let m :: Module
m = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (InstantiatedUnit -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid) ModuleName
mod_name
im :: InstalledModule
im = (InstalledModule, Maybe InstantiatedModule) -> InstalledModule
forall a b. (a, b) -> a
fst (Module -> (InstalledModule, Maybe InstantiatedModule)
getModuleInstantiation Module
m)
ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle
((ModIface, String) -> ModIface)
-> IO (ModIface, String) -> IO ModIface
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModIface, String) -> ModIface
forall a b. (a, b) -> a
fst
(IO (ModIface, String) -> IO ModIface)
-> (IO (MaybeErr SDoc (ModIface, String)) -> IO (ModIface, String))
-> IO (MaybeErr SDoc (ModIface, String))
-> IO ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext
-> IO (MaybeErr SDoc (ModIface, String)) -> IO (ModIface, String)
forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr SDoc a) -> m a
withException SDocContext
ctx
(IO (MaybeErr SDoc (ModIface, String)) -> IO ModIface)
-> IO (MaybeErr SDoc (ModIface, String)) -> IO ModIface
forall a b. (a -> b) -> a -> b
$ HscEnv
-> SDoc
-> InstalledModule
-> Module
-> IsBootInterface
-> IO (MaybeErr SDoc (ModIface, String))
findAndReadIface HscEnv
hsc_env
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mergeSignatures") InstalledModule
im Module
m IsBootInterface
NotBoot
let extend_ns :: NameShape
-> [AvailInfo]
-> IOEnv (Env TcGblEnv TcLclEnv) (Either SDoc NameShape)
extend_ns NameShape
nsubst [AvailInfo]
as = IO (Either SDoc NameShape)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either SDoc NameShape)
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SDoc NameShape)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either SDoc NameShape))
-> IO (Either SDoc NameShape)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either SDoc NameShape)
forall a b. (a -> b) -> a -> b
$ HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
extendNameShape HscEnv
hsc_env NameShape
nsubst [AvailInfo]
as
gen_subst :: (NameShape, OccSet, [(InstantiatedModule, ModIface)])
-> (InstantiatedModule, ModIface)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(NameShape, OccSet, [(InstantiatedModule, ModIface)])
gen_subst (NameShape
nsubst,OccSet
oks,[(InstantiatedModule, ModIface)]
ifaces) (imod :: InstantiatedModule
imod@(Module InstantiatedUnit
iuid ModuleName
_), ModIface
ireq_iface) = do
let insts :: GenInstantiations UnitId
insts = InstantiatedUnit -> GenInstantiations UnitId
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts InstantiatedUnit
iuid
isFromSignaturePackage :: Bool
isFromSignaturePackage =
let inst_uid :: UnitId
inst_uid = InstantiatedUnit -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf InstantiatedUnit
iuid
pkg :: UnitInfo
pkg = (() :: Constraint) => UnitState -> UnitId -> UnitInfo
UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId UnitState
unit_state UnitId
inst_uid
in [(ModuleName, Maybe Module)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (UnitInfo -> [(ModuleName, Maybe Module)]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules UnitInfo
pkg)
[AvailInfo]
as1 <- GenInstantiations UnitId -> ModIface -> TcM [AvailInfo]
tcRnModExports GenInstantiations UnitId
insts ModIface
ireq_iface
(ModIface
thinned_iface, [AvailInfo]
as2) <- case Maybe (XRec GhcPs [LIE GhcPs])
mb_exports of
Just (L SrcSpanAnn' (EpAnn AnnList)
loc [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (IE GhcPs)]
_)
| Bool
isFromSignaturePackage
-> SrcSpanAnn' (EpAnn AnnList)
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnList)
loc (IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall a b. (a -> b) -> a -> b
$ do
(Maybe
(Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])],
[AvailInfo])
mb_r, Messages TcRnMessage
msgs) <- TcRn
(Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])],
[AvailInfo])
-> TcRn
(Maybe
(Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])],
[AvailInfo]),
Messages TcRnMessage)
forall a. TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
tryTc (TcRn
(Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])],
[AvailInfo])
-> TcRn
(Maybe
(Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])],
[AvailInfo]),
Messages TcRnMessage))
-> TcRn
(Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])],
[AvailInfo])
-> TcRn
(Maybe
(Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])],
[AvailInfo]),
Messages TcRnMessage)
forall a b. (a -> b) -> a -> b
$ do
let ispec :: ImportSpec
ispec = ImpDeclSpec -> ImpItemSpec -> ImportSpec
ImpSpec ImpDeclSpec{
is_mod :: ModuleName
is_mod = ModuleName
mod_name,
is_as :: ModuleName
is_as = ModuleName
mod_name,
is_qual :: Bool
is_qual = Bool
False,
is_dloc :: SrcSpan
is_dloc = SrcSpanAnn' (EpAnn AnnList) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn AnnList)
loc
} ImpItemSpec
ImpAll
rdr_env :: GlobalRdrEnv
rdr_env = [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv (Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails (ImportSpec -> Maybe ImportSpec
forall a. a -> Maybe a
Just ImportSpec
ispec) [AvailInfo]
as1)
TcGblEnv
-> TcRnIf
TcGblEnv
TcLclEnv
(Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])], [AvailInfo])
-> TcRnIf
TcGblEnv
TcLclEnv
(Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])], [AvailInfo])
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env {
tcg_rdr_env = rdr_env
} (TcRnIf
TcGblEnv
TcLclEnv
(Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])], [AvailInfo])
-> TcRnIf
TcGblEnv
TcLclEnv
(Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])], [AvailInfo]))
-> TcRnIf
TcGblEnv
TcLclEnv
(Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])], [AvailInfo])
-> TcRnIf
TcGblEnv
TcLclEnv
(Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])], [AvailInfo])
forall a b. (a -> b) -> a -> b
$ Maybe (LocatedL [LIE GhcPs])
-> GlobalRdrEnv
-> ImportAvails
-> Module
-> TcRnIf
TcGblEnv
TcLclEnv
(Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])], [AvailInfo])
exports_from_avail Maybe (XRec GhcPs [LIE GhcPs])
Maybe (LocatedL [LIE GhcPs])
mb_exports GlobalRdrEnv
rdr_env
ImportAvails
emptyImportAvails
(TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env)
case Maybe
(Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])],
[AvailInfo])
mb_r of
Just (Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])]
_, [AvailInfo]
as2) -> (ModIface, [AvailInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([AvailInfo] -> ModIface -> ModIface
thinModIface [AvailInfo]
as2 ModIface
ireq_iface, [AvailInfo]
as2)
Maybe
(Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])],
[AvailInfo])
Nothing -> Messages TcRnMessage -> TcRn ()
addMessages Messages TcRnMessage
msgs TcRn ()
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall env a. IOEnv env a
failM
Maybe (XRec GhcPs [LIE GhcPs])
_ -> (ModIface, [AvailInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface, [AvailInfo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
ireq_iface, [AvailInfo]
as1)
let oks' :: OccSet
oks' | Bool
isFromSignaturePackage
= OccSet -> [OccName] -> OccSet
extendOccSetList OccSet
oks ([AvailInfo] -> [OccName]
exportOccs [AvailInfo]
as2)
| Bool
otherwise
= OccSet
oks
Either SDoc NameShape
mb_r <- NameShape
-> [AvailInfo]
-> IOEnv (Env TcGblEnv TcLclEnv) (Either SDoc NameShape)
extend_ns NameShape
nsubst [AvailInfo]
as2
case Either SDoc NameShape
mb_r of
Left SDoc
err -> TcRnMessage
-> IOEnv
(Env TcGblEnv TcLclEnv)
(NameShape, OccSet, [(InstantiatedModule, ModIface)])
forall a. TcRnMessage -> TcM a
failWithTc (DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints SDoc
err)
Right NameShape
nsubst' -> (NameShape, OccSet, [(InstantiatedModule, ModIface)])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(NameShape, OccSet, [(InstantiatedModule, ModIface)])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (NameShape
nsubst',OccSet
oks',(InstantiatedModule
imod, ModIface
thinned_iface)(InstantiatedModule, ModIface)
-> [(InstantiatedModule, ModIface)]
-> [(InstantiatedModule, ModIface)]
forall a. a -> [a] -> [a]
:[(InstantiatedModule, ModIface)]
ifaces)
nsubst0 :: NameShape
nsubst0 = ModuleName -> [AvailInfo] -> NameShape
mkNameShape (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
inner_mod) (ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
lcl_iface0)
ok_to_use0 :: OccSet
ok_to_use0 = [OccName] -> OccSet
mkOccSet ([AvailInfo] -> [OccName]
exportOccs (ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
lcl_iface0))
(NameShape
nsubst, OccSet
ok_to_use, [(InstantiatedModule, ModIface)]
rev_thinned_ifaces)
<- ((NameShape, OccSet, [(InstantiatedModule, ModIface)])
-> (InstantiatedModule, ModIface)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(NameShape, OccSet, [(InstantiatedModule, ModIface)]))
-> (NameShape, OccSet, [(InstantiatedModule, ModIface)])
-> [(InstantiatedModule, ModIface)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(NameShape, OccSet, [(InstantiatedModule, ModIface)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (NameShape, OccSet, [(InstantiatedModule, ModIface)])
-> (InstantiatedModule, ModIface)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(NameShape, OccSet, [(InstantiatedModule, ModIface)])
gen_subst (NameShape
nsubst0, OccSet
ok_to_use0, []) ([InstantiatedModule]
-> [ModIface] -> [(InstantiatedModule, ModIface)]
forall a b. [a] -> [b] -> [(a, b)]
zip [InstantiatedModule]
reqs [ModIface]
ireq_ifaces0)
let thinned_ifaces :: [(InstantiatedModule, ModIface)]
thinned_ifaces = [(InstantiatedModule, ModIface)]
-> [(InstantiatedModule, ModIface)]
forall a. [a] -> [a]
reverse [(InstantiatedModule, ModIface)]
rev_thinned_ifaces
exports :: [AvailInfo]
exports = NameShape -> [AvailInfo]
nameShapeExports NameShape
nsubst
rdr_env :: GlobalRdrEnv
rdr_env = [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv (Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails Maybe ImportSpec
forall a. Maybe a
Nothing [AvailInfo]
exports)
_warn_occs :: [OccName]
_warn_occs = (OccName -> Bool) -> [OccName] -> [OccName]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (OccName -> Bool) -> OccName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OccName -> OccSet -> Bool
`elemOccSet` OccSet
ok_to_use)) ([AvailInfo] -> [OccName]
exportOccs [AvailInfo]
exports)
warns :: Warnings pass
warns = Warnings pass
forall pass. Warnings pass
NoWarnings
TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env {
tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env,
tcg_imports = tcg_imports orig_tcg_env,
tcg_exports = exports,
tcg_dus = usesOnly (availsToNameSetWithSelectors exports),
tcg_warns = warns
} (TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
(Maybe
[(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (IE (GhcPass 'Renamed)),
[AvailInfo])]
mb_lies, [AvailInfo]
_) <- Maybe (LocatedL [LIE GhcPs])
-> GlobalRdrEnv
-> ImportAvails
-> Module
-> TcRnIf
TcGblEnv
TcLclEnv
(Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])], [AvailInfo])
exports_from_avail Maybe (XRec GhcPs [LIE GhcPs])
Maybe (LocatedL [LIE GhcPs])
mb_exports GlobalRdrEnv
rdr_env
(TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env) (TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env)
TcRn ()
failIfErrsM
TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env { tcg_rn_exports = mb_lies } (TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
[ModIface]
ext_ifaces <- [(InstantiatedModule, ModIface)]
-> ((InstantiatedModule, ModIface)
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> IOEnv (Env TcGblEnv TcLclEnv) [ModIface]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(InstantiatedModule, ModIface)]
thinned_ifaces (((InstantiatedModule, ModIface)
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> IOEnv (Env TcGblEnv TcLclEnv) [ModIface])
-> ((InstantiatedModule, ModIface)
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> IOEnv (Env TcGblEnv TcLclEnv) [ModIface]
forall a b. (a -> b) -> a -> b
$ \((Module InstantiatedUnit
iuid ModuleName
_), ModIface
ireq_iface) ->
GenInstantiations UnitId
-> Maybe NameShape
-> ModIface
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface
tcRnModIface (InstantiatedUnit -> GenInstantiations UnitId
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts InstantiatedUnit
iuid) (NameShape -> Maybe NameShape
forall a. a -> Maybe a
Just NameShape
nsubst) ModIface
ireq_iface
ModIface
lcl_iface <- GenInstantiations UnitId
-> Maybe NameShape
-> ModIface
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface
tcRnModIface (HomeUnit -> GenInstantiations UnitId
forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit) (NameShape -> Maybe NameShape
forall a. a -> Maybe a
Just NameShape
nsubst) ModIface
lcl_iface0
let ifaces :: [ModIface]
ifaces = ModIface
lcl_iface ModIface -> [ModIface] -> [ModIface]
forall a. a -> [a] -> [a]
: [ModIface]
ext_ifaces
let fix_env :: NameEnv FixItem
fix_env = [(Name, FixItem)] -> NameEnv FixItem
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
rdr_elt, OccName -> Fixity -> FixItem
FixItem OccName
occ Fixity
f)
| (OccName
occ, Fixity
f) <- (ModIface -> [(OccName, Fixity)])
-> [ModIface] -> [(OccName, Fixity)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModIface -> [(OccName, Fixity)]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [(OccName, Fixity)]
mi_fixities [ModIface]
ifaces
, GlobalRdrElt
rdr_elt <- GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
rdr_env OccName
occ ]
let type_env_var :: KnotVars (IORef TypeEnv)
type_env_var = TcGblEnv -> KnotVars (IORef TypeEnv)
tcg_type_env_var TcGblEnv
tcg_env
(TypeEnv
type_env, [ModDetails]
detailss) <- IfG (TypeEnv, [ModDetails]) -> TcRn (TypeEnv, [ModDetails])
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG (TypeEnv, [ModDetails]) -> TcRn (TypeEnv, [ModDetails]))
-> IfG (TypeEnv, [ModDetails]) -> TcRn (TypeEnv, [ModDetails])
forall a b. (a -> b) -> a -> b
$
Module
-> [ModIface]
-> KnotVars (IORef TypeEnv)
-> IfG (TypeEnv, [ModDetails])
forall lcl.
Module
-> [ModIface]
-> KnotVars (IORef TypeEnv)
-> IfM lcl (TypeEnv, [ModDetails])
typecheckIfacesForMerging Module
inner_mod [ModIface]
ifaces KnotVars (IORef TypeEnv)
type_env_var
let infos :: [(ModIface, ModDetails)]
infos = [ModIface] -> [ModDetails] -> [(ModIface, ModDetails)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModIface]
ifaces [ModDetails]
detailss
Unit -> [TyCon] -> [LTyClDecl (GhcPass 'Renamed)] -> TcRn ()
checkSynCycles (HomeUnit -> Unit
homeUnitAsUnit HomeUnit
home_unit) (TypeEnv -> [TyCon]
typeEnvTyCons TypeEnv
type_env) []
TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env {
tcg_tcs = typeEnvTyCons type_env,
tcg_patsyns = typeEnvPatSyns type_env,
tcg_type_env = type_env,
tcg_fix_env = fix_env
} (TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
TcGblEnv
tcg_env <- (\TcGblEnv
-> (ModIface, ModDetails) -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
x -> (TcGblEnv
-> (ModIface, ModDetails) -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcGblEnv
-> [(ModIface, ModDetails)]
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM TcGblEnv
-> (ModIface, ModDetails) -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
x TcGblEnv
tcg_env [(ModIface, ModDetails)]
infos)
((TcGblEnv
-> (ModIface, ModDetails) -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> (TcGblEnv
-> (ModIface, ModDetails) -> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ \TcGblEnv
tcg_env (ModIface
iface, ModDetails
details) -> do
let check_export :: Name -> TcRn ()
check_export Name
name
| Just TyThing
sig_thing <- TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv (ModDetails -> TypeEnv
md_types ModDetails
details) Name
name
= case TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
type_env (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
sig_thing) of
Just TyThing
thing -> ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM ModIface
iface TyThing
sig_thing TyThing
thing
Maybe TyThing
Nothing -> String -> TcRn ()
forall a. HasCallStack => String -> a
panic String
"mergeSignatures: check_export"
| Bool
otherwise
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> TcRn ()
check_export ((AvailInfo -> Name) -> [AvailInfo] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map AvailInfo -> Name
availName [AvailInfo]
exports)
let merge_inst :: ([ClsInst], InstEnv) -> ClsInst -> ([ClsInst], InstEnv)
merge_inst ([ClsInst]
insts, InstEnv
inst_env) ClsInst
inst
| InstEnv -> ClsInst -> Bool
memberInstEnv InstEnv
inst_env ClsInst
inst
= ([ClsInst]
insts, InstEnv
inst_env)
| Bool
otherwise
= (ClsInst
instClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
:[ClsInst]
insts, InstEnv -> ClsInst -> InstEnv
extendInstEnv InstEnv
inst_env ClsInst
inst)
([ClsInst]
insts, InstEnv
inst_env) = (([ClsInst], InstEnv) -> ClsInst -> ([ClsInst], InstEnv))
-> ([ClsInst], InstEnv) -> [ClsInst] -> ([ClsInst], InstEnv)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([ClsInst], InstEnv) -> ClsInst -> ([ClsInst], InstEnv)
merge_inst
(TcGblEnv -> [ClsInst]
tcg_insts TcGblEnv
tcg_env, TcGblEnv -> InstEnv
tcg_inst_env TcGblEnv
tcg_env)
(InstEnv -> [ClsInst]
instEnvElts (InstEnv -> [ClsInst]) -> InstEnv -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ ModDetails -> InstEnv
md_insts ModDetails
details)
avails :: ImportAvails
avails = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env
deps :: Dependencies
deps = ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface
avails_with_trans :: ImportAvails
avails_with_trans = ImportAvails -> Dependencies -> ImportAvails
addTransitiveDepInfo ImportAvails
avails Dependencies
deps
TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env {
tcg_inst_env = inst_env,
tcg_insts = insts,
tcg_imports = avails_with_trans,
tcg_merged =
if outer_mod == mi_module iface
then tcg_merged tcg_env
else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env
}
[(DFunId, ClsInst)]
dfun_insts <- [ClsInst]
-> (ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) (DFunId, ClsInst))
-> IOEnv (Env TcGblEnv TcLclEnv) [(DFunId, ClsInst)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (TcGblEnv -> [ClsInst]
tcg_insts TcGblEnv
tcg_env) ((ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) (DFunId, ClsInst))
-> IOEnv (Env TcGblEnv TcLclEnv) [(DFunId, ClsInst)])
-> (ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) (DFunId, ClsInst))
-> IOEnv (Env TcGblEnv TcLclEnv) [(DFunId, ClsInst)]
forall a b. (a -> b) -> a -> b
$ \ClsInst
inst -> do
Name
n <- Class -> TcThetaType -> SrcSpan -> TcM Name
newDFunName (ClsInst -> Class
is_cls ClsInst
inst) (ClsInst -> TcThetaType
is_tys ClsInst
inst) (Name -> SrcSpan
nameSrcSpan (ClsInst -> Name
is_dfun_name ClsInst
inst))
let dfun :: DFunId
dfun = DFunId -> Name -> DFunId
setVarName (ClsInst -> DFunId
is_dfun ClsInst
inst) Name
n
(DFunId, ClsInst)
-> IOEnv (Env TcGblEnv TcLclEnv) (DFunId, ClsInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DFunId
dfun, ClsInst
inst { is_dfun_name = n, is_dfun = dfun })
TcGblEnv
tcg_env <- TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env {
tcg_insts = map snd dfun_insts,
tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts)
}
[String] -> TcRn ()
addDependentFiles [String]
src_files
TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
addTransitiveDepInfo :: ImportAvails
-> Dependencies
-> ImportAvails
addTransitiveDepInfo :: ImportAvails -> Dependencies -> ImportAvails
addTransitiveDepInfo ImportAvails
avails Dependencies
deps =
ImportAvails
avails { imp_orphs = imp_orphs avails ++ dep_orphs deps
, imp_finsts = imp_finsts avails ++ dep_finsts deps
, imp_sig_mods = imp_sig_mods avails ++ dep_sig_mods deps }
tcRnInstantiateSignature ::
HscEnv -> Module -> RealSrcSpan ->
IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnInstantiateSignature :: HscEnv
-> Module
-> RealSrcSpan
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnInstantiateSignature HscEnv
hsc_env Module
this_mod RealSrcSpan
real_loc =
Logger
-> SDoc
-> ((Messages TcRnMessage, Maybe TcGblEnv) -> ())
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Signature instantiation"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(() -> (Messages TcRnMessage, Maybe TcGblEnv) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc HscEnv
hsc_env HscSource
HsigFile Bool
False Module
this_mod RealSrcSpan
real_loc (TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$ TcRnIf TcGblEnv TcLclEnv TcGblEnv
instantiateSignature
where
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
exportOccs :: [AvailInfo] -> [OccName]
exportOccs :: [AvailInfo] -> [OccName]
exportOccs = (AvailInfo -> [OccName]) -> [AvailInfo] -> [OccName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Name -> OccName) -> [Name] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Name -> OccName
forall name. HasOccName name => name -> OccName
occName ([Name] -> [OccName])
-> (AvailInfo -> [Name]) -> AvailInfo -> [OccName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AvailInfo -> [Name]
availNames)
impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc
impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc
impl_msg UnitState
unit_state Module
impl_mod (Module InstantiatedUnit
req_uid ModuleName
req_mod_name)
= UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"while checking that" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
impl_mod SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"implements signature" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
req_mod_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InstantiatedUnit -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
req_uid
checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv
checkImplements :: Module -> InstantiatedModule -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
checkImplements Module
impl_mod req_mod :: InstantiatedModule
req_mod@(Module InstantiatedUnit
uid ModuleName
mod_name) = do
HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
let unit_state :: UnitState
unit_state = (() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
other_home_units :: Set UnitId
other_home_units = HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env
SDoc
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (UnitState -> Module -> InstantiatedModule -> SDoc
impl_msg UnitState
unit_state Module
impl_mod InstantiatedModule
req_mod) (TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
let insts :: GenInstantiations UnitId
insts = InstantiatedUnit -> GenInstantiations UnitId
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts InstantiatedUnit
uid
ModIface
impl_iface <- IfG ModIface -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG ModIface -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> IfG ModIface -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a b. (a -> b) -> a -> b
$
SDoc -> Module -> IfG ModIface
forall lcl. SDoc -> Module -> IfM lcl ModIface
loadSysInterface (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"checkImplements 1") Module
impl_mod
let impl_gr :: GlobalRdrEnv
impl_gr = [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv
(Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails Maybe ImportSpec
forall a. Maybe a
Nothing (ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
impl_iface))
nsubst :: NameShape
nsubst = ModuleName -> [AvailInfo] -> NameShape
mkNameShape (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
impl_mod) (ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
impl_iface)
SDoc -> [Module] -> TcRn ()
loadModuleInterfaces (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Loading orphan modules (from implementor of hsig)")
(Dependencies -> [Module]
dep_orphs (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
impl_iface))
let avails :: ImportAvails
avails = HomeUnit
-> Set UnitId
-> ModIface
-> Bool
-> IsBootInterface
-> ImportedBy
-> ImportAvails
calculateAvails HomeUnit
home_unit Set UnitId
other_home_units
ModIface
impl_iface Bool
False IsBootInterface
NotBoot ImportedBy
ImportedBySystem
fix_env :: NameEnv FixItem
fix_env = [(Name, FixItem)] -> NameEnv FixItem
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
rdr_elt, OccName -> Fixity -> FixItem
FixItem OccName
occ Fixity
f)
| (OccName
occ, Fixity
f) <- ModIface -> [(OccName, Fixity)]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [(OccName, Fixity)]
mi_fixities ModIface
impl_iface
, GlobalRdrElt
rdr_elt <- GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
impl_gr OccName
occ ]
(TcGblEnv -> TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
tcg_env -> TcGblEnv
tcg_env {
tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,
tcg_imports = tcg_imports tcg_env `plusImportAvails` avails,
tcg_fix_env = fix_env
}) (TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
let sig_mod :: Module
sig_mod = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (InstantiatedUnit -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
uid) ModuleName
mod_name
isig_mod :: InstalledModule
isig_mod = (InstalledModule, Maybe InstantiatedModule) -> InstalledModule
forall a b. (a, b) -> a
fst (Module -> (InstalledModule, Maybe InstantiatedModule)
getModuleInstantiation Module
sig_mod)
HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
MaybeErr SDoc (ModIface, String)
mb_isig_iface <- IO (MaybeErr SDoc (ModIface, String))
-> IOEnv (Env TcGblEnv TcLclEnv) (MaybeErr SDoc (ModIface, String))
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MaybeErr SDoc (ModIface, String))
-> IOEnv
(Env TcGblEnv TcLclEnv) (MaybeErr SDoc (ModIface, String)))
-> IO (MaybeErr SDoc (ModIface, String))
-> IOEnv (Env TcGblEnv TcLclEnv) (MaybeErr SDoc (ModIface, String))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> SDoc
-> InstalledModule
-> Module
-> IsBootInterface
-> IO (MaybeErr SDoc (ModIface, String))
findAndReadIface HscEnv
hsc_env
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"checkImplements 2")
InstalledModule
isig_mod Module
sig_mod IsBootInterface
NotBoot
ModIface
isig_iface <- case MaybeErr SDoc (ModIface, String)
mb_isig_iface of
Succeeded (ModIface
iface, String
_) -> ModIface -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
iface
Failed SDoc
err -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Could not find hi interface for signature" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (InstalledModule -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstalledModule
isig_mod) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon) Int
4 SDoc
err
[OccName] -> (OccName -> TcRn ()) -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([AvailInfo] -> [OccName]
exportOccs (ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
isig_iface)) ((OccName -> TcRn ()) -> TcRn ())
-> (OccName -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \OccName
occ ->
case GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
impl_gr OccName
occ of
[] -> TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is exported by the hsig file, but not exported by the implementing module"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
impl_mod)
[GlobalRdrElt]
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TcRn ()
failIfErrsM
ModIface
sig_iface <- GenInstantiations UnitId
-> Maybe NameShape
-> ModIface
-> IOEnv (Env TcGblEnv TcLclEnv) ModIface
tcRnModIface GenInstantiations UnitId
insts (NameShape -> Maybe NameShape
forall a. a -> Maybe a
Just NameShape
nsubst) ModIface
isig_iface
ModDetails
sig_details <- IfG ModDetails -> TcRn ModDetails
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG ModDetails -> TcRn ModDetails)
-> IfG ModDetails -> TcRn ModDetails
forall a b. (a -> b) -> a -> b
$ NameShape -> ModIface -> IfG ModDetails
forall lcl. NameShape -> ModIface -> IfM lcl ModDetails
typecheckIfaceForInstantiate NameShape
nsubst ModIface
sig_iface
TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
checkHsigIface TcGblEnv
tcg_env GlobalRdrEnv
impl_gr ModIface
sig_iface ModDetails
sig_details
TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env {
tcg_exports = mi_exports sig_iface
}
instantiateSignature :: TcRn TcGblEnv
instantiateSignature :: TcRnIf TcGblEnv TcLclEnv TcGblEnv
instantiateSignature = do
HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let outer_mod :: Module
outer_mod = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
inner_mod :: Module
inner_mod = TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
Bool -> TcRn ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
outer_mod )
Bool -> TcRn ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (HomeUnit -> Bool
forall u. GenHomeUnit u -> Bool
isHomeUnitInstantiating HomeUnit
home_unit)
let uid :: UnitId
uid = HomeUnit -> UnitId
homeUnitInstanceOf HomeUnit
home_unit
Module
inner_mod Module -> InstantiatedModule -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
`checkImplements`
InstantiatedUnit -> ModuleName -> InstantiatedModule
forall u. u -> ModuleName -> GenModule u
Module
(UnitId -> GenInstantiations UnitId -> InstantiatedUnit
forall u.
IsUnitId u =>
u -> GenInstantiations u -> GenInstantiatedUnit u
mkInstantiatedUnit UnitId
uid (HomeUnit -> GenInstantiations UnitId
forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit))
(Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
outer_mod)