{-# LANGUAGE LambdaCase #-}
module GHC.Driver.Session.Inspect where
import GHC.Prelude
import GHC.Data.Maybe
import Control.Monad
import GHC.ByteCode.Types
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
import GHC.Driver.Env
import GHC.Driver.Main
import GHC.Driver.Monad
import GHC.Driver.Session
import GHC.Rename.Names
import GHC.Runtime.Context
import GHC.Runtime.Interpreter
import GHC.Types.Avail
import GHC.Types.Name
import GHC.Types.Name.Ppr
import GHC.Types.Name.Reader
import GHC.Types.Name.Set
import GHC.Types.PkgQual
import GHC.Types.SafeHaskell
import GHC.Types.SrcLoc
import GHC.Types.TyThing
import GHC.Types.TypeEnv
import GHC.Unit.External
import GHC.Unit.Home.ModInfo
import GHC.Unit.Module
import GHC.Unit.Module.Graph
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModIface
import GHC.Utils.Misc
import GHC.Utils.Outputable
import qualified GHC.Unit.Home.Graph as HUG
getModuleGraph :: GhcMonad m => m ModuleGraph
getModuleGraph :: forall (m :: * -> *). GhcMonad m => m ModuleGraph
getModuleGraph = (HscEnv -> ModuleGraph) -> m HscEnv -> m ModuleGraph
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HscEnv -> ModuleGraph
hsc_mod_graph m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-}
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded :: forall (m :: * -> *). GhcMonad m => ModuleName -> m Bool
isLoaded ModuleName
m = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
hmis <- HomeUnitGraph -> ModuleName -> IO [HomeModInfo]
HUG.lookupAllHug (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env) ModuleName
m
return $! not (null hmis)
isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool
isLoadedModule :: forall (m :: * -> *). GhcMonad m => UnitId -> ModuleName -> m Bool
isLoadedModule UnitId
uid ModuleName
m = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
hmi <- HomeUnitGraph -> UnitId -> ModuleName -> IO (Maybe HomeModInfo)
HUG.lookupHug (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env) UnitId
uid ModuleName
m
return $! isJust hmi
isLoadedHomeModule :: GhcMonad m => Module -> m Bool
isLoadedHomeModule :: forall (m :: * -> *). GhcMonad m => Module -> m Bool
isLoadedHomeModule Module
m = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
hmi <- Module -> HomeUnitGraph -> IO (Maybe HomeModInfo)
HUG.lookupHugByModule Module
m (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env)
return $! isJust hmi
getBindings :: GhcMonad m => m [TyThing]
getBindings :: forall (m :: * -> *). GhcMonad m => m [TyThing]
getBindings = (HscEnv -> m [TyThing]) -> m [TyThing]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [TyThing]) -> m [TyThing])
-> (HscEnv -> m [TyThing]) -> m [TyThing]
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
[TyThing] -> m [TyThing]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyThing] -> m [TyThing]) -> [TyThing] -> m [TyThing]
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> [TyThing]
icInScopeTTs (InteractiveContext -> [TyThing])
-> InteractiveContext -> [TyThing]
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
getInsts :: forall (m :: * -> *). GhcMonad m => m ([ClsInst], [FamInst])
getInsts = (HscEnv -> m ([ClsInst], [FamInst])) -> m ([ClsInst], [FamInst])
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m ([ClsInst], [FamInst])) -> m ([ClsInst], [FamInst]))
-> (HscEnv -> m ([ClsInst], [FamInst])) -> m ([ClsInst], [FamInst])
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
let (InstEnv
inst_env, [FamInst]
fam_env) = InteractiveContext -> (InstEnv, [FamInst])
ic_instances (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
in ([ClsInst], [FamInst]) -> m ([ClsInst], [FamInst])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstEnv -> [ClsInst]
instEnvElts InstEnv
inst_env, [FamInst]
fam_env)
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx :: forall (m :: * -> *). GhcMonad m => m NamePprCtx
getNamePprCtx = (HscEnv -> m NamePprCtx) -> m NamePprCtx
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m NamePprCtx) -> m NamePprCtx)
-> (HscEnv -> m NamePprCtx) -> m NamePprCtx
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
NamePprCtx -> m NamePprCtx
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamePprCtx -> m NamePprCtx) -> NamePprCtx -> m NamePprCtx
forall a b. (a -> b) -> a -> b
$ UnitEnv -> InteractiveContext -> NamePprCtx
icNamePprCtx (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
data ModuleInfo = ModuleInfo {
ModuleInfo -> TypeEnv
minf_type_env :: TypeEnv,
ModuleInfo -> [AvailInfo]
minf_exports :: [AvailInfo],
ModuleInfo -> [ClsInst]
minf_instances :: [ClsInst],
ModuleInfo -> Maybe ModIface
minf_iface :: Maybe ModIface,
ModuleInfo -> SafeHaskellMode
minf_safe :: SafeHaskellMode,
ModuleInfo -> Maybe InternalModBreaks
minf_modBreaks :: Maybe InternalModBreaks
}
getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)
getModuleInfo :: forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
getModuleInfo Module
mdl = (HscEnv -> m (Maybe ModuleInfo)) -> m (Maybe ModuleInfo)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe ModuleInfo)) -> m (Maybe ModuleInfo))
-> (HscEnv -> m (Maybe ModuleInfo)) -> m (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
if Unit -> HomeUnitGraph -> Bool
HUG.memberHugUnit (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mdl) (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env)
then IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo))
-> IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo HscEnv
hsc_env Module
mdl
else IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo))
-> IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo HscEnv
hsc_env Module
mdl
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo HscEnv
hsc_env Module
mdl
= do eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
iface <- hscGetModuleInterface hsc_env mdl
let
avails = ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
iface
pte = ExternalPackageState -> TypeEnv
eps_PTE ExternalPackageState
eps
tys = [ TyThing
ty | Name
name <- (AvailInfo -> [Name]) -> [AvailInfo] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNames [AvailInfo]
avails,
Just TyThing
ty <- [TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
pte Name
name] ]
return (Just (ModuleInfo {
minf_type_env = mkTypeEnv tys,
minf_exports = avails,
minf_instances = error "getModuleInfo: instances for package module unimplemented",
minf_iface = Just iface,
minf_safe = getSafeMode $ mi_trust iface,
minf_modBreaks = Nothing
}))
availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv
availsToGlobalRdrEnv :: HasDebugCallStack =>
HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv
availsToGlobalRdrEnv HscEnv
hsc_env Module
mod [AvailInfo]
avails
= GlobalRdrEnvX GREInfo -> IfGlobalRdrEnv
forall info. GlobalRdrEnvX info -> IfGlobalRdrEnv
forceGlobalRdrEnv GlobalRdrEnvX GREInfo
rdr_env
where
rdr_env :: GlobalRdrEnvX GREInfo
rdr_env = [GlobalRdrElt] -> GlobalRdrEnvX GREInfo
mkGlobalRdrEnv (HscEnv -> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails HscEnv
hsc_env (ImportSpec -> Maybe ImportSpec
forall a. a -> Maybe a
Just ImportSpec
imp_spec) [AvailInfo]
avails)
imp_spec :: ImportSpec
imp_spec = ImpSpec { is_decl :: ImpDeclSpec
is_decl = ImpDeclSpec
decl, is_item :: ImpItemSpec
is_item = ImpItemSpec
ImpAll}
decl :: ImpDeclSpec
decl = ImpDeclSpec { is_mod :: Module
is_mod = Module
mod, is_as :: ModuleName
is_as = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod,
is_qual :: Bool
is_qual = Bool
False, is_isboot :: IsBootInterface
is_isboot = IsBootInterface
NotBoot, is_pkg_qual :: PkgQual
is_pkg_qual = PkgQual
NoPkgQual,
is_dloc :: SrcSpan
is_dloc = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc,
is_level :: ImportLevel
is_level = ImportLevel
NormalLevel }
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo HscEnv
hsc_env Module
mdl =
Module -> HomeUnitGraph -> IO (Maybe HomeModInfo)
HUG.lookupHugByModule Module
mdl (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env) IO (Maybe HomeModInfo)
-> (Maybe HomeModInfo -> IO (Maybe ModuleInfo))
-> IO (Maybe ModuleInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe HomeModInfo
Nothing -> Maybe ModuleInfo -> IO (Maybe ModuleInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleInfo
forall a. Maybe a
Nothing
Just HomeModInfo
hmi -> do
let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
hmi
iface :: ModIface
iface = HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi
Maybe ModuleInfo -> IO (Maybe ModuleInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleInfo -> Maybe ModuleInfo
forall a. a -> Maybe a
Just (ModuleInfo {
minf_type_env :: TypeEnv
minf_type_env = ModDetails -> TypeEnv
md_types ModDetails
details,
minf_exports :: [AvailInfo]
minf_exports = ModDetails -> [AvailInfo]
md_exports ModDetails
details,
minf_instances :: [ClsInst]
minf_instances = InstEnv -> [ClsInst]
instEnvElts (InstEnv -> [ClsInst]) -> InstEnv -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ ModDetails -> InstEnv
md_insts ModDetails
details,
minf_iface :: Maybe ModIface
minf_iface = ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface,
minf_safe :: SafeHaskellMode
minf_safe = IfaceTrustInfo -> SafeHaskellMode
getSafeMode (IfaceTrustInfo -> SafeHaskellMode)
-> IfaceTrustInfo -> SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ ModIface -> IfaceTrustInfo
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust ModIface
iface,
minf_modBreaks :: Maybe InternalModBreaks
minf_modBreaks = HomeModInfo -> Maybe InternalModBreaks
getModBreaks HomeModInfo
hmi
}))
modInfoTyThings :: ModuleInfo -> [TyThing]
modInfoTyThings :: ModuleInfo -> [TyThing]
modInfoTyThings ModuleInfo
minf = TypeEnv -> [TyThing]
typeEnvElts (ModuleInfo -> TypeEnv
minf_type_env ModuleInfo
minf)
modInfoExports :: ModuleInfo -> [Name]
modInfoExports :: ModuleInfo -> [Name]
modInfoExports ModuleInfo
minf = (AvailInfo -> [Name]) -> [AvailInfo] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNames ([AvailInfo] -> [Name]) -> [AvailInfo] -> [Name]
forall a b. (a -> b) -> a -> b
$! ModuleInfo -> [AvailInfo]
minf_exports ModuleInfo
minf
modInfoExportsWithSelectors :: ModuleInfo -> [Name]
modInfoExportsWithSelectors :: ModuleInfo -> [Name]
modInfoExportsWithSelectors ModuleInfo
minf = (AvailInfo -> [Name]) -> [AvailInfo] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNames ([AvailInfo] -> [Name]) -> [AvailInfo] -> [Name]
forall a b. (a -> b) -> a -> b
$! ModuleInfo -> [AvailInfo]
minf_exports ModuleInfo
minf
modInfoInstances :: ModuleInfo -> [ClsInst]
modInfoInstances :: ModuleInfo -> [ClsInst]
modInfoInstances = ModuleInfo -> [ClsInst]
minf_instances
modInfoIsExportedName :: ModuleInfo -> Name -> Bool
modInfoIsExportedName :: ModuleInfo -> Name -> Bool
modInfoIsExportedName ModuleInfo
minf Name
name = Name -> NameSet -> Bool
elemNameSet Name
name ([AvailInfo] -> NameSet
availsToNameSet (ModuleInfo -> [AvailInfo]
minf_exports ModuleInfo
minf))
mkNamePprCtxForModule ::
GhcMonad m =>
Module ->
ModuleInfo ->
m NamePprCtx
mkNamePprCtxForModule :: forall (m :: * -> *).
GhcMonad m =>
Module -> ModuleInfo -> m NamePprCtx
mkNamePprCtxForModule Module
mod ModuleInfo
minf = (HscEnv -> m NamePprCtx) -> m NamePprCtx
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m NamePprCtx) -> m NamePprCtx)
-> (HscEnv -> m NamePprCtx) -> m NamePprCtx
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
let name_ppr_ctx :: NamePprCtx
name_ppr_ctx = PromotionTickContext -> UnitEnv -> IfGlobalRdrEnv -> NamePprCtx
forall info.
Outputable info =>
PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
mkNamePprCtx PromotionTickContext
ptc (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (HasDebugCallStack =>
HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv
HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv
availsToGlobalRdrEnv HscEnv
hsc_env Module
mod (ModuleInfo -> [AvailInfo]
minf_exports ModuleInfo
minf))
ptc :: PromotionTickContext
ptc = DynFlags -> PromotionTickContext
initPromotionTickContext (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
NamePprCtx -> m NamePprCtx
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return NamePprCtx
name_ppr_ctx
modInfoLookupName :: GhcMonad m =>
ModuleInfo -> Name
-> m (Maybe TyThing)
modInfoLookupName :: forall (m :: * -> *).
GhcMonad m =>
ModuleInfo -> Name -> m (Maybe TyThing)
modInfoLookupName ModuleInfo
minf Name
name = (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing))
-> (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
case TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv (ModuleInfo -> TypeEnv
minf_type_env ModuleInfo
minf) Name
name of
Just TyThing
tyThing -> Maybe TyThing -> m (Maybe TyThing)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just TyThing
tyThing)
Maybe TyThing
Nothing -> IO (Maybe TyThing) -> m (Maybe TyThing)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name)
modInfoIface :: ModuleInfo -> Maybe ModIface
modInfoIface :: ModuleInfo -> Maybe ModIface
modInfoIface = ModuleInfo -> Maybe ModIface
minf_iface
modInfoSafe :: ModuleInfo -> SafeHaskellMode
modInfoSafe :: ModuleInfo -> SafeHaskellMode
modInfoSafe = ModuleInfo -> SafeHaskellMode
minf_safe
modInfoModBreaks :: ModuleInfo -> Maybe InternalModBreaks
modInfoModBreaks :: ModuleInfo -> Maybe InternalModBreaks
modInfoModBreaks = ModuleInfo -> Maybe InternalModBreaks
minf_modBreaks