{-# LANGUAGE CPP #-}
module GHC.Driver.Env
( Hsc(..)
, HscEnv (..)
, hsc_home_unit
, hsc_units
, runHsc
, mkInteractiveHscEnv
, runInteractiveHsc
, hscEPS
, hptCompleteSigs
, hptInstances
, hptAnns
, hptAllThings
, hptSomeThingsBelowUs
, hptRules
, prepareAnnotations
, lookupType
, lookupIfaceByModule
, mainModIs
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Driver.Errors ( printOrThrowWarnings )
import GHC.Runtime.Context
import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )
import GHC.Unit
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Deps
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 ( ClsInst )
import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )
import GHC.Types.CompleteMatch
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.Data.Bag
import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Misc
import Control.Monad ( guard )
import Data.IORef
runHsc :: HscEnv -> Hsc a -> IO a
runHsc :: forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc HscEnv -> WarningMessages -> IO (a, WarningMessages)
hsc) = do
(a
a, WarningMessages
w) <- HscEnv -> WarningMessages -> IO (a, WarningMessages)
hsc HscEnv
hsc_env WarningMessages
forall a. Bag a
emptyBag
Logger -> DynFlags -> WarningMessages -> IO ()
printOrThrowWarnings (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) WarningMessages
w
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
mkInteractiveHscEnv :: HscEnv -> HscEnv
mkInteractiveHscEnv :: HscEnv -> HscEnv
mkInteractiveHscEnv HscEnv
hsc_env =
let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
in HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = InteractiveContext -> DynFlags
ic_dflags InteractiveContext
ic
, hsc_plugins :: [LoadedPlugin]
hsc_plugins = InteractiveContext -> [LoadedPlugin]
ic_plugins InteractiveContext
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
ue_home_unit (UnitEnv -> HomeUnit) -> (HscEnv -> UnitEnv) -> HscEnv -> HomeUnit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env
hsc_units :: HscEnv -> UnitState
hsc_units :: HscEnv -> UnitState
hsc_units = 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
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env = IORef ExternalPackageState -> IO ExternalPackageState
forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)
hptCompleteSigs :: HscEnv -> [CompleteMatch]
hptCompleteSigs :: HscEnv -> [CompleteMatch]
hptCompleteSigs = (HomeModInfo -> [CompleteMatch]) -> HscEnv -> [CompleteMatch]
forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings (ModDetails -> [CompleteMatch]
md_complete_matches (ModDetails -> [CompleteMatch])
-> (HomeModInfo -> ModDetails) -> HomeModInfo -> [CompleteMatch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details)
hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])
hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])
hptInstances HscEnv
hsc_env ModuleName -> Bool
want_this_module
= let ([[ClsInst]]
insts, [[FamInst]]
famInsts) = [([ClsInst], [FamInst])] -> ([[ClsInst]], [[FamInst]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([ClsInst], [FamInst])] -> ([[ClsInst]], [[FamInst]]))
-> [([ClsInst], [FamInst])] -> ([[ClsInst]], [[FamInst]])
forall a b. (a -> b) -> a -> b
$ ((HomeModInfo -> [([ClsInst], [FamInst])])
-> HscEnv -> [([ClsInst], [FamInst])])
-> HscEnv
-> (HomeModInfo -> [([ClsInst], [FamInst])])
-> [([ClsInst], [FamInst])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (HomeModInfo -> [([ClsInst], [FamInst])])
-> HscEnv -> [([ClsInst], [FamInst])]
forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings HscEnv
hsc_env ((HomeModInfo -> [([ClsInst], [FamInst])])
-> [([ClsInst], [FamInst])])
-> (HomeModInfo -> [([ClsInst], [FamInst])])
-> [([ClsInst], [FamInst])]
forall a b. (a -> b) -> a -> b
$ \HomeModInfo
mod_info -> do
Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ModuleName -> Bool
want_this_module (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))))
let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
mod_info
([ClsInst], [FamInst]) -> [([ClsInst], [FamInst])]
forall (m :: * -> *) a. Monad m => a -> m a
return (ModDetails -> [ClsInst]
md_insts ModDetails
details, ModDetails -> [FamInst]
md_fam_insts ModDetails
details)
in ([[ClsInst]] -> [ClsInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ClsInst]]
insts, [[FamInst]] -> [FamInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
famInsts)
hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
hptRules = (HomeModInfo -> [CoreRule])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> [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 [ModuleNameWithIsBoot] -> [Annotation]
hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]
hptAnns HscEnv
hsc_env (Just [ModuleNameWithIsBoot]
deps) = (HomeModInfo -> [Annotation])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [Annotation]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> [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 [ModuleNameWithIsBoot]
deps
hptAnns HscEnv
hsc_env Maybe [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 = (HomeModInfo -> [a]) -> [HomeModInfo] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HomeModInfo -> [a]
extract (HomePackageTable -> [HomeModInfo]
eltsHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env))
hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs :: forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs HomeModInfo -> [a]
extract Bool
include_hi_boot HscEnv
hsc_env [ModuleNameWithIsBoot]
deps
| GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) = []
| Bool
otherwise
= let hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
in
[ a
thing
|
GWIB { gwib_mod :: forall mod. GenWithIsBoot mod -> mod
gwib_mod = ModuleName
mod, gwib_isBoot :: forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot = IsBootInterface
is_boot } <- [ModuleNameWithIsBoot]
deps
, 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
, let things :: [a]
things = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt 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 []
msg :: SDoc
msg = [SDoc] -> SDoc
vcat [String -> SDoc
text String
"missing module" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod,
String -> SDoc
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
ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
let
mb_this_module_anns :: Maybe AnnEnv
mb_this_module_anns = (ModGuts -> AnnEnv) -> Maybe ModGuts -> Maybe AnnEnv
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
home_pkg_anns :: AnnEnv
home_pkg_anns = ([Annotation] -> AnnEnv
mkAnnEnv ([Annotation] -> AnnEnv)
-> (Maybe [ModuleNameWithIsBoot] -> [Annotation])
-> Maybe [ModuleNameWithIsBoot]
-> AnnEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]
hptAnns HscEnv
hsc_env) (Maybe [ModuleNameWithIsBoot] -> AnnEnv)
-> Maybe [ModuleNameWithIsBoot] -> AnnEnv
forall a b. (a -> b) -> a -> b
$ (ModGuts -> [ModuleNameWithIsBoot])
-> Maybe ModGuts -> Maybe [ModuleNameWithIsBoot]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dependencies -> [ModuleNameWithIsBoot]
dep_mods (Dependencies -> [ModuleNameWithIsBoot])
-> (ModGuts -> Dependencies) -> ModGuts -> [ModuleNameWithIsBoot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> Dependencies
mg_deps) Maybe ModGuts
mb_guts
other_pkg_anns :: AnnEnv
other_pkg_anns = ExternalPackageState -> AnnEnv
eps_ann_env ExternalPackageState
eps
ann_env :: AnnEnv
ann_env = (AnnEnv -> AnnEnv -> AnnEnv) -> [AnnEnv] -> AnnEnv
forall a. (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]
AnnEnv -> IO AnnEnv
forall (m :: * -> *) a. Monad m => a -> m a
return AnnEnv
ann_env
lookupType :: HscEnv -> Name -> IO (Maybe TyThing)
lookupType :: HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name = do
ExternalPackageState
eps <- IO ExternalPackageState -> IO ExternalPackageState
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
$ IORef ExternalPackageState -> IO ExternalPackageState
forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)
let pte :: PackageTypeEnv
pte = ExternalPackageState -> PackageTypeEnv
eps_PTE ExternalPackageState
eps
hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
mod :: GenModule Unit
mod = ASSERT2( isExternalName name, ppr name )
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 HomePackageTable -> GenModule Unit -> Maybe HomeModInfo
lookupHptByModule HomePackageTable
hpt GenModule Unit
mod 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
Maybe TyThing -> IO (Maybe TyThing)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TyThing
ty
lookupIfaceByModule
:: HomePackageTable
-> PackageIfaceTable
-> Module
-> Maybe ModIface
lookupIfaceByModule :: HomePackageTable
-> PackageIfaceTable
-> GenModule Unit
-> Maybe (ModIface_ 'ModIfaceFinal)
lookupIfaceByModule HomePackageTable
hpt PackageIfaceTable
pit GenModule Unit
mod
= case HomePackageTable -> GenModule Unit -> Maybe HomeModInfo
lookupHptByModule HomePackageTable
hpt GenModule Unit
mod 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 :: HscEnv -> Module
mainModIs :: HscEnv -> GenModule Unit
mainModIs HscEnv
hsc_env = HomeUnit -> ModuleName -> GenModule Unit
mkHomeModule (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) (DynFlags -> ModuleName
mainModuleNameIs (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))