module GHC.Driver.Env
( Hsc(..)
, HscEnv (..)
, hscUpdateFlags
, hscSetFlags
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
, hsc_HPT
, hsc_HUE
, hsc_HUG
, hsc_all_home_unit_ids
, hscUpdateLoggerFlags
, hscUpdateHUG
, hscUpdateHPT_lazy
, hscUpdateHPT
, hscSetActiveHomeUnit
, hscSetActiveUnitId
, hscActiveUnitId
, runHsc
, runHsc'
, mkInteractiveHscEnv
, runInteractiveHsc
, hscEPS
, hscInterp
, hptCompleteSigs
, hptAllInstances
, hptInstancesBelow
, hptAnns
, hptAllThings
, hptSomeThingsBelowUs
, hptRules
, prepareAnnotations
, discardIC
, lookupType
, lookupIfaceByModule
, mainModIs
)
where
import GHC.Prelude
import GHC.Driver.DynFlags
import GHC.Driver.Errors ( printOrThrowDiagnostics )
import GHC.Driver.Errors.Types ( GhcMessage )
import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig)
import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )
import GHC.Runtime.Context
import GHC.Runtime.Interpreter.Types (Interp)
import GHC.Unit
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Home.ModInfo
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Core ( CoreRule )
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )
import GHC.Types.CompleteMatch
import GHC.Types.Error ( emptyMessages, Messages )
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.TyThing
import GHC.Builtin.Names ( gHC_PRIM )
import GHC.Data.Maybe
import GHC.Utils.Exception as Ex
import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Logger
import Data.IORef
import qualified Data.Set as Set
import GHC.Unit.Module.Graph
runHsc :: HscEnv -> Hsc a -> IO a
runHsc :: forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env Hsc a
hsc = do
(a, w) <- HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
forall a. HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
runHsc' HscEnv
hsc_env Hsc a
hsc
let dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let !diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
!print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags
printOrThrowDiagnostics (hsc_logger hsc_env) print_config diag_opts w
return a
runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
runHsc' :: forall a. HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
runHsc' HscEnv
hsc_env (Hsc HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage)
hsc) = HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage)
hsc HscEnv
hsc_env Messages GhcMessage
forall e. Messages e
emptyMessages
mkInteractiveHscEnv :: HscEnv -> HscEnv
mkInteractiveHscEnv :: HscEnv -> HscEnv
mkInteractiveHscEnv HscEnv
hsc_env =
let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
in HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags (InteractiveContext -> DynFlags
ic_dflags InteractiveContext
ic) (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$
HscEnv
hsc_env { hsc_plugins = ic_plugins ic }
runInteractiveHsc :: HscEnv -> Hsc a -> IO a
runInteractiveHsc :: forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env = HscEnv -> Hsc a -> IO a
forall a. HscEnv -> Hsc a -> IO a
runHsc (HscEnv -> HscEnv
mkInteractiveHscEnv HscEnv
hsc_env)
hsc_home_unit :: HscEnv -> HomeUnit
hsc_home_unit :: HscEnv -> HomeUnit
hsc_home_unit = UnitEnv -> HomeUnit
unsafeGetHomeUnit (UnitEnv -> HomeUnit) -> (HscEnv -> UnitEnv) -> HscEnv -> HomeUnit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env
hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe = UnitEnv -> Maybe HomeUnit
ue_homeUnit (UnitEnv -> Maybe HomeUnit)
-> (HscEnv -> UnitEnv) -> HscEnv -> Maybe HomeUnit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units (UnitEnv -> UnitState)
-> (HscEnv -> UnitEnv) -> HscEnv -> UnitState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = HasDebugCallStack => UnitEnv -> HomePackageTable
UnitEnv -> HomePackageTable
ue_hpt (UnitEnv -> HomePackageTable)
-> (HscEnv -> UnitEnv) -> HscEnv -> HomePackageTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env
hsc_HUE :: HscEnv -> HomeUnitEnv
hsc_HUE :: HscEnv -> HomeUnitEnv
hsc_HUE = HasDebugCallStack => UnitEnv -> HomeUnitEnv
UnitEnv -> HomeUnitEnv
ue_currentHomeUnitEnv (UnitEnv -> HomeUnitEnv)
-> (HscEnv -> UnitEnv) -> HscEnv -> HomeUnitEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env
hsc_HUG :: HscEnv -> HomeUnitGraph
hsc_HUG :: HscEnv -> HomeUnitGraph
hsc_HUG = UnitEnv -> HomeUnitGraph
ue_home_unit_graph (UnitEnv -> HomeUnitGraph)
-> (HscEnv -> UnitEnv) -> HscEnv -> HomeUnitGraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env
hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId
hsc_all_home_unit_ids :: HscEnv -> Set UnitId
hsc_all_home_unit_ids = HomeUnitGraph -> Set UnitId
forall v. UnitEnvGraph v -> Set UnitId
unitEnv_keys (HomeUnitGraph -> Set UnitId)
-> (HscEnv -> HomeUnitGraph) -> HscEnv -> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> HomeUnitGraph
hsc_HUG
hscUpdateHPT_lazy :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT_lazy :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT_lazy HomePackageTable -> HomePackageTable
f HscEnv
hsc_env =
let !res :: UnitEnv
res = (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv
updateHpt_lazy HomePackageTable -> HomePackageTable
f (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
in HscEnv
hsc_env { hsc_unit_env = res }
hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT HomePackageTable -> HomePackageTable
f HscEnv
hsc_env =
let !res :: UnitEnv
res = (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv
updateHpt HomePackageTable -> HomePackageTable
f (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
in HscEnv
hsc_env { hsc_unit_env = res }
hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG HomeUnitGraph -> HomeUnitGraph
f HscEnv
hsc_env = HscEnv
hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) }
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env = IORef ExternalPackageState -> IO ExternalPackageState
forall a. IORef a -> IO a
readIORef (ExternalUnitCache -> IORef ExternalPackageState
euc_eps (UnitEnv -> ExternalUnitCache
ue_eps (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)))
hptCompleteSigs :: HscEnv -> CompleteMatches
hptCompleteSigs :: HscEnv -> CompleteMatches
hptCompleteSigs = (HomeModInfo -> CompleteMatches) -> HscEnv -> CompleteMatches
forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings (ModDetails -> CompleteMatches
md_complete_matches (ModDetails -> CompleteMatches)
-> (HomeModInfo -> ModDetails) -> HomeModInfo -> CompleteMatches
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details)
hptAllInstances :: HscEnv -> (InstEnv, [FamInst])
hptAllInstances :: HscEnv -> (InstEnv, [FamInst])
hptAllInstances HscEnv
hsc_env
= let ([InstEnv]
insts, [[FamInst]]
famInsts) = [(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]]))
-> [(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]])
forall a b. (a -> b) -> a -> b
$ ((HomeModInfo -> [(InstEnv, [FamInst])])
-> HscEnv -> [(InstEnv, [FamInst])])
-> HscEnv
-> (HomeModInfo -> [(InstEnv, [FamInst])])
-> [(InstEnv, [FamInst])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (HomeModInfo -> [(InstEnv, [FamInst])])
-> HscEnv -> [(InstEnv, [FamInst])]
forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings HscEnv
hsc_env ((HomeModInfo -> [(InstEnv, [FamInst])]) -> [(InstEnv, [FamInst])])
-> (HomeModInfo -> [(InstEnv, [FamInst])])
-> [(InstEnv, [FamInst])]
forall a b. (a -> b) -> a -> b
$ \HomeModInfo
mod_info -> do
let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
mod_info
(InstEnv, [FamInst]) -> [(InstEnv, [FamInst])]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (ModDetails -> InstEnv
md_insts ModDetails
details, ModDetails -> [FamInst]
md_fam_insts ModDetails
details)
in ((InstEnv -> InstEnv -> InstEnv) -> InstEnv -> [InstEnv] -> InstEnv
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' InstEnv -> InstEnv -> InstEnv
unionInstEnv InstEnv
emptyInstEnv [InstEnv]
insts, [[FamInst]] -> [FamInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
famInsts)
hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst])
hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst])
hptInstancesBelow HscEnv
hsc_env UnitId
uid ModuleNameWithIsBoot
mnwib =
let
mn :: ModuleName
mn = ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleNameWithIsBoot
mnwib
([InstEnv]
insts, [[FamInst]]
famInsts) =
[(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]]))
-> [(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]])
forall a b. (a -> b) -> a -> b
$ (HomeModInfo -> [(InstEnv, [FamInst])])
-> Bool
-> HscEnv
-> UnitId
-> ModuleNameWithIsBoot
-> [(InstEnv, [FamInst])]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
hptSomeThingsBelowUs (\HomeModInfo
mod_info ->
let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
mod_info
in if GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModIface_ 'ModIfaceFinal -> GenModule Unit
forall (phase :: ModIfacePhase). ModIface_ phase -> GenModule Unit
mi_module (HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
mod_info)) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
mn
then []
else [(ModDetails -> InstEnv
md_insts ModDetails
details, ModDetails -> [FamInst]
md_fam_insts ModDetails
details)])
Bool
True
HscEnv
hsc_env
UnitId
uid
ModuleNameWithIsBoot
mnwib
in ((InstEnv -> InstEnv -> InstEnv) -> InstEnv -> [InstEnv] -> InstEnv
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' InstEnv -> InstEnv -> InstEnv
unionInstEnv InstEnv
emptyInstEnv [InstEnv]
insts, [[FamInst]] -> [FamInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
famInsts)
hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]
hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]
hptRules = (HomeModInfo -> [CoreRule])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
hptSomeThingsBelowUs (ModDetails -> [CoreRule]
md_rules (ModDetails -> [CoreRule])
-> (HomeModInfo -> ModDetails) -> HomeModInfo -> [CoreRule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details) Bool
False
hptAnns :: HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation]
hptAnns :: HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation]
hptAnns HscEnv
hsc_env (Just (UnitId
uid, ModuleNameWithIsBoot
mn)) = (HomeModInfo -> [Annotation])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [Annotation]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
hptSomeThingsBelowUs (ModDetails -> [Annotation]
md_anns (ModDetails -> [Annotation])
-> (HomeModInfo -> ModDetails) -> HomeModInfo -> [Annotation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details) Bool
False HscEnv
hsc_env UnitId
uid ModuleNameWithIsBoot
mn
hptAnns HscEnv
hsc_env Maybe (UnitId, ModuleNameWithIsBoot)
Nothing = (HomeModInfo -> [Annotation]) -> HscEnv -> [Annotation]
forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings (ModDetails -> [Annotation]
md_anns (ModDetails -> [Annotation])
-> (HomeModInfo -> ModDetails) -> HomeModInfo -> [Annotation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details) HscEnv
hsc_env
hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings :: forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings HomeModInfo -> [a]
extract HscEnv
hsc_env = ((UnitId, HomeUnitEnv) -> [a]) -> [(UnitId, HomeUnitEnv)] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((HomeModInfo -> [a]) -> HomePackageTable -> [a]
forall a. (HomeModInfo -> [a]) -> HomePackageTable -> [a]
concatHpt HomeModInfo -> [a]
extract (HomePackageTable -> [a])
-> ((UnitId, HomeUnitEnv) -> HomePackageTable)
-> (UnitId, HomeUnitEnv)
-> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt (HomeUnitEnv -> HomePackageTable)
-> ((UnitId, HomeUnitEnv) -> HomeUnitEnv)
-> (UnitId, HomeUnitEnv)
-> HomePackageTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId, HomeUnitEnv) -> HomeUnitEnv
forall a b. (a, b) -> b
snd)
(HomeUnitGraph -> [(UnitId, HomeUnitEnv)]
hugElts (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env))
hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
hptSomeThingsBelowUs :: forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
hptSomeThingsBelowUs HomeModInfo -> [a]
extract Bool
include_hi_boot HscEnv
hsc_env UnitId
uid ModuleNameWithIsBoot
mn
| GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) = []
| Bool
otherwise
= let hug :: HomeUnitGraph
hug = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env
mg :: ModuleGraph
mg = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env
in
[ a
thing
|
(ModNodeKeyWithUid (GWIB { gwib_mod :: forall mod. GenWithIsBoot mod -> mod
gwib_mod = ModuleName
mod, gwib_isBoot :: forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot = IsBootInterface
is_boot }) UnitId
mod_uid) <- Set ModNodeKeyWithUid -> [ModNodeKeyWithUid]
forall a. Set a -> [a]
Set.toList (ModuleGraph
-> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
moduleGraphModulesBelow ModuleGraph
mg UnitId
uid ModuleNameWithIsBoot
mn)
, Bool
include_hi_boot Bool -> Bool -> Bool
|| (IsBootInterface
is_boot IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot)
, ModuleName
mod ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
gHC_PRIM
, Bool -> Bool
not (ModuleName
mod ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleNameWithIsBoot
mn Bool -> Bool -> Bool
&& UnitId
uid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
mod_uid)
, let things :: [a]
things = case HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo
lookupHug HomeUnitGraph
hug UnitId
mod_uid ModuleName
mod of
Just HomeModInfo
info -> HomeModInfo -> [a]
extract HomeModInfo
info
Maybe HomeModInfo
Nothing -> String -> SDoc -> [a] -> [a]
forall a. String -> SDoc -> a -> a
pprTrace String
"WARNING in hptSomeThingsBelowUs" SDoc
msg [a]
forall a. Monoid a => a
mempty
msg :: SDoc
msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"missing module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"When starting from" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleNameWithIsBoot -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleNameWithIsBoot
mn,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"below:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Set ModNodeKeyWithUid -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleGraph
-> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
moduleGraphModulesBelow ModuleGraph
mg UnitId
uid ModuleNameWithIsBoot
mn),
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Probable cause: out-of-date interface files"]
, a
thing <- [a]
things
]
prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations HscEnv
hsc_env Maybe ModGuts
mb_guts = do
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
let
mb_this_module_anns = (ModGuts -> AnnEnv) -> Maybe ModGuts -> Maybe AnnEnv
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Annotation] -> AnnEnv
mkAnnEnv ([Annotation] -> AnnEnv)
-> (ModGuts -> [Annotation]) -> ModGuts -> AnnEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> [Annotation]
mg_anns) Maybe ModGuts
mb_guts
get_mod ModGuts
mg = (GenModule Unit -> UnitId
moduleUnitId (ModGuts -> GenModule Unit
mg_module ModGuts
mg), ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModGuts -> GenModule Unit
mg_module ModGuts
mg)) IsBootInterface
NotBoot)
home_pkg_anns = ([Annotation] -> AnnEnv
mkAnnEnv ([Annotation] -> AnnEnv)
-> (Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation])
-> Maybe (UnitId, ModuleNameWithIsBoot)
-> AnnEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation]
hptAnns HscEnv
hsc_env) (Maybe (UnitId, ModuleNameWithIsBoot) -> AnnEnv)
-> Maybe (UnitId, ModuleNameWithIsBoot) -> AnnEnv
forall a b. (a -> b) -> a -> b
$ (ModGuts -> (UnitId, ModuleNameWithIsBoot))
-> Maybe ModGuts -> Maybe (UnitId, ModuleNameWithIsBoot)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModGuts -> (UnitId, ModuleNameWithIsBoot)
get_mod Maybe ModGuts
mb_guts
other_pkg_anns = ExternalPackageState -> AnnEnv
eps_ann_env ExternalPackageState
eps
ann_env = (AnnEnv -> AnnEnv -> AnnEnv) -> [AnnEnv] -> AnnEnv
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' AnnEnv -> AnnEnv -> AnnEnv
plusAnnEnv ([AnnEnv] -> AnnEnv) -> [AnnEnv] -> AnnEnv
forall a b. (a -> b) -> a -> b
$ [Maybe AnnEnv] -> [AnnEnv]
forall a. [Maybe a] -> [a]
catMaybes [Maybe AnnEnv
mb_this_module_anns,
AnnEnv -> Maybe AnnEnv
forall a. a -> Maybe a
Just AnnEnv
home_pkg_anns,
AnnEnv -> Maybe AnnEnv
forall a. a -> Maybe a
Just AnnEnv
other_pkg_anns]
return ann_env
lookupType :: HscEnv -> Name -> IO (Maybe TyThing)
lookupType :: HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name = do
eps <- IO ExternalPackageState -> IO ExternalPackageState
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> IO ExternalPackageState)
-> IO ExternalPackageState -> IO ExternalPackageState
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
let pte = ExternalPackageState -> PackageTypeEnv
eps_PTE ExternalPackageState
eps
return $ lookupTypeInPTE hsc_env pte name
lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> Maybe TyThing
lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> Maybe TyThing
lookupTypeInPTE HscEnv
hsc_env PackageTypeEnv
pte Name
name = Maybe TyThing
ty
where
hpt :: HomeUnitGraph
hpt = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env
mod :: GenModule Unit
mod = Bool -> SDoc -> GenModule Unit -> GenModule Unit
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Name -> Bool
isExternalName Name
name) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) (GenModule Unit -> GenModule Unit)
-> GenModule Unit -> GenModule Unit
forall a b. (a -> b) -> a -> b
$
if Name -> Bool
isHoleName Name
name
then HomeUnit -> ModuleName -> GenModule Unit
mkHomeModule (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (HasDebugCallStack => Name -> GenModule Unit
Name -> GenModule Unit
nameModule Name
name))
else HasDebugCallStack => Name -> GenModule Unit
Name -> GenModule Unit
nameModule Name
name
!ty :: Maybe TyThing
ty = if GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
then PackageTypeEnv -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv PackageTypeEnv
pte Name
name
else case GenModule Unit -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule GenModule Unit
mod HomeUnitGraph
hpt of
Just HomeModInfo
hm -> PackageTypeEnv -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (ModDetails -> PackageTypeEnv
md_types (HomeModInfo -> ModDetails
hm_details HomeModInfo
hm)) Name
name
Maybe HomeModInfo
Nothing -> PackageTypeEnv -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv PackageTypeEnv
pte Name
name
lookupIfaceByModule
:: HomeUnitGraph
-> PackageIfaceTable
-> Module
-> Maybe ModIface
lookupIfaceByModule :: HomeUnitGraph
-> PackageIfaceTable
-> GenModule Unit
-> Maybe (ModIface_ 'ModIfaceFinal)
lookupIfaceByModule HomeUnitGraph
hug PackageIfaceTable
pit GenModule Unit
mod
= case GenModule Unit -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule GenModule Unit
mod HomeUnitGraph
hug of
Just HomeModInfo
hm -> ModIface_ 'ModIfaceFinal -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. a -> Maybe a
Just (HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
hm)
Maybe HomeModInfo
Nothing -> PackageIfaceTable
-> GenModule Unit -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. ModuleEnv a -> GenModule Unit -> Maybe a
lookupModuleEnv PackageIfaceTable
pit GenModule Unit
mod
mainModIs :: HomeUnitEnv -> Module
mainModIs :: HomeUnitEnv -> GenModule Unit
mainModIs HomeUnitEnv
hue = HomeUnit -> ModuleName -> GenModule Unit
mkHomeModule (String -> Maybe HomeUnit -> HomeUnit
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"mainModIs" (Maybe HomeUnit -> HomeUnit) -> Maybe HomeUnit -> HomeUnit
forall a b. (a -> b) -> a -> b
$ HomeUnitEnv -> Maybe HomeUnit
homeUnitEnv_home_unit HomeUnitEnv
hue) (DynFlags -> ModuleName
mainModuleNameIs (HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue))
hscInterp :: HscEnv -> Interp
hscInterp :: HscEnv -> Interp
hscInterp HscEnv
hsc_env = case HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env of
Maybe Interp
Nothing -> GhcException -> Interp
forall a e. (HasCallStack, Exception e) => e -> a
throw (String -> GhcException
InstallationError String
"Couldn't find a target code interpreter. Try with -fexternal-interpreter")
Just Interp
i -> Interp
i
hscUpdateLoggerFlags :: HscEnv -> HscEnv
hscUpdateLoggerFlags :: HscEnv -> HscEnv
hscUpdateLoggerFlags HscEnv
h = HscEnv
h
{ hsc_logger = setLogFlags (hsc_logger h) (initLogFlags (hsc_dflags h)) }
hscUpdateFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags DynFlags -> DynFlags
f HscEnv
h = HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags (DynFlags -> DynFlags
f (HscEnv -> DynFlags
hsc_dflags HscEnv
h)) HscEnv
h
hscSetFlags :: HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
hscSetFlags :: HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags HscEnv
h =
HscEnv -> HscEnv
hscUpdateLoggerFlags (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
h { hsc_dflags = dflags
, hsc_unit_env = ue_setFlags dflags (hsc_unit_env h) }
hscSetActiveHomeUnit :: HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit :: HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit = HasDebugCallStack => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit)
hscSetActiveUnitId :: HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId :: HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId UnitId
uid HscEnv
e = HscEnv
e
{ hsc_unit_env = ue_setActiveUnit uid (hsc_unit_env e)
, hsc_dflags = ue_unitFlags uid (hsc_unit_env e) }
hscActiveUnitId :: HscEnv -> UnitId
hscActiveUnitId :: HscEnv -> UnitId
hscActiveUnitId HscEnv
e = UnitEnv -> UnitId
ue_currentUnit (HscEnv -> UnitEnv
hsc_unit_env HscEnv
e)
discardIC :: HscEnv -> HscEnv
discardIC :: HscEnv -> HscEnv
discardIC HscEnv
hsc_env
= HscEnv
hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print
, ic_monad = new_ic_monad
, ic_plugins = old_plugins
} }
where
!new_ic_int_print :: Name
new_ic_int_print = (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_int_print
!new_ic_monad :: Name
new_ic_monad = (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_monad
!old_plugins :: Plugins
old_plugins = InteractiveContext -> Plugins
ic_plugins InteractiveContext
old_ic
dflags :: DynFlags
dflags = InteractiveContext -> DynFlags
ic_dflags InteractiveContext
old_ic
old_ic :: InteractiveContext
old_ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
empty_ic :: InteractiveContext
empty_ic = DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
keep_external_name :: (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_name
| HomeUnit -> Name -> Bool
nameIsFromExternalPackage HomeUnit
home_unit Name
old_name = Name
old_name
| Bool
otherwise = InteractiveContext -> Name
ic_name InteractiveContext
empty_ic
where
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
old_name :: Name
old_name = InteractiveContext -> Name
ic_name InteractiveContext
old_ic