{-# 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 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
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 = 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 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 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 = forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)
hptCompleteSigs :: HscEnv -> [CompleteMatch]
hptCompleteSigs :: HscEnv -> [CompleteMatch]
hptCompleteSigs = forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings (ModDetails -> [CompleteMatch]
md_complete_matches 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) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ \HomeModInfo
mod_info -> do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ModuleName -> Bool
want_this_module (forall unit. GenModule unit -> ModuleName
moduleName (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
mod_info))))
let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
mod_info
forall (m :: * -> *) a. Monad m => a -> m a
return (ModDetails -> [ClsInst]
md_insts ModDetails
details, ModDetails -> [FamInst]
md_fam_insts ModDetails
details)
in (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ClsInst]]
insts, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
famInsts)
hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
hptRules = forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs (ModDetails -> [CoreRule]
md_rules 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) = forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs (ModDetails -> [Annotation]
md_anns 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 = forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings (ModDetails -> [Annotation]
md_anns 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 = 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 forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot)
, ModuleName
mod forall a. Eq a => a -> a -> Bool
/= forall unit. GenModule unit -> ModuleName
moduleName Module
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 -> 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
<+> 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Annotation] -> AnnEnv
mkAnnEnv 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]
hptAnns HscEnv
hsc_env) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dependencies -> [ModuleNameWithIsBoot]
dep_mods 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 = forall a. (a -> a -> a) -> [a] -> a
foldl1' AnnEnv -> AnnEnv -> AnnEnv
plusAnnEnv forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe AnnEnv
mb_this_module_anns,
forall a. a -> Maybe a
Just AnnEnv
home_pkg_anns,
forall a. a -> Maybe a
Just AnnEnv
other_pkg_anns]
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 :: Module
mod = ASSERT2( isExternalName name, ppr name )
if Name -> Bool
isHoleName Name
name
then HomeUnit -> ModuleName -> Module
mkHomeModule (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) (forall unit. GenModule unit -> ModuleName
moduleName (HasDebugCallStack => Name -> Module
nameModule Name
name))
else HasDebugCallStack => Name -> Module
nameModule Name
name
!ty :: Maybe TyThing
ty = if GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
then forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv PackageTypeEnv
pte Name
name
else case HomePackageTable -> Module -> Maybe HomeModInfo
lookupHptByModule HomePackageTable
hpt Module
mod of
Just HomeModInfo
hm -> forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (ModDetails -> PackageTypeEnv
md_types (HomeModInfo -> ModDetails
hm_details HomeModInfo
hm)) Name
name
Maybe HomeModInfo
Nothing -> forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv PackageTypeEnv
pte Name
name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TyThing
ty
lookupIfaceByModule
:: HomePackageTable
-> PackageIfaceTable
-> Module
-> Maybe ModIface
lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomePackageTable
hpt PackageIfaceTable
pit Module
mod
= case HomePackageTable -> Module -> Maybe HomeModInfo
lookupHptByModule HomePackageTable
hpt Module
mod of
Just HomeModInfo
hm -> forall a. a -> Maybe a
Just (HomeModInfo -> ModIface
hm_iface HomeModInfo
hm)
Maybe HomeModInfo
Nothing -> forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv PackageIfaceTable
pit Module
mod
mainModIs :: HscEnv -> Module
mainModIs :: HscEnv -> Module
mainModIs HscEnv
hsc_env = HomeUnit -> ModuleName -> Module
mkHomeModule (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) (DynFlags -> ModuleName
mainModuleNameIs (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))