{-# 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
   , hscInsertHPT
   , hscSetActiveHomeUnit
   , hscSetActiveUnitId
   , hscActiveUnitId
   , runHsc
   , runHsc'
   , mkInteractiveHscEnv
   , runInteractiveHsc
   , hscEPS
   , hscInterp
   , prepareAnnotations
   , discardIC
   , lookupType
   , lookupIfaceByModule
   , mainModIs

   , hugRulesBelow
   , hugInstancesBelow
   , hugAnnsBelow

    -- * Legacy API
   , hscUpdateHPT
   )
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.Home.PackageTable
import GHC.Unit.Home.Graph
import GHC.Unit.Module.Graph
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Env as UnitEnv
import GHC.Unit.External

import GHC.Types.Error ( emptyMessages, Messages )
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.TyThing

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 GHC.Core.Rules
import GHC.Types.Annotations
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Builtin.Names

import Data.IORef
import qualified Data.Set as Set

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

-- | 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
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 }

-- | 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 = 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_unsafeHomeUnit (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_homeUnitState (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
HUG.allUnits (HomeUnitGraph -> Set UnitId)
-> (HscEnv -> HomeUnitGraph) -> HscEnv -> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> HomeUnitGraph
hsc_HUG

hscInsertHPT :: HomeModInfo -> HscEnv -> IO ()
hscInsertHPT :: HomeModInfo -> HscEnv -> IO ()
hscInsertHPT HomeModInfo
hmi HscEnv
hsc_env = HasDebugCallStack => HomeModInfo -> UnitEnv -> IO ()
HomeModInfo -> UnitEnv -> IO ()
UnitEnv.insertHpt HomeModInfo
hmi (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)

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) }

{-

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.setTopSessionDynFlags`).


-}

-- 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 = 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)))

--------------------------------------------------------------------------------
-- * Queries on Transitive Closure
--------------------------------------------------------------------------------

-- | Find all rules in modules that are in the transitive closure of the given
-- module.
hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase
hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase
hugRulesBelow HscEnv
hsc UnitId
uid ModuleNameWithIsBoot
mn = ([CoreRule] -> RuleBase -> RuleBase)
-> RuleBase -> [[CoreRule]] -> RuleBase
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((RuleBase -> [CoreRule] -> RuleBase)
-> [CoreRule] -> RuleBase -> RuleBase
forall a b c. (a -> b -> c) -> b -> a -> c
flip RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList) RuleBase
emptyRuleBase ([[CoreRule]] -> RuleBase) -> IO [[CoreRule]] -> IO RuleBase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (HomeModInfo -> [CoreRule])
-> Bool
-> HscEnv
-> UnitId
-> ModuleNameWithIsBoot
-> IO [[CoreRule]]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]]
hugSomeThingsBelowUs (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 HscEnv
hsc UnitId
uid ModuleNameWithIsBoot
mn

-- | Get annotations from all modules "below" this one (in the dependency
-- sense) within the home units. If the module is @Nothing@, returns /all/
-- annotations in the home units.
hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv
hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv
hugAnnsBelow HscEnv
hsc UnitId
uid ModuleNameWithIsBoot
mn = ([Annotation] -> AnnEnv -> AnnEnv)
-> AnnEnv -> [[Annotation]] -> AnnEnv
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((AnnEnv -> [Annotation] -> AnnEnv)
-> [Annotation] -> AnnEnv -> AnnEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip AnnEnv -> [Annotation] -> AnnEnv
extendAnnEnvList) AnnEnv
emptyAnnEnv ([[Annotation]] -> AnnEnv) -> IO [[Annotation]] -> IO AnnEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (HomeModInfo -> [Annotation])
-> Bool
-> HscEnv
-> UnitId
-> ModuleNameWithIsBoot
-> IO [[Annotation]]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]]
hugSomeThingsBelowUs (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 UnitId
uid ModuleNameWithIsBoot
mn

-- | Find instances visible from the given set of imports
hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst])
hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst])
hugInstancesBelow HscEnv
hsc_env UnitId
uid ModuleNameWithIsBoot
mnwib = do
 let mn :: ModuleName
mn = ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleNameWithIsBoot
mnwib
 (insts, famInsts) <-
     [(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]])
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
unzip ([(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]]))
-> ([[(InstEnv, [FamInst])]] -> [(InstEnv, [FamInst])])
-> [[(InstEnv, [FamInst])]]
-> ([InstEnv], [[FamInst]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(InstEnv, [FamInst])]] -> [(InstEnv, [FamInst])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(InstEnv, [FamInst])]] -> ([InstEnv], [[FamInst]]))
-> IO [[(InstEnv, [FamInst])]] -> IO ([InstEnv], [[FamInst]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
       (HomeModInfo -> [(InstEnv, [FamInst])])
-> Bool
-> HscEnv
-> UnitId
-> ModuleNameWithIsBoot
-> IO [[(InstEnv, [FamInst])]]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]]
hugSomeThingsBelowUs (\HomeModInfo
mod_info ->
                                  let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
mod_info
                                  -- Don't include instances for the current module
                                  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 -- Include -hi-boot
                          HscEnv
hsc_env
                          UnitId
uid
                          ModuleNameWithIsBoot
mnwib
 return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)

-- | Get things from modules in the transitive closure of the given module.
--
-- Note: Don't expose this function. This is a footgun if exposed!
hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]]
hugSomeThingsBelowUs :: forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]]
hugSomeThingsBelowUs HomeModInfo -> [a]
extract Bool
include_hi_boot HscEnv
hsc_env UnitId
uid ModuleNameWithIsBoot
mn
  = let hug :: HomeUnitGraph
hug = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env
        mg :: ModuleGraph
mg  = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env
    in
    [IO [a]] -> IO [[a]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
    [ IO [a]
things
      -- "Finding each non-hi-boot module below me" maybe could be cached (well,
      -- the inverse) in the module graph to avoid filtering the boots out of
      -- the transitive closure out every time this is called
    | (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)

        -- 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 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)

        -- Look it up in the HUG
    , let things :: IO [a]
things = HomeUnitGraph -> UnitId -> ModuleName -> IO (Maybe HomeModInfo)
lookupHug HomeUnitGraph
hug UnitId
mod_uid ModuleName
mod IO (Maybe HomeModInfo) -> (Maybe HomeModInfo -> IO [a]) -> IO [a]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Just HomeModInfo
info -> [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> IO [a]) -> [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> [a]
extract HomeModInfo
info
                    Maybe HomeModInfo
Nothing -> String -> SDoc -> IO [a] -> IO [a]
forall a. String -> SDoc -> a -> a
pprTrace String
"WARNING in hugSomeThingsBelowUs" SDoc
msg IO [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"]
                        -- This really shouldn't happen, but see #962
    ]

-- | 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
    eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
    let -- Extract annotations from the module being compiled if supplied one
        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
        -- 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
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  <- fromMaybe (hugAllAnns (hsc_unit_env hsc_env))
                      $ uncurry (hugAnnsBelow hsc_env)
                      . get_mod <$> mb_guts
    let
        other_pkg_anns = ExternalPackageState -> AnnEnv
eps_ann_env ExternalPackageState
eps
        !ann_env       = (AnnEnv -> AnnEnv)
-> (AnnEnv -> AnnEnv -> AnnEnv) -> Maybe AnnEnv -> AnnEnv -> AnnEnv
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AnnEnv -> AnnEnv
forall a. a -> a
id AnnEnv -> AnnEnv -> AnnEnv
plusAnnEnv Maybe AnnEnv
mb_this_module_anns (AnnEnv -> AnnEnv) -> AnnEnv -> AnnEnv
forall a b. (a -> b) -> a -> b
$!
            AnnEnv -> AnnEnv -> AnnEnv
plusAnnEnv AnnEnv
home_pkg_anns AnnEnv
other_pkg_anns
    return 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
   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
   lookupTypeInPTE hsc_env pte name

lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> IO (Maybe TyThing)
lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> IO (Maybe TyThing)
lookupTypeInPTE HscEnv
hsc_env PackageTypeEnv
pte Name
name = IO (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 :: IO (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 Maybe TyThing -> IO (Maybe TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TyThing -> IO (Maybe TyThing))
-> Maybe TyThing -> IO (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$! PackageTypeEnv -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv PackageTypeEnv
pte Name
name
            else GenModule Unit -> HomeUnitGraph -> IO (Maybe HomeModInfo)
HUG.lookupHugByModule GenModule Unit
mod HomeUnitGraph
hpt IO (Maybe HomeModInfo)
-> (Maybe HomeModInfo -> IO (Maybe TyThing)) -> IO (Maybe TyThing)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
             Just HomeModInfo
hm -> Maybe TyThing -> IO (Maybe TyThing)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TyThing -> IO (Maybe TyThing))
-> Maybe TyThing -> IO (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$! 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 -> Maybe TyThing -> IO (Maybe TyThing)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TyThing -> IO (Maybe TyThing))
-> Maybe TyThing -> IO (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$! PackageTypeEnv -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv PackageTypeEnv
pte Name
name

-- | Find the 'ModIface' for a 'Module', searching in both the loaded home
-- and external package module information
lookupIfaceByModule
        :: HomeUnitGraph
        -> PackageIfaceTable
        -> Module
        -> IO (Maybe ModIface)
lookupIfaceByModule :: HomeUnitGraph
-> PackageIfaceTable
-> GenModule Unit
-> IO (Maybe (ModIface_ 'ModIfaceFinal))
lookupIfaceByModule HomeUnitGraph
hug PackageIfaceTable
pit GenModule Unit
mod
  = GenModule Unit -> HomeUnitGraph -> IO (Maybe HomeModInfo)
HUG.lookupHugByModule GenModule Unit
mod HomeUnitGraph
hug IO (Maybe HomeModInfo)
-> (Maybe HomeModInfo -> IO (Maybe (ModIface_ 'ModIfaceFinal)))
-> IO (Maybe (ModIface_ 'ModIfaceFinal))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (ModIface_ 'ModIfaceFinal)
-> IO (Maybe (ModIface_ 'ModIfaceFinal))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ModIface_ 'ModIfaceFinal)
 -> IO (Maybe (ModIface_ 'ModIfaceFinal)))
-> (Maybe HomeModInfo -> Maybe (ModIface_ 'ModIfaceFinal))
-> Maybe HomeModInfo
-> IO (Maybe (ModIface_ 'ModIfaceFinal))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
       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
   -- 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 -> 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))

-- | 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 -> 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

-- | 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 = setLogFlags (hsc_logger h) (initLogFlags (hsc_dflags h)) }

-- | Update Flags
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

-- | Set Flags
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) }

-- See Note [Multiple Home Units]
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)

-- | 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 = empty_ic { ic_int_print = new_ic_int_print
                                , ic_monad     = new_ic_monad
                                , ic_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


--------------------------------------------------------------------------------
-- * The Legacy API, should be removed after enough deprecation cycles
--------------------------------------------------------------------------------

{-# DEPRECATED hscUpdateHPT "Updating the HPT directly is no longer a supported \
   \ operation. Instead, the HPT is an insert-only data structure. If you want to \
   \ overwrite an existing entry, just use 'hscInsertHPT' to insert it again (it \
   \ will override the existing entry if there is one). See 'GHC.Unit.Home.PackageTable' for more details." #-}
hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT HomePackageTable -> HomePackageTable
f HscEnv
hsc_env = HscEnv
hsc_env { hsc_unit_env = updateHug (HUG.unitEnv_adjust upd (ue_currentUnit $ hsc_unit_env hsc_env)) ue }
  where
    ue :: UnitEnv
ue = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
    upd :: HomeUnitEnv -> HomeUnitEnv
upd HomeUnitEnv
hue = HomeUnitEnv
hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue) }