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.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.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 GHC.Unit.Module.Graph

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 Messages GhcMessage
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
GhcMessageOpts
print_config DiagOpts
diag_opts Messages GhcMessage
w
    a -> IO a
forall a. a -> IO a
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 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
unsafeGetHomeUnit (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_units (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
forall v. UnitEnvGraph v -> Set UnitId
unitEnv_keys (HomeUnitGraph -> Set UnitId)
-> (HscEnv -> HomeUnitGraph) -> HscEnv -> Set UnitId
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 = 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 = res }

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

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)

-- | 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) = [(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]]))
-> [(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]])
forall a b. (a -> b) -> a -> b
$ ((HomeModInfo -> [(InstEnv, [FamInst])])
 -> HscEnv -> [(InstEnv, [FamInst])])
-> HscEnv
-> (HomeModInfo -> [(InstEnv, [FamInst])])
-> [(InstEnv, [FamInst])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (HomeModInfo -> [(InstEnv, [FamInst])])
-> HscEnv -> [(InstEnv, [FamInst])]
forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings HscEnv
hsc_env ((HomeModInfo -> [(InstEnv, [FamInst])]) -> [(InstEnv, [FamInst])])
-> (HomeModInfo -> [(InstEnv, [FamInst])])
-> [(InstEnv, [FamInst])]
forall a b. (a -> b) -> a -> b
$ \HomeModInfo
mod_info -> do
                let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
mod_info
                (InstEnv, [FamInst]) -> [(InstEnv, [FamInst])]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (ModDetails -> InstEnv
md_insts ModDetails
details, ModDetails -> [FamInst]
md_fam_insts ModDetails
details)
    in ((InstEnv -> InstEnv -> InstEnv) -> InstEnv -> [InstEnv] -> InstEnv
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' InstEnv -> InstEnv -> InstEnv
unionInstEnv InstEnv
emptyInstEnv [InstEnv]
insts, [[FamInst]] -> [FamInst]
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 = ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleNameWithIsBoot
mnwib
    ([InstEnv]
insts, [[FamInst]]
famInsts) =
        [(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]]))
-> [(InstEnv, [FamInst])] -> ([InstEnv], [[FamInst]])
forall a b. (a -> b) -> a -> b
$ (HomeModInfo -> [(InstEnv, [FamInst])])
-> Bool
-> HscEnv
-> UnitId
-> ModuleNameWithIsBoot
-> [(InstEnv, [FamInst])]
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 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
  in ((InstEnv -> InstEnv -> InstEnv) -> InstEnv -> [InstEnv] -> InstEnv
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' InstEnv -> InstEnv -> InstEnv
unionInstEnv InstEnv
emptyInstEnv [InstEnv]
insts, [[FamInst]] -> [FamInst]
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 = (HomeModInfo -> [CoreRule])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> 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


-- | 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)) = (HomeModInfo -> [Annotation])
-> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [Annotation]
forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> UnitId -> 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 UnitId
uid ModuleNameWithIsBoot
mn
hptAnns HscEnv
hsc_env Maybe (UnitId, 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 = ((UnitId, HomeUnitEnv) -> [a]) -> [(UnitId, HomeUnitEnv)] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((HomeModInfo -> [a]) -> [HomeModInfo] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HomeModInfo -> [a]
extract ([HomeModInfo] -> [a])
-> ((UnitId, HomeUnitEnv) -> [HomeModInfo])
-> (UnitId, HomeUnitEnv)
-> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> [HomeModInfo]
eltsHpt (HomePackageTable -> [HomeModInfo])
-> ((UnitId, HomeUnitEnv) -> HomePackageTable)
-> (UnitId, HomeUnitEnv)
-> [HomeModInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt (HomeUnitEnv -> HomePackageTable)
-> ((UnitId, HomeUnitEnv) -> HomeUnitEnv)
-> (UnitId, HomeUnitEnv)
-> HomePackageTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId, HomeUnitEnv) -> HomeUnitEnv
forall a b. (a, b) -> b
snd)
                                (HomeUnitGraph -> [(UnitId, HomeUnitEnv)]
hugElts (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env))

-- | 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
        mg :: ModuleGraph
mg  = HscEnv -> ModuleGraph
hsc_mod_graph 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) <- 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 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 -> String -> SDoc -> [a] -> [a]
forall a. String -> SDoc -> a -> a
pprTrace String
"WARNING in hptSomeThingsBelowUs" SDoc
msg [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
    , 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 = (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 -> (UnitId, ModuleNameWithIsBoot)
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 :: AnnEnv
home_pkg_anns  = ([Annotation] -> AnnEnv
mkAnnEnv ([Annotation] -> AnnEnv)
-> (Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation])
-> Maybe (UnitId, ModuleNameWithIsBoot)
-> AnnEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation]
hptAnns HscEnv
hsc_env) (Maybe (UnitId, ModuleNameWithIsBoot) -> AnnEnv)
-> Maybe (UnitId, ModuleNameWithIsBoot) -> AnnEnv
forall a b. (a -> b) -> a -> b
$ (ModGuts -> (UnitId, ModuleNameWithIsBoot))
-> Maybe ModGuts -> Maybe (UnitId, ModuleNameWithIsBoot)
forall a b. (a -> b) -> Maybe a -> Maybe 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        = (AnnEnv -> AnnEnv -> AnnEnv) -> [AnnEnv] -> AnnEnv
forall a. HasCallStack => (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 a. a -> IO a
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 <- 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 :: PackageTypeEnv
pte = ExternalPackageState -> PackageTypeEnv
eps_PTE ExternalPackageState
eps
   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
$ HscEnv -> PackageTypeEnv -> Name -> Maybe TyThing
lookupTypeInPTE HscEnv
hsc_env PackageTypeEnv
pte Name
name

lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> Maybe TyThing
lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> Maybe TyThing
lookupTypeInPTE HscEnv
hsc_env PackageTypeEnv
pte Name
name = 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 :: 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 PackageTypeEnv -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv PackageTypeEnv
pte Name
name
            else case GenModule Unit -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule GenModule Unit
mod HomeUnitGraph
hpt 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

-- | 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
-> GenModule Unit
-> Maybe (ModIface_ 'ModIfaceFinal)
lookupIfaceByModule HomeUnitGraph
hug PackageIfaceTable
pit GenModule Unit
mod
  = case GenModule Unit -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule GenModule Unit
mod HomeUnitGraph
hug 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
   -- 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. HasCallStack => 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. 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