{-# LANGUAGE LambdaCase #-}

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.Session
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 Data.Set (Set)
import GHC.Unit.Module.Graph
import Data.List (sort)
import qualified Data.Map as Map

runHsc :: HscEnv -> Hsc a -> IO a
runHsc :: forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage)
hsc) = do
    (a
a, Messages GhcMessage
w) <- HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage)
hsc HscEnv
hsc_env forall e. Messages e
emptyMessages
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let !diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
        !print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags
    Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) DiagnosticOpts GhcMessage
print_config DiagOpts
diag_opts Messages GhcMessage
w
    forall (m :: * -> *) a. Monad m => a -> m a
return a
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 forall e. Messages e
emptyMessages

-- | Switches in the DynFlags and Plugins from the InteractiveContext
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
hscSetFlags (InteractiveContext -> DynFlags
ic_dflags InteractiveContext
ic) forall a b. (a -> b) -> a -> b
$
       HscEnv
hsc_env { hsc_plugins :: Plugins
hsc_plugins = InteractiveContext -> Plugins
ic_plugins InteractiveContext
ic }

-- | A variant of runHsc that switches in the DynFlags and Plugins from the
-- InteractiveContext before running the Hsc computation.
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
unsafeGetHomeUnit 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 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
ue_units 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
ue_hpt 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
ue_currentHomeUnitEnv 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 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 = forall v. UnitEnvGraph v -> Set UnitId
unitEnv_keys 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 :: UnitEnv
hsc_unit_env = UnitEnv
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 :: UnitEnv
hsc_unit_env = UnitEnv
res }

hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG HomeUnitGraph -> HomeUnitGraph
f HscEnv
hsc_env = HscEnv
hsc_env { hsc_unit_env :: UnitEnv
hsc_unit_env = (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv
updateHug HomeUnitGraph -> HomeUnitGraph
f (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) }

{-

Note [Target code interpreter]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Template Haskell and GHCi use an interpreter to execute code that is built for
the compiler target platform (= code host platform) on the compiler host
platform (= code build platform).

The internal interpreter can be used when both platforms are the same and when
the built code is compatible with the compiler itself (same way, etc.). This
interpreter is not always available: for instance stage1 compiler doesn't have
it because there might be an ABI mismatch between the code objects (built by
stage1 compiler) and the stage1 compiler itself (built by stage0 compiler).

In most cases, an external interpreter can be used instead: it runs in a
separate process and it communicates with the compiler via a two-way message
passing channel. The process is lazily spawned to avoid overhead when it is not
used.

The target code interpreter to use can be selected per session via the
`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in
which case Template Haskell and GHCi will fail to run. The interpreter to use is
configured via command-line flags (in `GHC.setSessionDynFlags`).


-}

-- Note [hsc_type_env_var hack]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- hsc_type_env_var is used to initialize tcg_type_env_var, and
-- eventually it is the mutable variable that is queried from
-- if_rec_types to get a TypeEnv.  So, clearly, it's something
-- related to knot-tying (see Note [Tying the knot]).
-- hsc_type_env_var is used in two places: initTcRn (where
-- it initializes tcg_type_env_var) and initIfaceCheck
-- (where it initializes if_rec_types).
--
-- But why do we need a way to feed a mutable variable in?  Why
-- can't we just initialize tcg_type_env_var when we start
-- typechecking?  The problem is we need to knot-tie the
-- EPS, and we may start adding things to the EPS before type
-- checking starts.
--
-- Here is a concrete example. Suppose we are running
-- "ghc -c A.hs", and we have this file system state:
--
--  A.hs-boot   A.hi-boot **up to date**
--  B.hs        B.hi      **up to date**
--  A.hs        A.hi      **stale**
--
-- The first thing we do is run checkOldIface on A.hi.
-- checkOldIface will call loadInterface on B.hi so it can
-- get its hands on the fingerprints, to find out if A.hi
-- needs recompilation.  But loadInterface also populates
-- the EPS!  And so if compilation turns out to be necessary,
-- as it is in this case, the thunks we put into the EPS for
-- B.hi need to have the correct if_rec_types mutable variable
-- to query.
--
-- If the mutable variable is only allocated WHEN we start
-- typechecking, then that's too late: we can't get the
-- information to the thunks.  So we need to pre-commit
-- to a type variable in 'hscIncrementalCompile' BEFORE we
-- check the old interface.
--
-- This is all a massive hack because arguably checkOldIface
-- should not populate the EPS. But that's a refactor for
-- another day.

-- | Retrieve the ExternalPackageState cache.
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env = 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 -> [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)

-- | Find all the instance declarations (of classes and families) from
-- the Home Package Table filtered by the provided predicate function.
-- Used in @tcRnImports@, to select the instances that are in the
-- transitive closure of imports from the currently compiled module.
hptAllInstances :: HscEnv -> (InstEnv, [FamInst])
hptAllInstances :: HscEnv -> (InstEnv, [FamInst])
hptAllInstances HscEnv
hsc_env
  = let ([InstEnv]
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
                let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
mod_info
                forall (m :: * -> *) a. Monad m => a -> m a
return (ModDetails -> InstEnv
md_insts ModDetails
details, ModDetails -> [FamInst]
md_fam_insts ModDetails
details)
    in (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' InstEnv -> InstEnv -> InstEnv
unionInstEnv InstEnv
emptyInstEnv [InstEnv]
insts, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
famInsts)

-- | Find instances visible from the given set of imports
hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst])
hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst])
hptInstancesBelow HscEnv
hsc_env UnitId
uid ModuleNameWithIsBoot
mnwib =
  let
    mn :: ModuleName
mn = forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleNameWithIsBoot
mnwib
    ([InstEnv]
insts, [[FamInst]]
famInsts) =
        forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
hptSomeThingsBelowUs (\HomeModInfo
mod_info ->
                                     let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
mod_info
                                     -- Don't include instances for the current module
                                     in if forall unit. GenModule unit -> ModuleName
moduleName (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
mod_info)) 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 -- Include -hi-boot
                             HscEnv
hsc_env
                             UnitId
uid
                             ModuleNameWithIsBoot
mnwib
  in (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' InstEnv -> InstEnv -> InstEnv
unionInstEnv InstEnv
emptyInstEnv [InstEnv]
insts, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
famInsts)

-- | Get rules from modules "below" this one (in the dependency sense)
hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]
hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]
hptRules = forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
hptSomeThingsBelowUs (ModDetails -> [CoreRule]
md_rules forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details) Bool
False


-- | Get annotations from modules "below" this one (in the dependency sense)
hptAnns :: HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation]
hptAnns :: HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation]
hptAnns HscEnv
hsc_env (Just (UnitId
uid, ModuleNameWithIsBoot
mn)) = forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> 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 UnitId
uid ModuleNameWithIsBoot
mn
hptAnns HscEnv
hsc_env Maybe (UnitId, 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 (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HomeModInfo -> [a]
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> [HomeModInfo]
eltsHpt forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
                                (HomeUnitGraph -> [(UnitId, HomeUnitEnv)]
hugElts (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env))

-- | This function returns all the modules belonging to the home-unit that can
-- be reached by following the given dependencies. Additionally, if both the
-- boot module and the non-boot module can be reached, it only returns the
-- non-boot one.
hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
hptModulesBelow HscEnv
hsc_env UnitId
uid ModuleNameWithIsBoot
mn = [ModNodeKeyWithUid] -> Set ModNodeKeyWithUid
filtered_mods forall a b. (a -> b) -> a -> b
$ [ ModNodeKeyWithUid
mn |  NodeKey_Module ModNodeKeyWithUid
mn <- [NodeKey]
modules_below]
  where
    td_map :: Map NodeKey (Set NodeKey)
td_map = ModuleGraph -> Map NodeKey (Set NodeKey)
mgTransDeps (HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env)

    modules_below :: [NodeKey]
modules_below = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid ModuleNameWithIsBoot
mn UnitId
uid)) Map NodeKey (Set NodeKey)
td_map

    filtered_mods :: [ModNodeKeyWithUid] -> Set ModNodeKeyWithUid
filtered_mods = forall a. [a] -> Set a
Set.fromDistinctAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
filter_mods forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort

    -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list
    -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a
    -- linear sweep with a window of size 2 to remove boot modules for which we
    -- have the corresponding non-boot.
    filter_mods :: [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
filter_mods = \case
      (r1 :: ModNodeKeyWithUid
r1@(ModNodeKeyWithUid (GWIB ModuleName
m1 IsBootInterface
b1) UnitId
uid1) : r2 :: ModNodeKeyWithUid
r2@(ModNodeKeyWithUid (GWIB ModuleName
m2 IsBootInterface
_) UnitId
uid2): [ModNodeKeyWithUid]
rs)
        | ModuleName
m1 forall a. Eq a => a -> a -> Bool
== ModuleName
m2  Bool -> Bool -> Bool
&& UnitId
uid1 forall a. Eq a => a -> a -> Bool
== UnitId
uid2 ->
                       let !r' :: ModNodeKeyWithUid
r' = case IsBootInterface
b1 of
                                  IsBootInterface
NotBoot -> ModNodeKeyWithUid
r1
                                  IsBootInterface
IsBoot  -> ModNodeKeyWithUid
r2
                       in ModNodeKeyWithUid
r' forall a. a -> [a] -> [a]
: [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
filter_mods [ModNodeKeyWithUid]
rs
        | Bool
otherwise -> ModNodeKeyWithUid
r1 forall a. a -> [a] -> [a]
: [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
filter_mods (ModNodeKeyWithUid
r2forall a. a -> [a] -> [a]
:[ModNodeKeyWithUid]
rs)
      [ModNodeKeyWithUid]
rs -> [ModNodeKeyWithUid]
rs



-- | Get things from modules "below" this one (in the dependency sense)
-- C.f Inst.hptInstances
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
    in
    [ a
thing
    |
    -- Find each non-hi-boot module below me
      (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) <- forall a. Set a -> [a]
Set.toList (HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
hptModulesBelow HscEnv
hsc_env UnitId
uid ModuleNameWithIsBoot
mn)
    , Bool
include_hi_boot Bool -> Bool -> Bool
|| (IsBootInterface
is_boot forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot)

        -- unsavoury: when compiling the base package with --make, we
        -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't
        -- be in the HPT, because we never compile it; it's in the EPT
        -- instead. ToDo: clean up, and remove this slightly bogus filter:
    , ModuleName
mod forall a. Eq a => a -> a -> Bool
/= forall unit. GenModule unit -> ModuleName
moduleName Module
gHC_PRIM
    , Bool -> Bool
not (ModuleName
mod forall a. Eq a => a -> a -> Bool
== forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleNameWithIsBoot
mn Bool -> Bool -> Bool
&& UnitId
uid forall a. Eq a => a -> a -> Bool
== UnitId
mod_uid)

        -- Look it up in the HPT
    , 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 -> forall a. String -> SDoc -> a -> a
pprTrace String
"WARNING in hptSomeThingsBelowUs" SDoc
msg forall a. Monoid a => a
mempty
          msg :: SDoc
msg = forall doc. IsDoc doc => [doc] -> doc
vcat [forall doc. IsLine doc => String -> doc
text String
"missing module" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
mod,
                     forall doc. IsLine doc => String -> doc
text String
"When starting from"  forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleNameWithIsBoot
mn,
                     forall doc. IsLine doc => String -> doc
text String
"below:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
hptModulesBelow HscEnv
hsc_env UnitId
uid ModuleNameWithIsBoot
mn),
                      forall doc. IsLine doc => String -> doc
text String
"Probable cause: out-of-date interface files"]
                        -- This really shouldn't happen, but see #962
    , a
thing <- [a]
things
    ]



-- | Deal with gathering annotations in from all possible places
--   and combining them into a single 'AnnEnv'
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 -- Extract annotations from the module being compiled if supplied one
        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
        -- Extract dependencies of the module if we are supplied one,
        -- otherwise load annotations from all home package table
        -- entries regardless of dependency ordering.
        get_mod :: ModGuts -> (UnitId, ModuleNameWithIsBoot)
get_mod ModGuts
mg = (Module -> UnitId
moduleUnitId (ModGuts -> Module
mg_module ModGuts
mg), forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (forall unit. GenModule unit -> ModuleName
moduleName (ModGuts -> Module
mg_module ModGuts
mg)) IsBootInterface
NotBoot)
        home_pkg_anns :: AnnEnv
home_pkg_anns  = ([Annotation] -> AnnEnv
mkAnnEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Maybe (UnitId, 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 ModGuts -> (UnitId, ModuleNameWithIsBoot)
get_mod 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

-- | Find the 'TyThing' for the given 'Name' by using all the resources
-- at our disposal: the compiled modules in the 'HomePackageTable' and the
-- compiled modules in other packages that live in 'PackageTypeEnv'. Note
-- that this does NOT look up the 'TyThing' in the module being compiled: you
-- have to do that yourself, if desired
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
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
   let pte :: PackageTypeEnv
pte = ExternalPackageState -> PackageTypeEnv
eps_PTE ExternalPackageState
eps
       hpt :: HomeUnitGraph
hpt = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env

       mod :: Module
mod = forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Name -> Bool
isExternalName Name
name) (forall a. Outputable a => a -> SDoc
ppr Name
name) forall a b. (a -> b) -> a -> b
$
             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))
               -- in one-shot, we don't use the HPT
               then forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv PackageTypeEnv
pte Name
name
               else case Module -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule Module
mod HomeUnitGraph
hpt 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

-- | Find the 'ModIface' for a 'Module', searching in both the loaded home
-- and external package module information
lookupIfaceByModule
        :: HomeUnitGraph
        -> PackageIfaceTable
        -> Module
        -> Maybe ModIface
lookupIfaceByModule :: HomeUnitGraph -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomeUnitGraph
hug PackageIfaceTable
pit Module
mod
  = case Module -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule Module
mod HomeUnitGraph
hug 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
   -- If the module does come from the home package, why do we look in the PIT as well?
   -- (a) In OneShot mode, even home-package modules accumulate in the PIT
   -- (b) Even in Batch (--make) mode, there is *one* case where a home-package
   --     module is in the PIT, namely GHC.Prim when compiling the base package.
   -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package
   -- of its own, but it doesn't seem worth the bother.

mainModIs :: HomeUnitEnv -> Module
mainModIs :: HomeUnitEnv -> Module
mainModIs HomeUnitEnv
hue = HomeUnit -> ModuleName -> Module
mkHomeModule (forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"mainModIs" forall a b. (a -> b) -> a -> b
$ HomeUnitEnv -> Maybe HomeUnit
homeUnitEnv_home_unit  HomeUnitEnv
hue) (DynFlags -> ModuleName
mainModuleNameIs (HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue))

-- | Retrieve the target code interpreter
--
-- Fails if no target code interpreter is available
hscInterp :: HscEnv -> Interp
hscInterp :: HscEnv -> Interp
hscInterp HscEnv
hsc_env = case HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env of
   Maybe Interp
Nothing -> forall a e. 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

-- | Update the LogFlags of the Log in hsc_logger from the DynFlags in
-- hsc_dflags. You need to call this when DynFlags are modified.
hscUpdateLoggerFlags :: HscEnv -> HscEnv
hscUpdateLoggerFlags :: HscEnv -> HscEnv
hscUpdateLoggerFlags HscEnv
h = HscEnv
h
  { hsc_logger :: Logger
hsc_logger = Logger -> LogFlags -> Logger
setLogFlags (HscEnv -> Logger
hsc_logger HscEnv
h) (DynFlags -> LogFlags
initLogFlags (HscEnv -> DynFlags
hsc_dflags HscEnv
h)) }

-- | Update Flags
hscUpdateFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags DynFlags -> DynFlags
f HscEnv
h = HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
hscSetFlags (DynFlags -> DynFlags
f (HscEnv -> DynFlags
hsc_dflags HscEnv
h)) HscEnv
h

-- | Set Flags
hscSetFlags :: HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
hscSetFlags :: HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags HscEnv
h =
  HscEnv -> HscEnv
hscUpdateLoggerFlags forall a b. (a -> b) -> a -> b
$ HscEnv
h { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags
                           , hsc_unit_env :: UnitEnv
hsc_unit_env = HasDebugCallStack => DynFlags -> UnitEnv -> UnitEnv
ue_setFlags DynFlags
dflags (HscEnv -> UnitEnv
hsc_unit_env HscEnv
h) }

-- See Note [Multiple Home Units]
hscSetActiveHomeUnit :: HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit :: HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit = HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (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 :: UnitEnv
hsc_unit_env = UnitId -> UnitEnv -> UnitEnv
ue_setActiveUnit UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
e)
  , hsc_dflags :: DynFlags
hsc_dflags = HasDebugCallStack => UnitId -> UnitEnv -> DynFlags
ue_unitFlags UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
e)  }

hscActiveUnitId :: HscEnv -> UnitId
hscActiveUnitId :: HscEnv -> UnitId
hscActiveUnitId HscEnv
e = UnitEnv -> UnitId
ue_currentUnit (HscEnv -> UnitEnv
hsc_unit_env HscEnv
e)

-- | Discard the contents of the InteractiveContext, but keep the DynFlags and
-- the loaded plugins.  It will also keep ic_int_print and ic_monad if their
-- names are from external packages.
discardIC :: HscEnv -> HscEnv
discardIC :: HscEnv -> HscEnv
discardIC HscEnv
hsc_env
  = HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
empty_ic { ic_int_print :: Name
ic_int_print = Name
new_ic_int_print
                                , ic_monad :: Name
ic_monad     = Name
new_ic_monad
                                , ic_plugins :: Plugins
ic_plugins   = Plugins
old_plugins
                                } }
  where
  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic
  !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