{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.Driver.Downsweep
  ( downsweep
  , downsweepThunk
  , downsweepInstalledModules
  , downsweepFromRootNodes
  , DownsweepMode(..)
   -- * Summary functions
  , summariseModule
  , summariseFile
  , summariseModuleInterface
  , SummariseResult(..)
  -- * Helper functions
  , instantiationNodes
  , checkHomeUnitsClosed
  ) where

import GHC.Prelude

import GHC.Platform.Ways

import GHC.Driver.Config.Finder (initFinderOpts)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Phases
import {-# SOURCE #-} GHC.Driver.Pipeline (preprocess)
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Monad
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.Messager
import GHC.Driver.MakeSem
import GHC.Driver.MakeAction
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Ppr

import GHC.Iface.Load

import GHC.Parser.Header
import GHC.Rename.Names
import GHC.Tc.Utils.Backpack

import GHC.Data.Graph.Directed
import GHC.Data.FastString
import GHC.Data.Maybe      ( expectJust )
import qualified GHC.Data.Maybe as M
import GHC.Data.OsPath     ( unsafeEncodeUtf )
import GHC.Data.StringBuffer
import GHC.Data.Graph.Directed.Reachability
import qualified GHC.LanguageExtensions as LangExt

import GHC.Utils.Exception ( throwIO, SomeAsyncException )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Fingerprint
import GHC.Utils.TmpFs
import GHC.Utils.Constants

import GHC.Types.Error
import GHC.Types.Target
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.Unique.Map
import GHC.Types.PkgQual

import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Graph
import GHC.Unit.Module.Deps
import qualified GHC.Unit.Home.Graph as HUG

import Data.Either ( rights, partitionEithers, lefts )
import qualified Data.Map as Map
import qualified Data.Set as Set

import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import qualified Control.Monad.Catch as MC
import Data.Maybe
import Data.List (partition)
import Data.Time
import Data.List (unfoldr)
import Data.Bifunctor (first)
import System.Directory
import System.FilePath

import Control.Monad.Trans.Reader
import qualified Data.Map.Strict as M
import Control.Monad.Trans.Class
import System.IO.Unsafe (unsafeInterleaveIO)

{-
Note [Downsweep and the ModuleGraph]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The ModuleGraph stores the relationship between all the modules, units, and
instantiations in the current session.

When we do downsweep, we build up a new ModuleGraph, starting from the root
modules. By following all the dependencies we construct a graph which allows
us to answer questions about the transitive closure of the imports.

The module graph is accessible in the HscEnv.

When is this graph constructed?

1. In `--make` mode, we construct the graph before starting to do any compilation.

2. In `-c` (oneshot) mode, we construct the graph when we have calculated the
   ModSummary for the module we are compiling. The `ModuleGraph` is stored in a
   thunk, so it is only constructed when it is needed. This avoids reading
   the interface files of the whole transitive closure unless they are needed.

3. In some situations (such as loading plugins) we may need to construct the
   graph without having a ModSummary. In this case we use the `downsweepInstalledModules`
   function.

The result is having a uniform graph available for the whole compilation pipeline.

-}

-- This caches the answer to the question, if we are in this unit, what does
-- an import of this module mean.
type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo]

-----------------------------------------------------------------------------
--
-- | Downsweep (dependency analysis) for --make mode
--
-- Chase downwards from the specified root set, returning summaries
-- for all home modules encountered.  Only follow source-import
-- links.
--
-- We pass in the previous collection of summaries, which is used as a
-- cache to avoid recalculating a module summary if the source is
-- unchanged.
--
-- The returned ModuleGraph has one node for each home-package
-- module, plus one for any hs-boot files.  The imports of these nodes
-- are all there, including the imports of non-home-package modules.
--
-- This function is intendned for use by --make mode and will also insert
-- LinkNodes and InstantiationNodes for any home units.
--
-- It will also turn on code generation for any modules that need it by calling
-- 'enableCodeGenForTH'.
downsweep :: HscEnv
          -> (GhcMessage -> AnyGhcDiagnostic)
          -> Maybe Messager
          -> [ModSummary]
          -- ^ Old summaries
          -> [ModuleName]       -- Ignore dependencies on these; treat
                                -- them as if they were package modules
          -> Bool               -- True <=> allow multiple targets to have
                                --          the same module name; this is
                                --          very useful for ghc -M
          -> IO ([DriverMessages], ModuleGraph)
                -- The non-error elements of the returned list all have distinct
                -- (Modules, IsBoot) identifiers, unless the Bool is true in
                -- which case there can be repeats
downsweep :: HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], ModuleGraph)
downsweep HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg [ModSummary]
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots = do
  WorkerLimit
n_jobs <- DynFlags -> IO WorkerLimit
mkWorkerLimit (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
  ([DriverMessages]
root_errs, [ModSummary]
root_summaries) <- WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> (HscEnv -> Target -> IO (Either DriverMessages ModSummary))
-> IO ([DriverMessages], [ModSummary])
rootSummariesParallel WorkerLimit
n_jobs HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg HscEnv -> Target -> IO (Either DriverMessages ModSummary)
summary
  let closure_errs :: [DriverMessages]
closure_errs = UnitEnv -> [DriverMessages]
checkHomeUnitsClosed UnitEnv
unit_env
      unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env

      all_errs :: [DriverMessages]
all_errs = [DriverMessages]
closure_errs [DriverMessages] -> [DriverMessages] -> [DriverMessages]
forall a. [a] -> [a] -> [a]
++ [DriverMessages]
root_errs

  case [DriverMessages]
all_errs of
    [] -> do
       ([DriverMessages]
downsweep_errs, [ModuleGraphNode]
downsweep_nodes) <- HscEnv
-> Map (UnitId, FilePath) ModSummary
-> [ModuleName]
-> Bool
-> DownsweepMode
-> [ModuleNodeInfo]
-> [UnitId]
-> IO ([DriverMessages], [ModuleGraphNode])
downsweepFromRootNodes HscEnv
hsc_env Map (UnitId, FilePath) ModSummary
old_summary_map [ModuleName]
excl_mods Bool
allow_dup_roots DownsweepMode
DownsweepUseCompile ((ModSummary -> ModuleNodeInfo) -> [ModSummary] -> [ModuleNodeInfo]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleNodeInfo
ModuleNodeCompile [ModSummary]
root_summaries) []

       let ([DriverMessages]
other_errs, [ModuleGraphNode]
unit_nodes) = [Either DriverMessages ModuleGraphNode]
-> ([DriverMessages], [ModuleGraphNode])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either DriverMessages ModuleGraphNode]
 -> ([DriverMessages], [ModuleGraphNode]))
-> [Either DriverMessages ModuleGraphNode]
-> ([DriverMessages], [ModuleGraphNode])
forall a b. (a -> b) -> a -> b
$ ([Either DriverMessages ModuleGraphNode]
 -> UnitId
 -> HomeUnitEnv
 -> [Either DriverMessages ModuleGraphNode])
-> [Either DriverMessages ModuleGraphNode]
-> UnitEnvGraph HomeUnitEnv
-> [Either DriverMessages ModuleGraphNode]
forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
HUG.unitEnv_foldWithKey (\[Either DriverMessages ModuleGraphNode]
nodes UnitId
uid HomeUnitEnv
hue -> [Either DriverMessages ModuleGraphNode]
nodes [Either DriverMessages ModuleGraphNode]
-> [Either DriverMessages ModuleGraphNode]
-> [Either DriverMessages ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
-> UnitId -> HomeUnitEnv -> [Either DriverMessages ModuleGraphNode]
unitModuleNodes [ModuleGraphNode]
downsweep_nodes UnitId
uid HomeUnitEnv
hue) [] (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env)

       let all_nodes :: [ModuleGraphNode]
all_nodes = [ModuleGraphNode]
downsweep_nodes [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
unit_nodes
       let all_errs :: [DriverMessages]
all_errs = [DriverMessages]
downsweep_errs [DriverMessages] -> [DriverMessages] -> [DriverMessages]
forall a. [a] -> [a] -> [a]
++ [DriverMessages]
other_errs

       let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
           tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
       -- if we have been passed -fno-code, we enable code generation
       -- for dependencies of modules that have -XTemplateHaskell,
       -- otherwise those modules will fail to compile.
       -- See Note [-fno-code mode] #8025
       ModuleGraph
th_configured_nodes <- Logger -> TmpFs -> UnitEnv -> [ModuleGraphNode] -> IO ModuleGraph
enableCodeGenForTH Logger
logger TmpFs
tmpfs UnitEnv
unit_env [ModuleGraphNode]
all_nodes

       return ([DriverMessages]
all_errs, ModuleGraph
th_configured_nodes)
    [DriverMessages]
_  -> ([DriverMessages], ModuleGraph)
-> IO ([DriverMessages], ModuleGraph)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DriverMessages]
all_errs, ModuleGraph
emptyMG)
  where
    summary :: HscEnv -> Target -> IO (Either DriverMessages ModSummary)
summary = [ModuleName]
-> Map (UnitId, FilePath) ModSummary
-> HscEnv
-> Target
-> IO (Either DriverMessages ModSummary)
getRootSummary [ModuleName]
excl_mods Map (UnitId, FilePath) ModSummary
old_summary_map

    -- A cache from file paths to the already summarised modules. The same file
    -- can be used in multiple units so the map is also keyed by which unit the
    -- file was used in.
    -- Reuse these if we can because the most expensive part of downsweep is
    -- reading the headers.
    old_summary_map :: M.Map (UnitId, FilePath) ModSummary
    old_summary_map :: Map (UnitId, FilePath) ModSummary
old_summary_map =
      [((UnitId, FilePath), ModSummary)]
-> Map (UnitId, FilePath) ModSummary
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((ModSummary -> UnitId
ms_unitid ModSummary
ms, ModSummary -> FilePath
msHsFilePath ModSummary
ms), ModSummary
ms) | ModSummary
ms <- [ModSummary]
old_summaries]

    -- Dependencies arising on a unit (backpack and module linking deps)
    unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]
    unitModuleNodes :: [ModuleGraphNode]
-> UnitId -> HomeUnitEnv -> [Either DriverMessages ModuleGraphNode]
unitModuleNodes [ModuleGraphNode]
summaries UnitId
uid HomeUnitEnv
hue =
      Maybe (Either DriverMessages ModuleGraphNode)
-> [Either DriverMessages ModuleGraphNode]
forall a. Maybe a -> [a]
maybeToList ([ModuleGraphNode]
-> UnitId
-> HomeUnitEnv
-> Maybe (Either DriverMessages ModuleGraphNode)
linkNodes [ModuleGraphNode]
summaries UnitId
uid HomeUnitEnv
hue)

-- | Calculate the module graph starting from a single ModSummary. The result is a
-- thunk, which when forced will perform the downsweep. This is useful in oneshot
-- mode where the module graph may never be needed.
-- If downsweep fails, then the resulting errors are just thrown.
downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph
downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph
downsweepThunk HscEnv
hsc_env ModSummary
mod_summary = IO ModuleGraph -> IO ModuleGraph
forall a. IO a -> IO a
unsafeInterleaveIO (IO ModuleGraph -> IO ModuleGraph)
-> IO ModuleGraph -> IO ModuleGraph
forall a b. (a -> b) -> a -> b
$ do
  Logger -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) Int
3 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Computing Module Graph thunk..."
  ~([DriverMessages]
errs, [ModuleGraphNode]
mg) <- HscEnv
-> Map (UnitId, FilePath) ModSummary
-> [ModuleName]
-> Bool
-> DownsweepMode
-> [ModuleNodeInfo]
-> [UnitId]
-> IO ([DriverMessages], [ModuleGraphNode])
downsweepFromRootNodes HscEnv
hsc_env Map (UnitId, FilePath) ModSummary
forall a. Monoid a => a
mempty [] Bool
True DownsweepMode
DownsweepUseFixed [ModSummary -> ModuleNodeInfo
ModuleNodeCompile ModSummary
mod_summary] []
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
                                   (DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags)
                                   (DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags)
                                   (DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage)
-> DriverMessages -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DriverMessages] -> DriverMessages
forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages [DriverMessages]
errs)
  return ([ModuleGraphNode] -> ModuleGraph
mkModuleGraph [ModuleGraphNode]
mg)

-- | Create a module graph from a list of installed modules.
-- This is used by the loader when we need to load modules but there
-- isn't already an existing module graph. For example, when loading plugins
-- during initialisation.
--
-- If you call this function, then if the `Module` you request to downsweep can't
-- be found then this function will throw errors.
-- If you need to use this function elsewhere, then it would make sense to make it
-- return [DriverMessages] and [ModuleGraph] so that the caller can handle the errors as it sees fit.
-- At the moment, it is overfitted for what `get_reachable_nodes` needs.
downsweepInstalledModules :: HscEnv -> [Module] -> IO ModuleGraph
downsweepInstalledModules :: HscEnv -> [Module] -> IO ModuleGraph
downsweepInstalledModules HscEnv
hsc_env [Module]
mods = do
    let
        ([Module]
home_mods, [Module]
external_mods) = (Module -> Bool) -> [Module] -> ([Module], [Module])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\Module
u -> Module -> UnitId
moduleUnitId Module
u UnitId -> Set UnitId -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env) [Module]
mods
        installed_mods :: [InstalledModule]
installed_mods = (Module -> InstalledModule) -> [Module] -> [InstalledModule]
forall a b. (a -> b) -> [a] -> [b]
map ((InstalledModule, Maybe InstantiatedModule) -> InstalledModule
forall a b. (a, b) -> a
fst ((InstalledModule, Maybe InstantiatedModule) -> InstalledModule)
-> (Module -> (InstalledModule, Maybe InstantiatedModule))
-> Module
-> InstalledModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> (InstalledModule, Maybe InstantiatedModule)
getModuleInstantiation) [Module]
home_mods
        external_uids :: [UnitId]
external_uids = (Module -> UnitId) -> [Module] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map Module -> UnitId
moduleUnitId [Module]
external_mods

        process :: InstalledModule -> IO ModuleNodeInfo
        process :: InstalledModule -> IO ModuleNodeInfo
process InstalledModule
i = do
          InstalledFindResult
res <- HscEnv
-> InstalledModule -> IsBootInterface -> IO InstalledFindResult
findExactModule HscEnv
hsc_env InstalledModule
i IsBootInterface
NotBoot
          case InstalledFindResult
res of
            InstalledFound ModLocation
loc -> ModuleNodeInfo -> IO ModuleNodeInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleNodeInfo -> IO ModuleNodeInfo)
-> ModuleNodeInfo -> IO ModuleNodeInfo
forall a b. (a -> b) -> a -> b
$ ModNodeKeyWithUid -> ModLocation -> ModuleNodeInfo
ModuleNodeFixed (InstalledModule -> ModNodeKeyWithUid
installedModuleToMnk InstalledModule
i) ModLocation
loc
            -- It is an internal-ish error if this happens, since we any call to this function should
            -- already know that we can find the modules we need to load.
            InstalledFindResult
_ -> GhcException -> IO ModuleNodeInfo
forall a. GhcException -> a
throwGhcException (GhcException -> IO ModuleNodeInfo)
-> GhcException -> IO ModuleNodeInfo
forall a b. (a -> b) -> a -> b
$ FilePath -> GhcException
ProgramError (FilePath -> GhcException) -> FilePath -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> FilePath
showSDoc (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) (SDoc -> FilePath) -> SDoc -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"downsweepInstalledModules: Could not find installed module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InstalledModule -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstalledModule
i

    [ModuleNodeInfo]
nodes <- (InstalledModule -> IO ModuleNodeInfo)
-> [InstalledModule] -> IO [ModuleNodeInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM InstalledModule -> IO ModuleNodeInfo
process [InstalledModule]
installed_mods
    ([DriverMessages]
errs, [ModuleGraphNode]
mg) <- HscEnv
-> Map (UnitId, FilePath) ModSummary
-> [ModuleName]
-> Bool
-> DownsweepMode
-> [ModuleNodeInfo]
-> [UnitId]
-> IO ([DriverMessages], [ModuleGraphNode])
downsweepFromRootNodes HscEnv
hsc_env Map (UnitId, FilePath) ModSummary
forall a. Monoid a => a
mempty [] Bool
True DownsweepMode
DownsweepUseFixed [ModuleNodeInfo]
nodes [UnitId]
external_uids

    -- Similarly here, we should really not get any errors, but print them out if we do.
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
                                     (DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags)
                                     (DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags)
                                     (DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage)
-> DriverMessages -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DriverMessages] -> DriverMessages
forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages [DriverMessages]
errs)

    return ([ModuleGraphNode] -> ModuleGraph
mkModuleGraph [ModuleGraphNode]
mg)



-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used
-- by --make mode, and fixed nodes by oneshot mode.
--
-- See Note [Module Types in the ModuleGraph] for the difference between the two.
data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed

-- | Perform downsweep, starting from the given root 'ModuleNodeInfo's and root
-- 'UnitId's.
-- This function will start at the given roots, and traverse downwards to find
-- all the dependencies, all the way to the leaf units.
downsweepFromRootNodes :: HscEnv
                  -> M.Map (UnitId, FilePath) ModSummary
                  -> [ModuleName]
                  -> Bool
                  -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies
                  -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo
                  -> [UnitId] -- ^ The starting units
                  -> IO ([DriverMessages], [ModuleGraphNode])
downsweepFromRootNodes :: HscEnv
-> Map (UnitId, FilePath) ModSummary
-> [ModuleName]
-> Bool
-> DownsweepMode
-> [ModuleNodeInfo]
-> [UnitId]
-> IO ([DriverMessages], [ModuleGraphNode])
downsweepFromRootNodes HscEnv
hsc_env Map (UnitId, FilePath) ModSummary
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots DownsweepMode
mode [ModuleNodeInfo]
root_nodes [UnitId]
root_uids
   = do
       let root_map :: DownsweepCache
root_map = [ModuleNodeInfo] -> DownsweepCache
mkRootMap [ModuleNodeInfo]
root_nodes
       DownsweepCache -> IO ()
checkDuplicates DownsweepCache
root_map
       (Map NodeKey ModuleGraphNode
module_deps, DownsweepCache
map0) <- [ModuleNodeInfo]
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopModuleNodeInfos [ModuleNodeInfo]
root_nodes (Map NodeKey ModuleGraphNode
forall k a. Map k a
M.empty, DownsweepCache
root_map)
       let all_deps :: Map NodeKey ModuleGraphNode
all_deps = HscEnv
-> Map NodeKey ModuleGraphNode
-> [UnitId]
-> Map NodeKey ModuleGraphNode
loopUnit HscEnv
hsc_env Map NodeKey ModuleGraphNode
module_deps [UnitId]
root_uids

       let all_instantiations :: [(UnitId, InstantiatedUnit)]
all_instantiations =  HscEnv -> [(UnitId, InstantiatedUnit)]
getHomeUnitInstantiations HscEnv
hsc_env
       let deps' :: Map NodeKey ModuleGraphNode
deps' = [(UnitId, InstantiatedUnit)]
-> Map NodeKey ModuleGraphNode -> Map NodeKey ModuleGraphNode
loopInstantiations [(UnitId, InstantiatedUnit)]
all_instantiations Map NodeKey ModuleGraphNode
all_deps

           downsweep_errs :: [DriverMessages]
downsweep_errs = [Either DriverMessages ModuleNodeInfo] -> [DriverMessages]
forall a b. [Either a b] -> [a]
lefts ([Either DriverMessages ModuleNodeInfo] -> [DriverMessages])
-> [Either DriverMessages ModuleNodeInfo] -> [DriverMessages]
forall a b. (a -> b) -> a -> b
$ [[Either DriverMessages ModuleNodeInfo]]
-> [Either DriverMessages ModuleNodeInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either DriverMessages ModuleNodeInfo]]
 -> [Either DriverMessages ModuleNodeInfo])
-> [[Either DriverMessages ModuleNodeInfo]]
-> [Either DriverMessages ModuleNodeInfo]
forall a b. (a -> b) -> a -> b
$ DownsweepCache -> [[Either DriverMessages ModuleNodeInfo]]
forall k a. Map k a -> [a]
M.elems DownsweepCache
map0
           downsweep_nodes :: [ModuleGraphNode]
downsweep_nodes = Map NodeKey ModuleGraphNode -> [ModuleGraphNode]
forall k a. Map k a -> [a]
M.elems Map NodeKey ModuleGraphNode
deps'

       return ([DriverMessages]
downsweep_errs, [ModuleGraphNode]
downsweep_nodes)
     where
        getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]
        getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]
getHomeUnitInstantiations HscEnv
hsc_env = ([(UnitId, InstantiatedUnit)]
 -> UnitId -> HomeUnitEnv -> [(UnitId, InstantiatedUnit)])
-> [(UnitId, InstantiatedUnit)]
-> UnitEnvGraph HomeUnitEnv
-> [(UnitId, InstantiatedUnit)]
forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
HUG.unitEnv_foldWithKey (\[(UnitId, InstantiatedUnit)]
nodes UnitId
uid HomeUnitEnv
hue -> [(UnitId, InstantiatedUnit)]
nodes [(UnitId, InstantiatedUnit)]
-> [(UnitId, InstantiatedUnit)] -> [(UnitId, InstantiatedUnit)]
forall a. [a] -> [a] -> [a]
++  UnitId -> UnitState -> [(UnitId, InstantiatedUnit)]
instantiationNodes UnitId
uid (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
hue)) [] (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env)


        calcDeps :: ModSummary
-> [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
calcDeps ModSummary
ms =
          -- Add a dependency on the HsBoot file if it exists
          -- This gets passed to the loopImports function which just ignores it if it
          -- can't be found.
          [(ModSummary -> UnitId
ms_unitid ModSummary
ms, PkgQual
NoPkgQual, Located ModuleName
-> IsBootInterface -> GenWithIsBoot (Located ModuleName)
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleName -> Located ModuleName
forall e. e -> Located e
noLoc (ModuleName -> Located ModuleName)
-> ModuleName -> Located ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
IsBoot) | IsBootInterface
NotBoot <- [ModSummary -> IsBootInterface
isBootSummary ModSummary
ms] ] [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
forall a. [a] -> [a] -> [a]
++
          [(ModSummary -> UnitId
ms_unitid ModSummary
ms, PkgQual
b, GenWithIsBoot (Located ModuleName)
c) | (PkgQual
b, GenWithIsBoot (Located ModuleName)
c) <- ModSummary -> [(PkgQual, GenWithIsBoot (Located ModuleName))]
msDeps ModSummary
ms ]

        -- In a root module, the filename is allowed to diverge from the module
        -- name, so we have to check that there aren't multiple root files
        -- defining the same module (otherwise the duplicates will be silently
        -- ignored, leading to confusing behaviour).
        checkDuplicates
          :: DownsweepCache
          -> IO ()
        checkDuplicates :: DownsweepCache -> IO ()
checkDuplicates DownsweepCache
root_map
           | Bool -> Bool
not Bool
allow_dup_roots
           , [ModuleNodeInfo]
dup_root:[[ModuleNodeInfo]]
_ <- [[ModuleNodeInfo]]
dup_roots = IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [ModuleNodeInfo] -> IO ()
multiRootsErr [ModuleNodeInfo]
dup_root
           | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
           where
             dup_roots :: [[ModuleNodeInfo]]        -- Each at least of length 2
             dup_roots :: [[ModuleNodeInfo]]
dup_roots = ([ModuleNodeInfo] -> Bool)
-> [[ModuleNodeInfo]] -> [[ModuleNodeInfo]]
forall a. (a -> Bool) -> [a] -> [a]
filterOut [ModuleNodeInfo] -> Bool
forall a. [a] -> Bool
isSingleton ([[ModuleNodeInfo]] -> [[ModuleNodeInfo]])
-> [[ModuleNodeInfo]] -> [[ModuleNodeInfo]]
forall a b. (a -> b) -> a -> b
$ ([Either DriverMessages ModuleNodeInfo] -> [ModuleNodeInfo])
-> [[Either DriverMessages ModuleNodeInfo]] -> [[ModuleNodeInfo]]
forall a b. (a -> b) -> [a] -> [b]
map [Either DriverMessages ModuleNodeInfo] -> [ModuleNodeInfo]
forall a b. [Either a b] -> [b]
rights (DownsweepCache -> [[Either DriverMessages ModuleNodeInfo]]
forall k a. Map k a -> [a]
M.elems DownsweepCache
root_map)

        loopInstantiations :: [(UnitId, InstantiatedUnit)]
                           -> M.Map NodeKey ModuleGraphNode
                           -> M.Map NodeKey ModuleGraphNode
        loopInstantiations :: [(UnitId, InstantiatedUnit)]
-> Map NodeKey ModuleGraphNode -> Map NodeKey ModuleGraphNode
loopInstantiations [] Map NodeKey ModuleGraphNode
done = Map NodeKey ModuleGraphNode
done
        loopInstantiations ((UnitId
home_uid, InstantiatedUnit
iud) :[(UnitId, InstantiatedUnit)]
xs) Map NodeKey ModuleGraphNode
done =
          let hsc_env' :: HscEnv
hsc_env' = HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit HscEnv
hsc_env
              done' :: Map NodeKey ModuleGraphNode
done' = HscEnv
-> Map NodeKey ModuleGraphNode
-> [UnitId]
-> Map NodeKey ModuleGraphNode
loopUnit HscEnv
hsc_env' Map NodeKey ModuleGraphNode
done [InstantiatedUnit -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf InstantiatedUnit
iud]
              payload :: ModuleGraphNode
payload = UnitId -> InstantiatedUnit -> ModuleGraphNode
InstantiationNode UnitId
home_uid InstantiatedUnit
iud
          in [(UnitId, InstantiatedUnit)]
-> Map NodeKey ModuleGraphNode -> Map NodeKey ModuleGraphNode
loopInstantiations [(UnitId, InstantiatedUnit)]
xs (NodeKey
-> ModuleGraphNode
-> Map NodeKey ModuleGraphNode
-> Map NodeKey ModuleGraphNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
payload) ModuleGraphNode
payload Map NodeKey ModuleGraphNode
done')

          where
            home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
home_uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)


        -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
        loopSummaries :: [ModSummary]
              -> (M.Map NodeKey ModuleGraphNode,
                    DownsweepCache)
              -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
        loopSummaries :: [ModSummary]
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopSummaries [] (Map NodeKey ModuleGraphNode, DownsweepCache)
done = (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map NodeKey ModuleGraphNode, DownsweepCache)
done
        loopSummaries (ModSummary
ms:[ModSummary]
next) (Map NodeKey ModuleGraphNode
done, DownsweepCache
summarised)
          | Just {} <- NodeKey -> Map NodeKey ModuleGraphNode -> Maybe ModuleGraphNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeKey
k Map NodeKey ModuleGraphNode
done
          = [ModSummary]
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopSummaries [ModSummary]
next (Map NodeKey ModuleGraphNode
done, DownsweepCache
summarised)
          -- Didn't work out what the imports mean yet, now do that.
          | Bool
otherwise = do
             ([NodeKey]
final_deps, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports (ModSummary
-> [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
calcDeps ModSummary
ms) Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
             -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
             ([NodeKey]
_, Map NodeKey ModuleGraphNode
done'', DownsweepCache
summarised'') <- [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports (Maybe (UnitId, PkgQual, GenWithIsBoot (Located ModuleName))
-> [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
forall a. Maybe a -> [a]
maybeToList Maybe (UnitId, PkgQual, GenWithIsBoot (Located ModuleName))
hs_file_for_boot) Map NodeKey ModuleGraphNode
done' DownsweepCache
summarised'
             [ModSummary]
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopSummaries [ModSummary]
next (NodeKey
-> ModuleGraphNode
-> Map NodeKey ModuleGraphNode
-> Map NodeKey ModuleGraphNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert NodeKey
k ([NodeKey] -> ModuleNodeInfo -> ModuleGraphNode
ModuleNode [NodeKey]
final_deps (ModSummary -> ModuleNodeInfo
ModuleNodeCompile ModSummary
ms)) Map NodeKey ModuleGraphNode
done'', DownsweepCache
summarised'')
          where
            k :: NodeKey
k = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms)

            hs_file_for_boot :: Maybe (UnitId, PkgQual, GenWithIsBoot (Located ModuleName))
hs_file_for_boot
              | HscSource
HsBootFile <- ModSummary -> HscSource
ms_hsc_src ModSummary
ms
              = (UnitId, PkgQual, GenWithIsBoot (Located ModuleName))
-> Maybe (UnitId, PkgQual, GenWithIsBoot (Located ModuleName))
forall a. a -> Maybe a
Just ((UnitId, PkgQual, GenWithIsBoot (Located ModuleName))
 -> Maybe (UnitId, PkgQual, GenWithIsBoot (Located ModuleName)))
-> (UnitId, PkgQual, GenWithIsBoot (Located ModuleName))
-> Maybe (UnitId, PkgQual, GenWithIsBoot (Located ModuleName))
forall a b. (a -> b) -> a -> b
$ ((ModSummary -> UnitId
ms_unitid ModSummary
ms), PkgQual
NoPkgQual, (Located ModuleName
-> IsBootInterface -> GenWithIsBoot (Located ModuleName)
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleName -> Located ModuleName
forall e. e -> Located e
noLoc (ModuleName -> Located ModuleName)
-> ModuleName -> Located ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
NotBoot))
              | Bool
otherwise
              = Maybe (UnitId, PkgQual, GenWithIsBoot (Located ModuleName))
forall a. Maybe a
Nothing

        loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache)
        loopModuleNodeInfos :: [ModuleNodeInfo]
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopModuleNodeInfos [ModuleNodeInfo]
is (Map NodeKey ModuleGraphNode, DownsweepCache)
cache = ((Map NodeKey ModuleGraphNode, DownsweepCache)
 -> ModuleNodeInfo
 -> IO (Map NodeKey ModuleGraphNode, DownsweepCache))
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> [ModuleNodeInfo]
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((ModuleNodeInfo
 -> (Map NodeKey ModuleGraphNode, DownsweepCache)
 -> IO (Map NodeKey ModuleGraphNode, DownsweepCache))
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> ModuleNodeInfo
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleNodeInfo
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopModuleNodeInfo) (Map NodeKey ModuleGraphNode, DownsweepCache)
cache [ModuleNodeInfo]
is

        loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache)
        loopModuleNodeInfo :: ModuleNodeInfo
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopModuleNodeInfo ModuleNodeInfo
mod_node_info (Map NodeKey ModuleGraphNode
done, DownsweepCache
summarised) = do
          case ModuleNodeInfo
mod_node_info of
            ModuleNodeCompile ModSummary
ms -> do
              [ModSummary]
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopSummaries [ModSummary
ms] (Map NodeKey ModuleGraphNode
done, DownsweepCache
summarised)
            ModuleNodeFixed ModNodeKeyWithUid
mod ModLocation
ml -> do
              Map NodeKey ModuleGraphNode
done' <- ModNodeKeyWithUid
-> ModLocation
-> Map NodeKey ModuleGraphNode
-> IO (Map NodeKey ModuleGraphNode)
loopFixedModule ModNodeKeyWithUid
mod ModLocation
ml Map NodeKey ModuleGraphNode
done
              return (Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised)

        -- NB: loopFixedModule does not take a downsweep cache, because if you
        -- ever reach a Fixed node, everything under that also must be fixed.
        loopFixedModule :: ModNodeKeyWithUid -> ModLocation
                        -> M.Map NodeKey ModuleGraphNode
                        -> IO (M.Map NodeKey ModuleGraphNode)
        loopFixedModule :: ModNodeKeyWithUid
-> ModLocation
-> Map NodeKey ModuleGraphNode
-> IO (Map NodeKey ModuleGraphNode)
loopFixedModule ModNodeKeyWithUid
key ModLocation
loc Map NodeKey ModuleGraphNode
done = do
          let nk :: NodeKey
nk = ModNodeKeyWithUid -> NodeKey
NodeKey_Module ModNodeKeyWithUid
key
          case NodeKey -> Map NodeKey ModuleGraphNode -> Maybe ModuleGraphNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeKey
nk Map NodeKey ModuleGraphNode
done of
            Just {} -> Map NodeKey ModuleGraphNode -> IO (Map NodeKey ModuleGraphNode)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map NodeKey ModuleGraphNode
done
            Maybe ModuleGraphNode
Nothing -> do
              -- MP: TODO, we should just read the dependency info from the interface rather than either
              -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
              -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
              MaybeErr ReadInterfaceError ModIface
read_result <-
                -- 1. Check if the interface is already loaded into the EPS by some other
                -- part of the compiler.
                HscEnv -> Module -> IO (Maybe ModIface)
lookupIfaceByModuleHsc HscEnv
hsc_env (ModNodeKeyWithUid -> Module
mnkToModule ModNodeKeyWithUid
key) IO (Maybe ModIface)
-> (Maybe ModIface -> IO (MaybeErr ReadInterfaceError ModIface))
-> IO (MaybeErr ReadInterfaceError ModIface)
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 ModIface
iface -> MaybeErr ReadInterfaceError ModIface
-> IO (MaybeErr ReadInterfaceError ModIface)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface -> MaybeErr ReadInterfaceError ModIface
forall err val. val -> MaybeErr err val
M.Succeeded ModIface
iface)
                  Maybe ModIface
Nothing -> Logger
-> DynFlags
-> NameCache
-> Module
-> FilePath
-> IO (MaybeErr ReadInterfaceError ModIface)
readIface (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) (HscEnv -> NameCache
hsc_NC HscEnv
hsc_env) (ModNodeKeyWithUid -> Module
mnkToModule ModNodeKeyWithUid
key) (ModLocation -> FilePath
ml_hi_file ModLocation
loc)
              case MaybeErr ReadInterfaceError ModIface
read_result of
                M.Succeeded ModIface
iface -> do
                  -- Computer information about this node
                  let node_deps :: [Either ModNodeKeyWithUid UnitId]
node_deps = Dependencies -> [Either ModNodeKeyWithUid UnitId]
ifaceDeps (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface)
                      edges :: [NodeKey]
edges = (Either ModNodeKeyWithUid UnitId -> NodeKey)
-> [Either ModNodeKeyWithUid UnitId] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map ((ModNodeKeyWithUid -> NodeKey)
-> (UnitId -> NodeKey)
-> Either ModNodeKeyWithUid UnitId
-> NodeKey
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ModNodeKeyWithUid -> NodeKey
NodeKey_Module UnitId -> NodeKey
NodeKey_ExternalUnit) [Either ModNodeKeyWithUid UnitId]
node_deps
                      node :: ModuleGraphNode
node = [NodeKey] -> ModuleNodeInfo -> ModuleGraphNode
ModuleNode [NodeKey]
edges (ModNodeKeyWithUid -> ModLocation -> ModuleNodeInfo
ModuleNodeFixed ModNodeKeyWithUid
key ModLocation
loc)
                  (Map NodeKey ModuleGraphNode
 -> Either ModNodeKeyWithUid UnitId
 -> IO (Map NodeKey ModuleGraphNode))
-> Map NodeKey ModuleGraphNode
-> [Either ModNodeKeyWithUid UnitId]
-> IO (Map NodeKey ModuleGraphNode)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (UnitId
-> Map NodeKey ModuleGraphNode
-> Either ModNodeKeyWithUid UnitId
-> IO (Map NodeKey ModuleGraphNode)
loopFixedNodeKey (ModNodeKeyWithUid -> UnitId
mnkUnitId ModNodeKeyWithUid
key)) (NodeKey
-> ModuleGraphNode
-> Map NodeKey ModuleGraphNode
-> Map NodeKey ModuleGraphNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert NodeKey
nk ModuleGraphNode
node Map NodeKey ModuleGraphNode
done) [Either ModNodeKeyWithUid UnitId]
node_deps
                -- Ignore any failure, we might try to read a .hi-boot file for
                -- example, even if there is not one.
                M.Failed {} ->
                  Map NodeKey ModuleGraphNode -> IO (Map NodeKey ModuleGraphNode)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map NodeKey ModuleGraphNode
done

        loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> IO (M.Map NodeKey ModuleGraphNode)
        loopFixedNodeKey :: UnitId
-> Map NodeKey ModuleGraphNode
-> Either ModNodeKeyWithUid UnitId
-> IO (Map NodeKey ModuleGraphNode)
loopFixedNodeKey UnitId
_ Map NodeKey ModuleGraphNode
done (Left ModNodeKeyWithUid
key) = do
          [ModNodeKeyWithUid]
-> Map NodeKey ModuleGraphNode -> IO (Map NodeKey ModuleGraphNode)
loopFixedImports [ModNodeKeyWithUid
key] Map NodeKey ModuleGraphNode
done
        loopFixedNodeKey UnitId
home_uid Map NodeKey ModuleGraphNode
done (Right UnitId
uid) = do
          -- Set active unit so that looking loopUnit finds the correct
          -- -package flags in the unit state.
          let hsc_env' :: HscEnv
hsc_env' = HasDebugCallStack => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId UnitId
home_uid HscEnv
hsc_env
          Map NodeKey ModuleGraphNode -> IO (Map NodeKey ModuleGraphNode)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Map NodeKey ModuleGraphNode -> IO (Map NodeKey ModuleGraphNode))
-> Map NodeKey ModuleGraphNode -> IO (Map NodeKey ModuleGraphNode)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Map NodeKey ModuleGraphNode
-> [UnitId]
-> Map NodeKey ModuleGraphNode
loopUnit HscEnv
hsc_env' Map NodeKey ModuleGraphNode
done [UnitId
uid]


        ifaceDeps :: Dependencies -> [Either ModNodeKeyWithUid UnitId]
        ifaceDeps :: Dependencies -> [Either ModNodeKeyWithUid UnitId]
ifaceDeps Dependencies
deps =
          [ ModNodeKeyWithUid -> Either ModNodeKeyWithUid UnitId
forall a b. a -> Either a b
Left (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid ModuleNameWithIsBoot
dep UnitId
uid)
          | (UnitId
uid, ModuleNameWithIsBoot
dep) <- Set (UnitId, ModuleNameWithIsBoot)
-> [(UnitId, ModuleNameWithIsBoot)]
forall a. Set a -> [a]
Set.toList (Dependencies -> Set (UnitId, ModuleNameWithIsBoot)
dep_direct_mods Dependencies
deps)
          ] [Either ModNodeKeyWithUid UnitId]
-> [Either ModNodeKeyWithUid UnitId]
-> [Either ModNodeKeyWithUid UnitId]
forall a. [a] -> [a] -> [a]
++
          [ UnitId -> Either ModNodeKeyWithUid UnitId
forall a b. b -> Either a b
Right UnitId
uid
          | UnitId
uid <- Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList (Dependencies -> Set UnitId
dep_direct_pkgs Dependencies
deps)
          ]

        -- Like loopImports, but we already know exactly which module we are looking for.
        loopFixedImports :: [ModNodeKeyWithUid]
                         -> M.Map NodeKey ModuleGraphNode
                         -> IO (M.Map NodeKey ModuleGraphNode)
        loopFixedImports :: [ModNodeKeyWithUid]
-> Map NodeKey ModuleGraphNode -> IO (Map NodeKey ModuleGraphNode)
loopFixedImports [] Map NodeKey ModuleGraphNode
done = Map NodeKey ModuleGraphNode -> IO (Map NodeKey ModuleGraphNode)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map NodeKey ModuleGraphNode
done
        loopFixedImports (ModNodeKeyWithUid
key:[ModNodeKeyWithUid]
keys) Map NodeKey ModuleGraphNode
done = do
          let nk :: NodeKey
nk = ModNodeKeyWithUid -> NodeKey
NodeKey_Module ModNodeKeyWithUid
key
          case NodeKey -> Map NodeKey ModuleGraphNode -> Maybe ModuleGraphNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeKey
nk Map NodeKey ModuleGraphNode
done of
            Just {} -> [ModNodeKeyWithUid]
-> Map NodeKey ModuleGraphNode -> IO (Map NodeKey ModuleGraphNode)
loopFixedImports [ModNodeKeyWithUid]
keys Map NodeKey ModuleGraphNode
done
            Maybe ModuleGraphNode
Nothing -> do
              InstalledFindResult
read_result <- HscEnv
-> InstalledModule -> IsBootInterface -> IO InstalledFindResult
findExactModule HscEnv
hsc_env (ModNodeKeyWithUid -> InstalledModule
mnkToInstalledModule ModNodeKeyWithUid
key) (ModNodeKeyWithUid -> IsBootInterface
mnkIsBoot ModNodeKeyWithUid
key)
              case InstalledFindResult
read_result of
                InstalledFound ModLocation
loc -> do
                  Map NodeKey ModuleGraphNode
done' <- ModNodeKeyWithUid
-> ModLocation
-> Map NodeKey ModuleGraphNode
-> IO (Map NodeKey ModuleGraphNode)
loopFixedModule ModNodeKeyWithUid
key ModLocation
loc Map NodeKey ModuleGraphNode
done
                  [ModNodeKeyWithUid]
-> Map NodeKey ModuleGraphNode -> IO (Map NodeKey ModuleGraphNode)
loopFixedImports [ModNodeKeyWithUid]
keys Map NodeKey ModuleGraphNode
done'
                InstalledFindResult
_otherwise ->
                  -- If the finder fails, just keep going, there will be another
                  -- error later.
                  [ModNodeKeyWithUid]
-> Map NodeKey ModuleGraphNode -> IO (Map NodeKey ModuleGraphNode)
loopFixedImports [ModNodeKeyWithUid]
keys Map NodeKey ModuleGraphNode
done

        downsweepSummarise :: HscEnv
                           -> HomeUnit
                           -> M.Map (UnitId, FilePath) ModSummary
                           -> IsBootInterface
                           -> Located ModuleName
                           -> PkgQual
                           -> Maybe (StringBuffer, UTCTime)
                           -> [ModuleName]
                           -> IO SummariseResult
        downsweepSummarise :: HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
downsweepSummarise HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summaries IsBootInterface
is_boot Located ModuleName
wanted_mod PkgQual
mb_pkg Maybe (StringBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods =
          case DownsweepMode
mode of
            DownsweepMode
DownsweepUseCompile -> HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summaries IsBootInterface
is_boot Located ModuleName
wanted_mod PkgQual
mb_pkg Maybe (StringBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
            DownsweepMode
DownsweepUseFixed -> HscEnv
-> HomeUnit
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> [ModuleName]
-> IO SummariseResult
summariseModuleInterface HscEnv
hsc_env HomeUnit
home_unit IsBootInterface
is_boot Located ModuleName
wanted_mod PkgQual
mb_pkg [ModuleName]
excl_mods


        -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover
        -- a new module by doing this.
        loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
                        -- Work list: process these modules
             -> M.Map NodeKey ModuleGraphNode
             -> DownsweepCache
                        -- Visited set; the range is a list because
                        -- the roots can have the same module names
                        -- if allow_dup_roots is True
             -> IO ([NodeKey],
                  M.Map NodeKey ModuleGraphNode, DownsweepCache)
                        -- The result is the completed NodeMap
        loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [] Map NodeKey ModuleGraphNode
done DownsweepCache
summarised = ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Map NodeKey ModuleGraphNode
done, DownsweepCache
summarised)
        loopImports ((UnitId
home_uid,PkgQual
mb_pkg, GenWithIsBoot (Located ModuleName)
gwib) : [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
ss) Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
          | Just [Either DriverMessages ModuleNodeInfo]
summs <- (UnitId, PkgQual, ModuleNameWithIsBoot)
-> DownsweepCache -> Maybe [Either DriverMessages ModuleNodeInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key DownsweepCache
summarised
          = case [Either DriverMessages ModuleNodeInfo]
summs of
              [Right ModuleNodeInfo
ms] -> do
                let nk :: NodeKey
nk = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNodeInfo -> ModNodeKeyWithUid
mnKey ModuleNodeInfo
ms)
                ([NodeKey]
rest, Map NodeKey ModuleGraphNode
summarised', DownsweepCache
done') <- [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
                ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeKey
nkNodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
: [NodeKey]
rest, Map NodeKey ModuleGraphNode
summarised', DownsweepCache
done')
              [Left DriverMessages
_err] ->
                [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
              [Either DriverMessages ModuleNodeInfo]
_errs ->  do
                [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
          | Bool
otherwise
          = do
               SummariseResult
mb_s <- HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
downsweepSummarise HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summaries
                                       IsBootInterface
is_boot Located ModuleName
wanted_mod PkgQual
mb_pkg
                                       Maybe (StringBuffer, UTCTime)
forall a. Maybe a
Nothing [ModuleName]
excl_mods
               case SummariseResult
mb_s of
                   SummariseResult
NotThere -> [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
                   External UnitId
uid -> do
                    -- Pass an updated hsc_env to loopUnit, as each unit might
                    -- have a different visible package database.
                    let hsc_env' :: HscEnv
hsc_env' = HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit HscEnv
hsc_env
                    let done' :: Map NodeKey ModuleGraphNode
done' = HscEnv
-> Map NodeKey ModuleGraphNode
-> [UnitId]
-> Map NodeKey ModuleGraphNode
loopUnit HscEnv
hsc_env' Map NodeKey ModuleGraphNode
done [UnitId
uid]
                    ([NodeKey]
other_deps, Map NodeKey ModuleGraphNode
done'', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
ss Map NodeKey ModuleGraphNode
done' DownsweepCache
summarised
                    ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId -> NodeKey
NodeKey_ExternalUnit UnitId
uid NodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
: [NodeKey]
other_deps, Map NodeKey ModuleGraphNode
done'', DownsweepCache
summarised')
                   FoundInstantiation InstantiatedUnit
iud -> do
                    ([NodeKey]
other_deps, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
                    ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
iud NodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
: [NodeKey]
other_deps, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised')
                   FoundHomeWithError (UnitId
_uid, DriverMessages
e) ->  [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
ss Map NodeKey ModuleGraphNode
done ((UnitId, PkgQual, ModuleNameWithIsBoot)
-> [Either DriverMessages ModuleNodeInfo]
-> DownsweepCache
-> DownsweepCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key [(DriverMessages -> Either DriverMessages ModuleNodeInfo
forall a b. a -> Either a b
Left DriverMessages
e)] DownsweepCache
summarised)
                   FoundHome ModuleNodeInfo
s -> do
                     (Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <-
                       ModuleNodeInfo
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopModuleNodeInfo ModuleNodeInfo
s (Map NodeKey ModuleGraphNode
done, (UnitId, PkgQual, ModuleNameWithIsBoot)
-> [Either DriverMessages ModuleNodeInfo]
-> DownsweepCache
-> DownsweepCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key [ModuleNodeInfo -> Either DriverMessages ModuleNodeInfo
forall a b. b -> Either a b
Right ModuleNodeInfo
s] DownsweepCache
summarised)
                     ([NodeKey]
other_deps, Map NodeKey ModuleGraphNode
final_done, DownsweepCache
final_summarised) <- [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
ss Map NodeKey ModuleGraphNode
done' DownsweepCache
summarised'

                     -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
                     ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNodeInfo -> ModNodeKeyWithUid
mnKey ModuleNodeInfo
s) NodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
: [NodeKey]
other_deps, Map NodeKey ModuleGraphNode
final_done, DownsweepCache
final_summarised)
          where
            cache_key :: (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key = (UnitId
home_uid, PkgQual
mb_pkg, Located ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (Located ModuleName -> ModuleName)
-> GenWithIsBoot (Located ModuleName) -> ModuleNameWithIsBoot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenWithIsBoot (Located ModuleName)
gwib)
            home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
home_uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
            GWIB { gwib_mod :: forall mod. GenWithIsBoot mod -> mod
gwib_mod = L SrcSpan
loc ModuleName
mod, gwib_isBoot :: forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot = IsBootInterface
is_boot } = GenWithIsBoot (Located ModuleName)
gwib
            wanted_mod :: Located ModuleName
wanted_mod = SrcSpan -> ModuleName -> Located ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc ModuleName
mod

        loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
        loopUnit :: HscEnv
-> Map NodeKey ModuleGraphNode
-> [UnitId]
-> Map NodeKey ModuleGraphNode
loopUnit HscEnv
_ Map NodeKey ModuleGraphNode
cache [] = Map NodeKey ModuleGraphNode
cache
        loopUnit HscEnv
lcl_hsc_env Map NodeKey ModuleGraphNode
cache (UnitId
u:[UnitId]
uxs) = do
           let nk :: NodeKey
nk = (UnitId -> NodeKey
NodeKey_ExternalUnit UnitId
u)
           case NodeKey -> Map NodeKey ModuleGraphNode -> Maybe ModuleGraphNode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeKey
nk Map NodeKey ModuleGraphNode
cache of
             Just {} -> HscEnv
-> Map NodeKey ModuleGraphNode
-> [UnitId]
-> Map NodeKey ModuleGraphNode
loopUnit HscEnv
lcl_hsc_env Map NodeKey ModuleGraphNode
cache [UnitId]
uxs
             Maybe ModuleGraphNode
Nothing -> case GenericUnitInfo PackageId PackageName UnitId ModuleName Module
-> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends (GenericUnitInfo PackageId PackageName UnitId ModuleName Module
 -> [UnitId])
-> Maybe
     (GenericUnitInfo PackageId PackageName UnitId ModuleName Module)
-> Maybe [UnitId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitState
-> UnitId
-> Maybe
     (GenericUnitInfo PackageId PackageName UnitId ModuleName Module)
lookupUnitId (HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
lcl_hsc_env) UnitId
u of
                         Just [UnitId]
us -> HscEnv
-> Map NodeKey ModuleGraphNode
-> [UnitId]
-> Map NodeKey ModuleGraphNode
loopUnit HscEnv
lcl_hsc_env (HscEnv
-> Map NodeKey ModuleGraphNode
-> [UnitId]
-> Map NodeKey ModuleGraphNode
loopUnit HscEnv
lcl_hsc_env (NodeKey
-> ModuleGraphNode
-> Map NodeKey ModuleGraphNode
-> Map NodeKey ModuleGraphNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NodeKey
nk ([UnitId] -> UnitId -> ModuleGraphNode
UnitNode [UnitId]
us UnitId
u) Map NodeKey ModuleGraphNode
cache) [UnitId]
us) [UnitId]
uxs
                         Maybe [UnitId]
Nothing -> FilePath -> SDoc -> Map NodeKey ModuleGraphNode
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"loopUnit" (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Malformed package database, missing " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
u)

multiRootsErr :: [ModuleNodeInfo] -> IO ()
multiRootsErr :: [ModuleNodeInfo] -> IO ()
multiRootsErr [] = FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
panic FilePath
"multiRootsErr"
multiRootsErr summs :: [ModuleNodeInfo]
summs@(ModuleNodeInfo
summ1:[ModuleNodeInfo]
_)
  = MsgEnvelope GhcMessage -> IO ()
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO ())
-> MsgEnvelope GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ (DriverMessage -> GhcMessage)
-> MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage (MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage)
-> MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
    SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ Module -> [FilePath] -> DriverMessage
DriverDuplicatedModuleDeclaration Module
mod [FilePath]
files
  where
    mod :: Module
mod = ModuleNodeInfo -> Module
moduleNodeInfoModule ModuleNodeInfo
summ1
    files :: [FilePath]
files = (ModuleNodeInfo -> Maybe FilePath)
-> [ModuleNodeInfo] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ModLocation -> Maybe FilePath
ml_hs_file (ModLocation -> Maybe FilePath)
-> (ModuleNodeInfo -> ModLocation)
-> ModuleNodeInfo
-> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNodeInfo -> ModLocation
moduleNodeInfoLocation) [ModuleNodeInfo]
summs

moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages
moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages
moduleNotFoundErr UnitId
uid ModuleName
mod = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (UnitId -> ModuleName -> DriverMessage
DriverModuleNotFound UnitId
uid ModuleName
mod)

-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.
-- These are used to represent the type checking that is done after
-- all the free holes (sigs in current package) relevant to that instantiation
-- are compiled. This is necessary to catch some instantiation errors.
instantiationNodes :: UnitId -> UnitState -> [(UnitId, InstantiatedUnit)]
instantiationNodes :: UnitId -> UnitState -> [(UnitId, InstantiatedUnit)]
instantiationNodes UnitId
uid UnitState
unit_state = (InstantiatedUnit -> (UnitId, InstantiatedUnit))
-> [InstantiatedUnit] -> [(UnitId, InstantiatedUnit)]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId
uid,) [InstantiatedUnit]
iuids_to_check
  where
    iuids_to_check :: [InstantiatedUnit]
    iuids_to_check :: [InstantiatedUnit]
iuids_to_check =
      [InstantiatedUnit] -> [InstantiatedUnit]
forall a. Ord a => [a] -> [a]
nubSort ([InstantiatedUnit] -> [InstantiatedUnit])
-> [InstantiatedUnit] -> [InstantiatedUnit]
forall a b. (a -> b) -> a -> b
$ ((GenUnit UnitId, Maybe PackageArg) -> [InstantiatedUnit])
-> [(GenUnit UnitId, Maybe PackageArg)] -> [InstantiatedUnit]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GenUnit UnitId -> [InstantiatedUnit]
forall {unit}. GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId (GenUnit UnitId -> [InstantiatedUnit])
-> ((GenUnit UnitId, Maybe PackageArg) -> GenUnit UnitId)
-> (GenUnit UnitId, Maybe PackageArg)
-> [InstantiatedUnit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenUnit UnitId, Maybe PackageArg) -> GenUnit UnitId
forall a b. (a, b) -> a
fst) (UnitState -> [(GenUnit UnitId, Maybe PackageArg)]
explicitUnits UnitState
unit_state)
     where
      goUnitId :: GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId GenUnit unit
uid =
        [ GenInstantiatedUnit unit
recur
        | VirtUnit GenInstantiatedUnit unit
indef <- [GenUnit unit
uid]
        , (ModuleName, GenModule (GenUnit unit))
inst <- GenInstantiatedUnit unit -> GenInstantiations unit
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit unit
indef
        , GenInstantiatedUnit unit
recur <- (GenInstantiatedUnit unit
indef GenInstantiatedUnit unit
-> [GenInstantiatedUnit unit] -> [GenInstantiatedUnit unit]
forall a. a -> [a] -> [a]
:) ([GenInstantiatedUnit unit] -> [GenInstantiatedUnit unit])
-> [GenInstantiatedUnit unit] -> [GenInstantiatedUnit unit]
forall a b. (a -> b) -> a -> b
$ GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId (GenUnit unit -> [GenInstantiatedUnit unit])
-> GenUnit unit -> [GenInstantiatedUnit unit]
forall a b. (a -> b) -> a -> b
$ GenModule (GenUnit unit) -> GenUnit unit
forall unit. GenModule unit -> unit
moduleUnit (GenModule (GenUnit unit) -> GenUnit unit)
-> GenModule (GenUnit unit) -> GenUnit unit
forall a b. (a -> b) -> a -> b
$ (ModuleName, GenModule (GenUnit unit)) -> GenModule (GenUnit unit)
forall a b. (a, b) -> b
snd (ModuleName, GenModule (GenUnit unit))
inst
        ]

-- The linking plan for each module. If we need to do linking for a home unit
-- then this function returns a graph node which depends on all the modules in the home unit.

-- At the moment nothing can depend on these LinkNodes.
linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
linkNodes :: [ModuleGraphNode]
-> UnitId
-> HomeUnitEnv
-> Maybe (Either DriverMessages ModuleGraphNode)
linkNodes [ModuleGraphNode]
summaries UnitId
uid HomeUnitEnv
hue =
  let dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue
      ofile :: Maybe FilePath
ofile = DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags

      unit_nodes :: [NodeKey]
      unit_nodes :: [NodeKey]
unit_nodes = (ModuleGraphNode -> NodeKey) -> [ModuleGraphNode] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey ((ModuleGraphNode -> Bool) -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
uid) (UnitId -> Bool)
-> (ModuleGraphNode -> UnitId) -> ModuleGraphNode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraphNode -> UnitId
mgNodeUnitId) [ModuleGraphNode]
summaries)
  -- Issue a warning for the confusing case where the user
  -- said '-o foo' but we're not going to do any linking.
  -- We attempt linking if either (a) one of the modules is
  -- called Main, or (b) the user said -no-hs-main, indicating
  -- that main() is going to come from somewhere else.
  --
      no_hs_main :: Bool
no_hs_main = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags

      main_sum :: Bool
main_sum = (NodeKey -> Bool) -> [NodeKey] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (NodeKey -> NodeKey -> Bool
forall a. Eq a => a -> a -> Bool
== ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (DynFlags -> ModuleName
mainModuleNameIs DynFlags
dflags) IsBootInterface
NotBoot) UnitId
uid)) [NodeKey]
unit_nodes

      do_linking :: Bool
do_linking =  Bool
main_sum Bool -> Bool -> Bool
|| Bool
no_hs_main Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkDynLib Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkStaticLib

  in if | DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkBinary Bool -> Bool -> Bool
&& Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust Maybe FilePath
ofile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
do_linking ->
            Either DriverMessages ModuleGraphNode
-> Maybe (Either DriverMessages ModuleGraphNode)
forall a. a -> Maybe a
Just (DriverMessages -> Either DriverMessages ModuleGraphNode
forall a b. a -> Either a b
Left (DriverMessages -> Either DriverMessages ModuleGraphNode)
-> DriverMessages -> Either DriverMessages ModuleGraphNode
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (ModuleName -> DriverMessage
DriverRedirectedNoMain (ModuleName -> DriverMessage) -> ModuleName -> DriverMessage
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName
mainModuleNameIs DynFlags
dflags))
        -- This should be an error, not a warning (#10895).
        | DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
/= GhcLink
NoLink, Bool
do_linking -> Either DriverMessages ModuleGraphNode
-> Maybe (Either DriverMessages ModuleGraphNode)
forall a. a -> Maybe a
Just (ModuleGraphNode -> Either DriverMessages ModuleGraphNode
forall a b. b -> Either a b
Right ([NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
unit_nodes UnitId
uid))
        | Bool
otherwise  -> Maybe (Either DriverMessages ModuleGraphNode)
forall a. Maybe a
Nothing

getRootSummary ::
  [ModuleName] ->
  M.Map (UnitId, FilePath) ModSummary ->
  HscEnv ->
  Target ->
  IO (Either DriverMessages ModSummary)
getRootSummary :: [ModuleName]
-> Map (UnitId, FilePath) ModSummary
-> HscEnv
-> Target
-> IO (Either DriverMessages ModSummary)
getRootSummary [ModuleName]
excl_mods Map (UnitId, FilePath) ModSummary
old_summary_map HscEnv
hsc_env Target
target
  | TargetFile FilePath
file Maybe Phase
mb_phase <- TargetId
targetId
  = do
    let offset_file :: FilePath
offset_file = DynFlags -> FilePath -> FilePath
augmentByWorkingDirectory DynFlags
dflags FilePath
file
    Bool
exists <- IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
offset_file
    if Bool
exists Bool -> Bool -> Bool
|| Maybe (StringBuffer, UTCTime) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (StringBuffer, UTCTime)
maybe_buf
    then HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer, UTCTime)
-> IO (Either DriverMessages ModSummary)
summariseFile HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map FilePath
offset_file Maybe Phase
mb_phase
         Maybe (StringBuffer, UTCTime)
maybe_buf
    else
      Either DriverMessages ModSummary
-> IO (Either DriverMessages ModSummary)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DriverMessages ModSummary
 -> IO (Either DriverMessages ModSummary))
-> Either DriverMessages ModSummary
-> IO (Either DriverMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ DriverMessages -> Either DriverMessages ModSummary
forall a b. a -> Either a b
Left (DriverMessages -> Either DriverMessages ModSummary)
-> DriverMessages -> Either DriverMessages ModSummary
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (FilePath -> DriverMessage
DriverFileNotFound FilePath
offset_file)
  | TargetModule ModuleName
modl <- TargetId
targetId
  = do
    SummariseResult
maybe_summary <- HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map IsBootInterface
NotBoot
                     (SrcSpan -> ModuleName -> Located ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
rootLoc ModuleName
modl) (UnitId -> PkgQual
ThisPkg (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit))
                     Maybe (StringBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
    pure case SummariseResult
maybe_summary of
      FoundHome (ModuleNodeCompile ModSummary
s)  -> ModSummary -> Either DriverMessages ModSummary
forall a b. b -> Either a b
Right ModSummary
s
      FoundHomeWithError (UnitId, DriverMessages)
err -> DriverMessages -> Either DriverMessages ModSummary
forall a b. a -> Either a b
Left ((UnitId, DriverMessages) -> DriverMessages
forall a b. (a, b) -> b
snd (UnitId, DriverMessages)
err)
      SummariseResult
_ -> DriverMessages -> Either DriverMessages ModSummary
forall a b. a -> Either a b
Left (UnitId -> ModuleName -> DriverMessages
moduleNotFoundErr UnitId
uid ModuleName
modl)
    where
      Target {TargetId
targetId :: TargetId
targetId :: Target -> TargetId
targetId, targetContents :: Target -> Maybe (StringBuffer, UTCTime)
targetContents = Maybe (StringBuffer, UTCTime)
maybe_buf, targetUnitId :: Target -> UnitId
targetUnitId = UnitId
uid} = Target
target
      home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
      rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"<command line>")
      dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags (HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv
UnitId -> UnitEnv -> HomeUnitEnv
ue_findHomeUnitEnv UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env))

-- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline
-- system.
-- Create bundles of 'Target's wrapped in a 'MakeAction' that uses
-- 'withAbstractSem' to wait for a free slot, limiting the number of
-- concurrently computed summaries to the value of the @-j@ option or the slots
-- allocated by the job server, if that is used.
--
-- The 'MakeAction' returns 'Maybe', which is not handled as an error, because
-- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the
-- result won't be read anyway here.
--
-- To emulate the current behavior, we funnel exceptions past the concurrency
-- barrier and rethrow the first one afterwards.
rootSummariesParallel ::
  WorkerLimit ->
  HscEnv ->
  (GhcMessage -> AnyGhcDiagnostic) ->
  Maybe Messager ->
  (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) ->
  IO ([DriverMessages], [ModSummary])
rootSummariesParallel :: WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> (HscEnv -> Target -> IO (Either DriverMessages ModSummary))
-> IO ([DriverMessages], [ModSummary])
rootSummariesParallel WorkerLimit
n_jobs HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg HscEnv -> Target -> IO (Either DriverMessages ModSummary)
get_summary = do
  ([MakeAction]
actions, [IO
   (Maybe (Either SomeException [Either DriverMessages ModSummary]))]
get_results) <- [(MakeAction,
  IO
    (Maybe (Either SomeException [Either DriverMessages ModSummary])))]
-> ([MakeAction],
    [IO
       (Maybe (Either SomeException [Either DriverMessages ModSummary]))])
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
unzip ([(MakeAction,
   IO
     (Maybe (Either SomeException [Either DriverMessages ModSummary])))]
 -> ([MakeAction],
     [IO
        (Maybe
           (Either SomeException [Either DriverMessages ModSummary]))]))
-> IO
     [(MakeAction,
       IO
         (Maybe (Either SomeException [Either DriverMessages ModSummary])))]
-> IO
     ([MakeAction],
      [IO
         (Maybe (Either SomeException [Either DriverMessages ModSummary]))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, [Target])
 -> IO
      (MakeAction,
       IO
         (Maybe (Either SomeException [Either DriverMessages ModSummary]))))
-> [(Int, [Target])]
-> IO
     [(MakeAction,
       IO
         (Maybe (Either SomeException [Either DriverMessages ModSummary])))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int, [Target])
-> IO
     (MakeAction,
      IO
        (Maybe (Either SomeException [Either DriverMessages ModSummary])))
action_and_result ([Int] -> [[Target]] -> [(Int, [Target])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [[Target]]
bundles)
  WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [MakeAction]
-> IO ()
runPipelines WorkerLimit
n_jobs HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg [MakeAction]
actions
  ([Either SomeException [Either DriverMessages ModSummary]]
-> Either SomeException [[Either DriverMessages ModSummary]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Either SomeException [Either DriverMessages ModSummary]]
 -> Either SomeException [[Either DriverMessages ModSummary]])
-> ([Maybe
       (Either SomeException [Either DriverMessages ModSummary])]
    -> [Either SomeException [Either DriverMessages ModSummary]])
-> [Maybe
      (Either SomeException [Either DriverMessages ModSummary])]
-> Either SomeException [[Either DriverMessages ModSummary]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Either SomeException [Either DriverMessages ModSummary])]
-> [Either SomeException [Either DriverMessages ModSummary]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Either SomeException [Either DriverMessages ModSummary])]
 -> Either SomeException [[Either DriverMessages ModSummary]])
-> IO
     [Maybe (Either SomeException [Either DriverMessages ModSummary])]
-> IO (Either SomeException [[Either DriverMessages ModSummary]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO
   (Maybe (Either SomeException [Either DriverMessages ModSummary]))]
-> IO
     [Maybe (Either SomeException [Either DriverMessages ModSummary])]
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
   (Maybe (Either SomeException [Either DriverMessages ModSummary]))]
get_results) IO (Either SomeException [[Either DriverMessages ModSummary]])
-> (Either SomeException [[Either DriverMessages ModSummary]]
    -> IO ([DriverMessages], [ModSummary]))
-> IO ([DriverMessages], [ModSummary])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right [[Either DriverMessages ModSummary]]
results -> ([DriverMessages], [ModSummary])
-> IO ([DriverMessages], [ModSummary])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either DriverMessages ModSummary]
-> ([DriverMessages], [ModSummary])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([[Either DriverMessages ModSummary]]
-> [Either DriverMessages ModSummary]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Either DriverMessages ModSummary]]
results))
    Left SomeException
exc -> SomeException -> IO ([DriverMessages], [ModSummary])
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
exc
  where
    bundles :: [[Target]]
bundles = [Target] -> [[Target]]
mk_bundles [Target]
targets

    mk_bundles :: [Target] -> [[Target]]
mk_bundles = ([Target] -> Maybe ([Target], [Target])) -> [Target] -> [[Target]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr \case
      [] -> Maybe ([Target], [Target])
forall a. Maybe a
Nothing
      [Target]
ts -> ([Target], [Target]) -> Maybe ([Target], [Target])
forall a. a -> Maybe a
Just (Int -> [Target] -> ([Target], [Target])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
bundle_size [Target]
ts)

    bundle_size :: Int
bundle_size = Int
20

    targets :: [Target]
targets = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env

    action_and_result :: (Int, [Target])
-> IO
     (MakeAction,
      IO
        (Maybe (Either SomeException [Either DriverMessages ModSummary])))
action_and_result (Int
log_queue_id, [Target]
ts) = do
      MVar
  (Maybe (Either SomeException [Either DriverMessages ModSummary]))
res_var <- IO
  (MVar
     (Maybe (Either SomeException [Either DriverMessages ModSummary])))
-> IO
     (MVar
        (Maybe (Either SomeException [Either DriverMessages ModSummary])))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO
  (MVar
     (Maybe (Either SomeException [Either DriverMessages ModSummary])))
forall a. IO (MVar a)
newEmptyMVar
      (MakeAction,
 IO
   (Maybe (Either SomeException [Either DriverMessages ModSummary])))
-> IO
     (MakeAction,
      IO
        (Maybe (Either SomeException [Either DriverMessages ModSummary])))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((MakeAction,
  IO
    (Maybe (Either SomeException [Either DriverMessages ModSummary])))
 -> IO
      (MakeAction,
       IO
         (Maybe (Either SomeException [Either DriverMessages ModSummary]))))
-> (MakeAction,
    IO
      (Maybe (Either SomeException [Either DriverMessages ModSummary])))
-> IO
     (MakeAction,
      IO
        (Maybe (Either SomeException [Either DriverMessages ModSummary])))
forall a b. (a -> b) -> a -> b
$! (RunMakeM (Either SomeException [Either DriverMessages ModSummary])
-> MVar
     (Maybe (Either SomeException [Either DriverMessages ModSummary]))
-> MakeAction
forall a. RunMakeM a -> MVar (Maybe a) -> MakeAction
MakeAction (Int
-> [Target]
-> RunMakeM
     (Either SomeException [Either DriverMessages ModSummary])
action Int
log_queue_id [Target]
ts) MVar
  (Maybe (Either SomeException [Either DriverMessages ModSummary]))
res_var, MVar
  (Maybe (Either SomeException [Either DriverMessages ModSummary]))
-> IO
     (Maybe (Either SomeException [Either DriverMessages ModSummary]))
forall a. MVar a -> IO a
readMVar MVar
  (Maybe (Either SomeException [Either DriverMessages ModSummary]))
res_var)

    action :: Int
-> [Target]
-> RunMakeM
     (Either SomeException [Either DriverMessages ModSummary])
action Int
log_queue_id [Target]
target_bundle = do
      env :: MakeEnv
env@MakeEnv {AbstractSem
compile_sem :: AbstractSem
compile_sem :: MakeEnv -> AbstractSem
compile_sem} <- ReaderT MakeEnv (MaybeT IO) MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      MaybeT IO (Either SomeException [Either DriverMessages ModSummary])
-> RunMakeM
     (Either SomeException [Either DriverMessages ModSummary])
forall (m :: * -> *) a. Monad m => m a -> ReaderT MakeEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT
   IO (Either SomeException [Either DriverMessages ModSummary])
 -> RunMakeM
      (Either SomeException [Either DriverMessages ModSummary]))
-> MaybeT
     IO (Either SomeException [Either DriverMessages ModSummary])
-> RunMakeM
     (Either SomeException [Either DriverMessages ModSummary])
forall a b. (a -> b) -> a -> b
$ IO (Either SomeException [Either DriverMessages ModSummary])
-> MaybeT
     IO (Either SomeException [Either DriverMessages ModSummary])
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either SomeException [Either DriverMessages ModSummary])
 -> MaybeT
      IO (Either SomeException [Either DriverMessages ModSummary]))
-> IO (Either SomeException [Either DriverMessages ModSummary])
-> MaybeT
     IO (Either SomeException [Either DriverMessages ModSummary])
forall a b. (a -> b) -> a -> b
$
        AbstractSem
-> IO (Either SomeException [Either DriverMessages ModSummary])
-> IO (Either SomeException [Either DriverMessages ModSummary])
forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem (IO (Either SomeException [Either DriverMessages ModSummary])
 -> IO (Either SomeException [Either DriverMessages ModSummary]))
-> IO (Either SomeException [Either DriverMessages ModSummary])
-> IO (Either SomeException [Either DriverMessages ModSummary])
forall a b. (a -> b) -> a -> b
$
        Int
-> MakeEnv
-> (HscEnv
    -> IO (Either SomeException [Either DriverMessages ModSummary]))
-> IO (Either SomeException [Either DriverMessages ModSummary])
forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
log_queue_id MakeEnv
env \ HscEnv
lcl_hsc_env ->
          IO [Either DriverMessages ModSummary]
-> IO (Either SomeException [Either DriverMessages ModSummary])
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try ((Target -> IO (Either DriverMessages ModSummary))
-> [Target] -> IO [Either DriverMessages ModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (HscEnv -> Target -> IO (Either DriverMessages ModSummary)
get_summary HscEnv
lcl_hsc_env) [Target]
target_bundle) IO (Either SomeException [Either DriverMessages ModSummary])
-> (Either SomeException [Either DriverMessages ModSummary]
    -> IO (Either SomeException [Either DriverMessages ModSummary]))
-> IO (Either SomeException [Either DriverMessages ModSummary])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left SomeException
e | Just (SomeAsyncException
_ :: SomeAsyncException) <- SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e ->
              SomeException
-> IO (Either SomeException [Either DriverMessages ModSummary])
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
            Either SomeException [Either DriverMessages ModSummary]
a -> Either SomeException [Either DriverMessages ModSummary]
-> IO (Either SomeException [Either DriverMessages ModSummary])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SomeException [Either DriverMessages ModSummary]
a

-- | This function checks then important property that if both p and q are home units
-- then any dependency of p, which transitively depends on q is also a home unit.
--
-- See Note [Multiple Home Units], section 'Closure Property'.
checkHomeUnitsClosed ::  UnitEnv -> [DriverMessages]
checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
checkHomeUnitsClosed UnitEnv
ue
    | Set UnitId -> Bool
forall a. Set a -> Bool
Set.null Set UnitId
bad_unit_ids = []
    | Bool
otherwise = [MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
rootLoc (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ [UnitId] -> DriverMessage
DriverHomePackagesNotClosed (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
bad_unit_ids)]
  where
    home_id_set :: Set UnitId
home_id_set = UnitEnvGraph HomeUnitEnv -> Set UnitId
HUG.allUnits (UnitEnvGraph HomeUnitEnv -> Set UnitId)
-> UnitEnvGraph HomeUnitEnv -> Set UnitId
forall a b. (a -> b) -> a -> b
$ UnitEnv -> UnitEnvGraph HomeUnitEnv
ue_home_unit_graph UnitEnv
ue
    bad_unit_ids :: Set UnitId
bad_unit_ids = Set UnitId
upwards_closure Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set UnitId
home_id_set {- Remove all home units reached, keep only bad nodes -}
    rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"<command line>")

    downwards_closure :: Graph (Node UnitId UnitId)
    downwards_closure :: Graph (Node UnitId UnitId)
downwards_closure = [Node UnitId UnitId] -> Graph (Node UnitId UnitId)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [Node UnitId UnitId]
graphNodes

    inverse_closure :: ReachabilityIndex (Node UnitId UnitId)
inverse_closure = Graph (Node UnitId UnitId)
-> ReachabilityIndex (Node UnitId UnitId)
forall node. Graph node -> ReachabilityIndex node
graphReachability (Graph (Node UnitId UnitId)
 -> ReachabilityIndex (Node UnitId UnitId))
-> Graph (Node UnitId UnitId)
-> ReachabilityIndex (Node UnitId UnitId)
forall a b. (a -> b) -> a -> b
$ Graph (Node UnitId UnitId) -> Graph (Node UnitId UnitId)
forall node. Graph node -> Graph node
transposeG Graph (Node UnitId UnitId)
downwards_closure

    upwards_closure :: Set UnitId
upwards_closure = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ([UnitId] -> Set UnitId) -> [UnitId] -> Set UnitId
forall a b. (a -> b) -> a -> b
$ (Node UnitId UnitId -> UnitId) -> [Node UnitId UnitId] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map Node UnitId UnitId -> UnitId
forall key payload. Node key payload -> key
node_key ([Node UnitId UnitId] -> [UnitId])
-> [Node UnitId UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ ReachabilityIndex (Node UnitId UnitId)
-> [Node UnitId UnitId] -> [Node UnitId UnitId]
forall node. ReachabilityIndex node -> [node] -> [node]
allReachableMany ReachabilityIndex (Node UnitId UnitId)
inverse_closure [UnitId -> UnitId -> [UnitId] -> Node UnitId UnitId
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode UnitId
uid UnitId
uid [] | UnitId
uid <- Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
home_id_set]

    all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
    all_unit_direct_deps :: UniqMap UnitId (Set UnitId)
all_unit_direct_deps
      = (UniqMap UnitId (Set UnitId)
 -> UnitId -> HomeUnitEnv -> UniqMap UnitId (Set UnitId))
-> UniqMap UnitId (Set UnitId)
-> UnitEnvGraph HomeUnitEnv
-> UniqMap UnitId (Set UnitId)
forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
HUG.unitEnv_foldWithKey UniqMap UnitId (Set UnitId)
-> UnitId -> HomeUnitEnv -> UniqMap UnitId (Set UnitId)
go UniqMap UnitId (Set UnitId)
forall k a. UniqMap k a
emptyUniqMap (UnitEnvGraph HomeUnitEnv -> UniqMap UnitId (Set UnitId))
-> UnitEnvGraph HomeUnitEnv -> UniqMap UnitId (Set UnitId)
forall a b. (a -> b) -> a -> b
$ UnitEnv -> UnitEnvGraph HomeUnitEnv
ue_home_unit_graph UnitEnv
ue
      where
        go :: UniqMap UnitId (Set UnitId)
-> UnitId -> HomeUnitEnv -> UniqMap UnitId (Set UnitId)
go UniqMap UnitId (Set UnitId)
rest UnitId
this HomeUnitEnv
this_uis =
           (Set UnitId -> Set UnitId -> Set UnitId)
-> UniqMap UnitId (Set UnitId)
-> UniqMap UnitId (Set UnitId)
-> UniqMap UnitId (Set UnitId)
forall a k.
(a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
plusUniqMap_C Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.union
             ((Set UnitId -> Set UnitId -> Set UnitId)
-> UniqMap UnitId (Set UnitId)
-> UnitId
-> Set UnitId
-> UniqMap UnitId (Set UnitId)
forall k a.
Uniquable k =>
(a -> a -> a) -> UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap_C Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.union UniqMap UnitId (Set UnitId)
external_depends UnitId
this ([UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ([UnitId] -> Set UnitId) -> [UnitId] -> Set UnitId
forall a b. (a -> b) -> a -> b
$ [UnitId]
this_deps))
             UniqMap UnitId (Set UnitId)
rest
           where
             external_depends :: UniqMap UnitId (Set UnitId)
external_depends = (GenericUnitInfo PackageId PackageName UnitId ModuleName Module
 -> Set UnitId)
-> UniqMap
     UnitId
     (GenericUnitInfo PackageId PackageName UnitId ModuleName Module)
-> UniqMap UnitId (Set UnitId)
forall a b k. (a -> b) -> UniqMap k a -> UniqMap k b
mapUniqMap ([UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ([UnitId] -> Set UnitId)
-> (GenericUnitInfo PackageId PackageName UnitId ModuleName Module
    -> [UnitId])
-> GenericUnitInfo PackageId PackageName UnitId ModuleName Module
-> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericUnitInfo PackageId PackageName UnitId ModuleName Module
-> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends) (UnitState
-> UniqMap
     UnitId
     (GenericUnitInfo PackageId PackageName UnitId ModuleName Module)
unitInfoMap UnitState
this_units)
             this_units :: UnitState
this_units = HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
this_uis
             this_deps :: [UnitId]
this_deps = [ GenUnit UnitId -> UnitId
toUnitId GenUnit UnitId
unit | (GenUnit UnitId
unit,Just PackageArg
_) <- UnitState -> [(GenUnit UnitId, Maybe PackageArg)]
explicitUnits UnitState
this_units]

    graphNodes :: [Node UnitId UnitId]
    graphNodes :: [Node UnitId UnitId]
graphNodes = Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go Set UnitId
forall a. Set a
Set.empty Set UnitId
home_id_set
      where
        go :: Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go Set UnitId
done Set UnitId
todo
          = case Set UnitId -> Maybe (UnitId, Set UnitId)
forall a. Set a -> Maybe (a, Set a)
Set.minView Set UnitId
todo of
              Maybe (UnitId, Set UnitId)
Nothing -> []
              Just (UnitId
uid, Set UnitId
todo')
                | UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member UnitId
uid Set UnitId
done -> Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go Set UnitId
done Set UnitId
todo'
                | Bool
otherwise -> case UniqMap UnitId (Set UnitId) -> UnitId -> Maybe (Set UnitId)
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap UnitId (Set UnitId)
all_unit_direct_deps UnitId
uid of
                    Maybe (Set UnitId)
Nothing -> FilePath -> SDoc -> [Node UnitId UnitId]
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"uid not found" ((UnitId, UniqMap UnitId (Set UnitId)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId
uid, UniqMap UnitId (Set UnitId)
all_unit_direct_deps))
                    Just Set UnitId
depends ->
                      let todo'' :: Set UnitId
todo'' = (Set UnitId
depends Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set UnitId
done) Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set UnitId
todo'
                      in UnitId -> UnitId -> [UnitId] -> Node UnitId UnitId
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode UnitId
uid UnitId
uid (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
depends) Node UnitId UnitId -> [Node UnitId UnitId] -> [Node UnitId UnitId]
forall a. a -> [a] -> [a]
: Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go (UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.insert UnitId
uid Set UnitId
done) Set UnitId
todo''

-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
-- the specified target, disable optimization and change the .hi
-- and .o file locations to be temporary files.
-- See Note [-fno-code mode]
enableCodeGenForTH
  :: Logger
  -> TmpFs
  -> UnitEnv
  -> [ModuleGraphNode]
  -> IO ModuleGraph
enableCodeGenForTH :: Logger -> TmpFs -> UnitEnv -> [ModuleGraphNode] -> IO ModuleGraph
enableCodeGenForTH Logger
logger TmpFs
tmpfs UnitEnv
unit_env =
  Logger
-> TmpFs
-> TempFileLifetime
-> TempFileLifetime
-> UnitEnv
-> [ModuleGraphNode]
-> IO ModuleGraph
enableCodeGenWhen Logger
logger TmpFs
tmpfs TempFileLifetime
TFL_CurrentModule TempFileLifetime
TFL_GhcSession UnitEnv
unit_env


data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (CodeGenEnable -> CodeGenEnable -> Bool
(CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool) -> Eq CodeGenEnable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CodeGenEnable -> CodeGenEnable -> Bool
== :: CodeGenEnable -> CodeGenEnable -> Bool
$c/= :: CodeGenEnable -> CodeGenEnable -> Bool
/= :: CodeGenEnable -> CodeGenEnable -> Bool
Eq, Int -> CodeGenEnable -> FilePath -> FilePath
[CodeGenEnable] -> FilePath -> FilePath
CodeGenEnable -> FilePath
(Int -> CodeGenEnable -> FilePath -> FilePath)
-> (CodeGenEnable -> FilePath)
-> ([CodeGenEnable] -> FilePath -> FilePath)
-> Show CodeGenEnable
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> CodeGenEnable -> FilePath -> FilePath
showsPrec :: Int -> CodeGenEnable -> FilePath -> FilePath
$cshow :: CodeGenEnable -> FilePath
show :: CodeGenEnable -> FilePath
$cshowList :: [CodeGenEnable] -> FilePath -> FilePath
showList :: [CodeGenEnable] -> FilePath -> FilePath
Show, Eq CodeGenEnable
Eq CodeGenEnable =>
(CodeGenEnable -> CodeGenEnable -> Ordering)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> CodeGenEnable)
-> (CodeGenEnable -> CodeGenEnable -> CodeGenEnable)
-> Ord CodeGenEnable
CodeGenEnable -> CodeGenEnable -> Bool
CodeGenEnable -> CodeGenEnable -> Ordering
CodeGenEnable -> CodeGenEnable -> CodeGenEnable
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CodeGenEnable -> CodeGenEnable -> Ordering
compare :: CodeGenEnable -> CodeGenEnable -> Ordering
$c< :: CodeGenEnable -> CodeGenEnable -> Bool
< :: CodeGenEnable -> CodeGenEnable -> Bool
$c<= :: CodeGenEnable -> CodeGenEnable -> Bool
<= :: CodeGenEnable -> CodeGenEnable -> Bool
$c> :: CodeGenEnable -> CodeGenEnable -> Bool
> :: CodeGenEnable -> CodeGenEnable -> Bool
$c>= :: CodeGenEnable -> CodeGenEnable -> Bool
>= :: CodeGenEnable -> CodeGenEnable -> Bool
$cmax :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
max :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
$cmin :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
min :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
Ord)

instance Outputable CodeGenEnable where
  ppr :: CodeGenEnable -> SDoc
ppr = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath -> SDoc)
-> (CodeGenEnable -> FilePath) -> CodeGenEnable -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenEnable -> FilePath
forall a. Show a => a -> FilePath
show

-- | Helper used to implement 'enableCodeGenForTH'.
-- In particular, this enables
-- unoptimized code generation for all modules that meet some
-- condition (first parameter), or are dependencies of those
-- modules. The second parameter is a condition to check before
-- marking modules for code generation.
enableCodeGenWhen
  :: Logger
  -> TmpFs
  -> TempFileLifetime
  -> TempFileLifetime
  -> UnitEnv
  -> [ModuleGraphNode]
  -> IO ModuleGraph
enableCodeGenWhen :: Logger
-> TmpFs
-> TempFileLifetime
-> TempFileLifetime
-> UnitEnv
-> [ModuleGraphNode]
-> IO ModuleGraph
enableCodeGenWhen Logger
logger TmpFs
tmpfs TempFileLifetime
staticLife TempFileLifetime
dynLife UnitEnv
unit_env [ModuleGraphNode]
mod_graph = do
  (ModuleNodeInfo -> IO ModuleNodeInfo)
-> ModuleGraph -> IO ModuleGraph
mgMapM ModuleNodeInfo -> IO ModuleNodeInfo
enable_code_gen ModuleGraph
mg
  where
    defaultBackendOf :: ModSummary -> Backend
defaultBackendOf ModSummary
ms = Platform -> Backend
platformDefaultBackend (DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> DynFlags -> Platform
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitId -> UnitEnv -> DynFlags
UnitId -> UnitEnv -> DynFlags
ue_unitFlags (ModSummary -> UnitId
ms_unitid ModSummary
ms) UnitEnv
unit_env)

    enable_code_gen :: ModuleNodeInfo -> IO ModuleNodeInfo
    enable_code_gen :: ModuleNodeInfo -> IO ModuleNodeInfo
enable_code_gen (ModuleNodeCompile ModSummary
ms) = ModSummary -> ModuleNodeInfo
ModuleNodeCompile (ModSummary -> ModuleNodeInfo)
-> IO ModSummary -> IO ModuleNodeInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModSummary -> IO ModSummary
enable_code_gen_ms ModSummary
ms
    enable_code_gen m :: ModuleNodeInfo
m@(ModuleNodeFixed {}) = ModuleNodeInfo -> IO ModuleNodeInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleNodeInfo
m

    -- FIXME: Strong resemblance and some duplication between this and `makeDynFlagsConsistent`.
    -- It would be good to consider how to make these checks more uniform and not duplicated.
    enable_code_gen_ms :: ModSummary -> IO ModSummary
    enable_code_gen_ms :: ModSummary -> IO ModSummary
enable_code_gen_ms ModSummary
ms
      | ModSummary
        { ms_location :: ModSummary -> ModLocation
ms_location = ModLocation
ms_location
        , ms_hsc_src :: ModSummary -> HscSource
ms_hsc_src = HscSource
HsSrcFile
        , ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags
        } <- ModSummary
ms
      , Just CodeGenEnable
enable_spec <- NodeKey -> Maybe CodeGenEnable
needs_codegen_map (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms)) =
      if | ModSummary -> Bool
nocode_enable ModSummary
ms -> do
               let new_temp_file :: FilePath -> FilePath -> IO (OsString, OsString)
new_temp_file FilePath
suf FilePath
dynsuf = do
                     FilePath
tn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
staticLife FilePath
suf
                     let dyn_tn :: FilePath
dyn_tn = FilePath
tn FilePath -> FilePath -> FilePath
-<.> FilePath
dynsuf
                     TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
dynLife [FilePath
dyn_tn]
                     return (HasCallStack => FilePath -> OsString
FilePath -> OsString
unsafeEncodeUtf FilePath
tn, HasCallStack => FilePath -> OsString
FilePath -> OsString
unsafeEncodeUtf FilePath
dyn_tn)
                 -- We don't want to create .o or .hi files unless we have been asked
                 -- to by the user. But we need them, so we patch their locations in
                 -- the ModSummary with temporary files.
                 --
               ((OsString
hi_file, OsString
dyn_hi_file), (OsString
o_file, OsString
dyn_o_file)) <-
                 -- If ``-fwrite-interface` is specified, then the .o and .hi files
                 -- are written into `-odir` and `-hidir` respectively.  #16670
                 if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
                   then ((OsString, OsString), (OsString, OsString))
-> IO ((OsString, OsString), (OsString, OsString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ModLocation -> OsString
ml_hi_file_ospath ModLocation
ms_location, ModLocation -> OsString
ml_dyn_hi_file_ospath ModLocation
ms_location)
                               , (ModLocation -> OsString
ml_obj_file_ospath ModLocation
ms_location, ModLocation -> OsString
ml_dyn_obj_file_ospath ModLocation
ms_location))
                   else (,) ((OsString, OsString)
 -> (OsString, OsString)
 -> ((OsString, OsString), (OsString, OsString)))
-> IO (OsString, OsString)
-> IO
     ((OsString, OsString)
      -> ((OsString, OsString), (OsString, OsString)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> IO (OsString, OsString)
new_temp_file (DynFlags -> FilePath
hiSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynHiSuf_ DynFlags
dflags))
                            IO
  ((OsString, OsString)
   -> ((OsString, OsString), (OsString, OsString)))
-> IO (OsString, OsString)
-> IO ((OsString, OsString), (OsString, OsString))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> FilePath -> IO (OsString, OsString)
new_temp_file (DynFlags -> FilePath
objectSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynObjectSuf_ DynFlags
dflags))
               let new_dflags :: DynFlags
new_dflags = case CodeGenEnable
enable_spec of
                                  CodeGenEnable
EnableByteCode -> DynFlags
dflags { backend = interpreterBackend }
                                  CodeGenEnable
EnableObject   -> DynFlags
dflags { backend = defaultBackendOf ms }
                                  CodeGenEnable
EnableByteCodeAndObject -> (DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags GeneralFlag
Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}
               let ms' :: ModSummary
ms' = ModSummary
ms
                     { ms_location =
                         ms_location { ml_hi_file_ospath = hi_file
                                     , ml_obj_file_ospath = o_file
                                     , ml_dyn_hi_file_ospath = dyn_hi_file
                                     , ml_dyn_obj_file_ospath = dyn_o_file }
                     , ms_hspp_opts = updOptLevel 0 $ new_dflags
                     }
               -- Recursive call to catch the other cases
               ModSummary -> IO ModSummary
enable_code_gen_ms ModSummary
ms'

         -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough)
         -- we only get to this case if the default backend is already generating object files, but we need dynamic
         -- objects
         | CodeGenEnable -> ModSummary -> Bool
bytecode_and_enable CodeGenEnable
enable_spec ModSummary
ms -> do
               let ms' :: ModSummary
ms' = ModSummary
ms
                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode
                     }
               -- Recursive call to catch the other cases
               ModSummary -> IO ModSummary
enable_code_gen_ms ModSummary
ms'
         | CodeGenEnable -> ModSummary -> Bool
dynamic_too_enable CodeGenEnable
enable_spec ModSummary
ms -> do
               let ms' :: ModSummary
ms' = ModSummary
ms
                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo
                     }
               -- Recursive call to catch the other cases
               ModSummary -> IO ModSummary
enable_code_gen_ms ModSummary
ms'
         | ModSummary -> Bool
ext_interp_enable ModSummary
ms -> do
               let ms' :: ModSummary
ms' = ModSummary
ms
                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter
                     }
               -- Recursive call to catch the other cases
               ModSummary -> IO ModSummary
enable_code_gen_ms ModSummary
ms'

         | DynFlags -> Bool
needs_full_ways DynFlags
dflags -> do
               let ms' :: ModSummary
ms' = ModSummary
ms { ms_hspp_opts = set_full_ways dflags }
               -- Recursive call to catch the other cases
               ModSummary -> IO ModSummary
enable_code_gen_ms ModSummary
ms'

         | Bool
otherwise -> ModSummary -> IO ModSummary
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
ms

    enable_code_gen_ms ModSummary
ms = ModSummary -> IO ModSummary
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
ms

    nocode_enable :: ModSummary -> Bool
nocode_enable ms :: ModSummary
ms@(ModSummary { ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags }) =
      Bool -> Bool
not (Backend -> Bool
backendGeneratesCode (DynFlags -> Backend
backend DynFlags
dflags)) Bool -> Bool -> Bool
&&
      -- Don't enable codegen for TH on indefinite packages; we
      -- can't compile anything anyway! See #16219.
      HomeUnit -> Bool
forall u. GenHomeUnit u -> Bool
isHomeUnitDefinite (UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit (ModSummary -> UnitId
ms_unitid ModSummary
ms) UnitEnv
unit_env)

    bytecode_and_enable :: CodeGenEnable -> ModSummary -> Bool
bytecode_and_enable CodeGenEnable
enable_spec ModSummary
ms =
      -- In the situation where we **would** need to enable dynamic-too
      -- IF we had decided we needed objects
      CodeGenEnable -> ModSummary -> Bool
dynamic_too_enable CodeGenEnable
EnableObject ModSummary
ms
        -- but we prefer to use bytecode rather than objects
        Bool -> Bool -> Bool
&& Bool
prefer_bytecode
        -- and we haven't already turned it on
        Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
generate_both
      where
        lcl_dflags :: DynFlags
lcl_dflags   = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
        prefer_bytecode :: Bool
prefer_bytecode = case CodeGenEnable
enable_spec of
                            CodeGenEnable
EnableByteCodeAndObject -> Bool
True
                            CodeGenEnable
EnableByteCode -> Bool
True
                            CodeGenEnable
EnableObject -> Bool
False

        generate_both :: Bool
generate_both   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ByteCodeAndObjectCode DynFlags
lcl_dflags

    -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
    -- the linker can correctly load the object files.  This isn't necessary
    -- when using -fexternal-interpreter.
    dynamic_too_enable :: CodeGenEnable -> ModSummary -> Bool
dynamic_too_enable CodeGenEnable
enable_spec ModSummary
ms
      | Settings -> Bool
sTargetRTSLinkerOnlySupportsSharedLibs (Settings -> Bool) -> Settings -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Settings
settings DynFlags
lcl_dflags =
          Bool -> Bool
not Bool
isDynWay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
dyn_too_enabled
            Bool -> Bool -> Bool
&& Bool
enable_object
      | Bool
otherwise =
          Bool
hostIsDynamic Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hostIsProfiled Bool -> Bool -> Bool
&& Bool
internalInterpreter Bool -> Bool -> Bool
&&
            Bool -> Bool
not Bool
isDynWay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isProfWay Bool -> Bool -> Bool
&&  Bool -> Bool
not Bool
dyn_too_enabled
              Bool -> Bool -> Bool
&& Bool
enable_object
      where
       lcl_dflags :: DynFlags
lcl_dflags   = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
       internalInterpreter :: Bool
internalInterpreter = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
lcl_dflags)
       dyn_too_enabled :: Bool
dyn_too_enabled = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildDynamicToo DynFlags
lcl_dflags
       isDynWay :: Bool
isDynWay    = Ways -> Way -> Bool
hasWay (DynFlags -> Ways
ways DynFlags
lcl_dflags) Way
WayDyn
       isProfWay :: Bool
isProfWay   = Ways -> Way -> Bool
hasWay (DynFlags -> Ways
ways DynFlags
lcl_dflags) Way
WayProf
       enable_object :: Bool
enable_object = case CodeGenEnable
enable_spec of
                            CodeGenEnable
EnableByteCode -> Bool
False
                            CodeGenEnable
EnableByteCodeAndObject -> Bool
True
                            CodeGenEnable
EnableObject -> Bool
True

    -- #16331 - when no "internal interpreter" is available but we
    -- need to process some TemplateHaskell or QuasiQuotes, we automatically
    -- turn on -fexternal-interpreter.
    ext_interp_enable :: ModSummary -> Bool
ext_interp_enable ModSummary
ms = Bool -> Bool
not Bool
ghciSupported Bool -> Bool -> Bool
&& Bool
internalInterpreter
      where
       lcl_dflags :: DynFlags
lcl_dflags   = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
       internalInterpreter :: Bool
internalInterpreter = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
lcl_dflags)

    mg :: ModuleGraph
mg = [ModuleGraphNode] -> ModuleGraph
mkModuleGraph [ModuleGraphNode]
mod_graph

    needs_obj_set, needs_bc_set :: NodeKey -> Bool
    needs_obj_set :: NodeKey -> Bool
needs_obj_set NodeKey
k = ModuleGraph -> [NodeKey] -> NodeKey -> Bool
mgQueryMany ModuleGraph
mg [NodeKey]
need_obj_set NodeKey
k Bool -> Bool -> Bool
|| NodeKey
k NodeKey -> [NodeKey] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NodeKey]
need_obj_set

    needs_bc_set :: NodeKey -> Bool
needs_bc_set NodeKey
k = ModuleGraph -> [NodeKey] -> NodeKey -> Bool
mgQueryMany ModuleGraph
mg [NodeKey]
need_bc_set NodeKey
k Bool -> Bool -> Bool
|| NodeKey
k NodeKey -> [NodeKey] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NodeKey]
need_bc_set

    -- A map which tells us how to enable code generation for a NodeKey
    needs_codegen_map :: NodeKey -> Maybe CodeGenEnable
    needs_codegen_map :: NodeKey -> Maybe CodeGenEnable
needs_codegen_map NodeKey
nk =
      -- Another option here would be to just produce object code, rather than both object and
      -- byte code
      case (NodeKey -> Bool
needs_obj_set NodeKey
nk, NodeKey -> Bool
needs_bc_set NodeKey
nk) of
        (Bool
True, Bool
True)   -> CodeGenEnable -> Maybe CodeGenEnable
forall a. a -> Maybe a
Just CodeGenEnable
EnableByteCodeAndObject
        (Bool
True, Bool
False)  -> CodeGenEnable -> Maybe CodeGenEnable
forall a. a -> Maybe a
Just CodeGenEnable
EnableObject
        (Bool
False, Bool
True)  -> CodeGenEnable -> Maybe CodeGenEnable
forall a. a -> Maybe a
Just CodeGenEnable
EnableByteCode
        (Bool
False, Bool
False) -> Maybe CodeGenEnable
forall a. Maybe a
Nothing

    -- The direct dependencies of modules which require object code
    need_obj_set :: [NodeKey]
need_obj_set =
      [[NodeKey]] -> [NodeKey]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only
        -- it's dependencies.
        [ [NodeKey]
deps
        | (ModuleNode [NodeKey]
deps (ModuleNodeCompile ModSummary
ms)) <- [ModuleGraphNode]
mod_graph
        , ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms
        , Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_UseBytecodeRatherThanObjects (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms))
        ]

    -- The direct dependencies of modules which require byte code
    need_bc_set :: [NodeKey]
need_bc_set =
      [[NodeKey]] -> [NodeKey]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [NodeKey]
deps
        | (ModuleNode [NodeKey]
deps (ModuleNodeCompile ModSummary
ms)) <- [ModuleGraphNode]
mod_graph
        , ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms
        , GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_UseBytecodeRatherThanObjects (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms)
        ]

    -- FIXME: Duplicated from makeDynFlagsConsistent
    needs_full_ways :: DynFlags -> Bool
needs_full_ways DynFlags
dflags
      = DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkInMemory Bool -> Bool -> Bool
&&
        Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags) Bool -> Bool -> Bool
&&
        DynFlags -> Ways
targetWays_ DynFlags
dflags Ways -> Ways -> Bool
forall a. Eq a => a -> a -> Bool
/= Ways
hostFullWays
    set_full_ways :: DynFlags -> DynFlags
set_full_ways DynFlags
dflags =
        let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
            dflags_a :: DynFlags
dflags_a = DynFlags
dflags { targetWays_ = hostFullWays }
            dflags_b :: DynFlags
dflags_b = (DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags_a
                     ([GeneralFlag] -> DynFlags) -> [GeneralFlag] -> DynFlags
forall a b. (a -> b) -> a -> b
$ (Way -> [GeneralFlag]) -> Ways -> [GeneralFlag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Platform -> Way -> [GeneralFlag]
wayGeneralFlags Platform
platform)
                                 Ways
hostFullWays
            dflags_c :: DynFlags
dflags_c = (DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> GeneralFlag -> DynFlags
gopt_unset DynFlags
dflags_b
                     ([GeneralFlag] -> DynFlags) -> [GeneralFlag] -> DynFlags
forall a b. (a -> b) -> a -> b
$ (Way -> [GeneralFlag]) -> Ways -> [GeneralFlag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Platform -> Way -> [GeneralFlag]
wayUnsetGeneralFlags Platform
platform)
                                 Ways
hostFullWays
        in DynFlags
dflags_c

-- | Populate the Downsweep cache with the root modules.
mkRootMap
  :: [ModuleNodeInfo]
  -> DownsweepCache
mkRootMap :: [ModuleNodeInfo] -> DownsweepCache
mkRootMap [ModuleNodeInfo]
summaries = ([Either DriverMessages ModuleNodeInfo]
 -> [Either DriverMessages ModuleNodeInfo]
 -> [Either DriverMessages ModuleNodeInfo])
-> [((UnitId, PkgQual, ModuleNameWithIsBoot),
     [Either DriverMessages ModuleNodeInfo])]
-> DownsweepCache
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (([Either DriverMessages ModuleNodeInfo]
 -> [Either DriverMessages ModuleNodeInfo]
 -> [Either DriverMessages ModuleNodeInfo])
-> [Either DriverMessages ModuleNodeInfo]
-> [Either DriverMessages ModuleNodeInfo]
-> [Either DriverMessages ModuleNodeInfo]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Either DriverMessages ModuleNodeInfo]
-> [Either DriverMessages ModuleNodeInfo]
-> [Either DriverMessages ModuleNodeInfo]
forall a. [a] -> [a] -> [a]
(++))
  [ ((ModuleNodeInfo -> UnitId
moduleNodeInfoUnitId ModuleNodeInfo
s, PkgQual
NoPkgQual, ModuleNodeInfo -> ModuleNameWithIsBoot
moduleNodeInfoMnwib ModuleNodeInfo
s), [ModuleNodeInfo -> Either DriverMessages ModuleNodeInfo
forall a b. b -> Either a b
Right ModuleNodeInfo
s]) | ModuleNodeInfo
s <- [ModuleNodeInfo]
summaries ]

-----------------------------------------------------------------------------
-- Summarising modules

-- We have two types of summarisation:
--
--    * Summarise a file.  This is used for the root module(s) passed to
--      cmLoadModules.  The file is read, and used to determine the root
--      module name.  The module name may differ from the filename.
--
--    * Summarise a module.  We are given a module name, and must provide
--      a summary.  The finder is used to locate the file in which the module
--      resides.

summariseFile
        :: HscEnv
        -> HomeUnit
        -> M.Map (UnitId, FilePath) ModSummary    -- old summaries
        -> FilePath                     -- source file name
        -> Maybe Phase                  -- start phase
        -> Maybe (StringBuffer,UTCTime)
        -> IO (Either DriverMessages ModSummary)

summariseFile :: HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer, UTCTime)
-> IO (Either DriverMessages ModSummary)
summariseFile HscEnv
hsc_env' HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summaries FilePath
src_fn Maybe Phase
mb_phase Maybe (StringBuffer, UTCTime)
maybe_buf
        -- we can use a cached summary if one is available and the
        -- source file hasn't changed,
   | Just ModSummary
old_summary <- (UnitId, FilePath)
-> Map (UnitId, FilePath) ModSummary -> Maybe ModSummary
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit, FilePath
src_fn) Map (UnitId, FilePath) ModSummary
old_summaries
   = do
        let location :: ModLocation
location = ModSummary -> ModLocation
ms_location (ModSummary -> ModLocation) -> ModSummary -> ModLocation
forall a b. (a -> b) -> a -> b
$ ModSummary
old_summary

        Fingerprint
src_hash <- IO Fingerprint
get_src_hash
                -- The file exists; we checked in getRootSummary above.
                -- If it gets removed subsequently, then this
                -- getFileHash may fail, but that's the right
                -- behaviour.

                -- return the cached summary if the source didn't change
        HscEnv
-> (Fingerprint -> IO (Either DriverMessages ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash
            HscEnv
hsc_env (FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn)
            ModSummary
old_summary ModLocation
location Fingerprint
src_hash

   | Bool
otherwise
   = do Fingerprint
src_hash <- IO Fingerprint
get_src_hash
        FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn Fingerprint
src_hash
  where
    -- change the main active unit so all operations happen relative to the given unit
    hsc_env :: HscEnv
hsc_env = HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit HscEnv
hsc_env'
    -- src_fn does not necessarily exist on the filesystem, so we need to
    -- check what kind of target we are dealing with
    get_src_hash :: IO Fingerprint
get_src_hash = case Maybe (StringBuffer, UTCTime)
maybe_buf of
                      Just (StringBuffer
buf,UTCTime
_) -> Fingerprint -> IO Fingerprint
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint -> IO Fingerprint) -> Fingerprint -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ StringBuffer -> Fingerprint
fingerprintStringBuffer StringBuffer
buf
                      Maybe (StringBuffer, UTCTime)
Nothing -> IO Fingerprint -> IO Fingerprint
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> IO Fingerprint)
-> IO Fingerprint -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Fingerprint
getFileHash FilePath
src_fn

    new_summary :: FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn Fingerprint
src_hash = ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DriverMessages IO ModSummary
 -> IO (Either DriverMessages ModSummary))
-> ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ do
        preimps :: PreprocessedImports
preimps@PreprocessedImports {FilePath
[(PkgQual, Located ModuleName)]
ModuleName
StringBuffer
SrcSpan
DynFlags
pi_local_dflags :: DynFlags
pi_srcimps :: [(PkgQual, Located ModuleName)]
pi_theimps :: [(PkgQual, Located ModuleName)]
pi_hspp_fn :: FilePath
pi_hspp_buf :: StringBuffer
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> StringBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_theimps :: PreprocessedImports -> [(PkgQual, Located ModuleName)]
pi_srcimps :: PreprocessedImports -> [(PkgQual, Located ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..}
            <- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (StringBuffer, UTCTime)
maybe_buf

        let fopts :: FinderOpts
fopts = DynFlags -> FinderOpts
initFinderOpts (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
            (FilePath
basename, FilePath
extension) = FilePath -> (FilePath, FilePath)
splitExtension FilePath
src_fn

            hsc_src :: HscSource
hsc_src
              | FilePath -> Bool
isHaskellSigSuffix (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
extension) = HscSource
HsigFile
              | FilePath -> Bool
isHaskellBootSuffix (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
extension) = HscSource
HsBootFile
              | Bool
otherwise = HscSource
HsSrcFile

            -- Make a ModLocation for this file, adding the @-boot@ suffix to
            -- all paths if the original was a boot file.
            location :: ModLocation
location = FinderOpts
-> ModuleName -> OsString -> OsString -> HscSource -> ModLocation
mkHomeModLocation FinderOpts
fopts ModuleName
pi_mod_name (HasCallStack => FilePath -> OsString
FilePath -> OsString
unsafeEncodeUtf FilePath
basename) (HasCallStack => FilePath -> OsString
FilePath -> OsString
unsafeEncodeUtf FilePath
extension) HscSource
hsc_src

        -- Tell the Finder cache where it is, so that subsequent calls
        -- to findModule will find it, even if it's not on any search path
        Module
mod <- IO Module -> ExceptT DriverMessages IO Module
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> ExceptT DriverMessages IO Module)
-> IO Module -> ExceptT DriverMessages IO Module
forall a b. (a -> b) -> a -> b
$ do
          let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
          let fc :: FinderCache
fc        = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
          FinderCache
-> HomeUnit -> ModuleName -> ModLocation -> HscSource -> IO Module
addHomeModuleToFinder FinderCache
fc HomeUnit
home_unit ModuleName
pi_mod_name ModLocation
location HscSource
hsc_src

        IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> ExceptT DriverMessages IO ModSummary)
-> IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env (MakeNewModSummary -> IO ModSummary)
-> MakeNewModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
            { nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
            , nms_src_hash :: Fingerprint
nms_src_hash = Fingerprint
src_hash
            , nms_hsc_src :: HscSource
nms_hsc_src = HscSource
hsc_src
            , nms_location :: ModLocation
nms_location = ModLocation
location
            , nms_mod :: Module
nms_mod = Module
mod
            , nms_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
            }

checkSummaryHash
    :: HscEnv
    -> (Fingerprint -> IO (Either e ModSummary))
    -> ModSummary -> ModLocation -> Fingerprint
    -> IO (Either e ModSummary)
checkSummaryHash :: forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash
  HscEnv
hsc_env Fingerprint -> IO (Either e ModSummary)
new_summary
  ModSummary
old_summary
  ModLocation
location Fingerprint
src_hash
  | ModSummary -> Fingerprint
ms_hs_hash ModSummary
old_summary Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
src_hash Bool -> Bool -> Bool
&&
      Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) = do
           -- update the object-file timestamp
           Maybe UTCTime
obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_obj_file ModLocation
location)

           -- We have to repopulate the Finder's cache for file targets
           -- because the file might not even be on the regular search path
           -- and it was likely flushed in depanal. This is not technically
           -- needed when we're called from sumariseModule but it shouldn't
           -- hurt.
           let fc :: FinderCache
fc      = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
               mod :: Module
mod     = ModSummary -> Module
ms_mod ModSummary
old_summary
               hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
old_summary
           FinderCache -> Module -> ModLocation -> HscSource -> IO ()
addModuleToFinder FinderCache
fc Module
mod ModLocation
location HscSource
hsc_src

           Maybe UTCTime
hi_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
location)
           Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
location)

           return $ ModSummary -> Either e ModSummary
forall a b. b -> Either a b
Right
             ( ModSummary
old_summary
                     { ms_obj_date = obj_timestamp
                     , ms_iface_date = hi_timestamp
                     , ms_hie_date = hie_timestamp
                     }
             )

   | Bool
otherwise =
           -- source changed: re-summarise.
           Fingerprint -> IO (Either e ModSummary)
new_summary Fingerprint
src_hash

data SummariseResult =
        FoundInstantiation InstantiatedUnit
      | FoundHomeWithError (UnitId, DriverMessages)
      | FoundHome ModuleNodeInfo
      | External UnitId
      | NotThere

-- | summariseModule finds the location of the source file for the given module.
-- This version always returns a ModuleNodeCompile node, it is useful for
-- --make mode.
summariseModule :: HscEnv
                -> HomeUnit
                -> M.Map (UnitId, FilePath) ModSummary
                -> IsBootInterface
                -> Located ModuleName
                -> PkgQual
                -> Maybe (StringBuffer, UTCTime)
                -> [ModuleName]
                -> IO SummariseResult
summariseModule :: HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summaries IsBootInterface
is_boot Located ModuleName
wanted_mod PkgQual
mb_pkg Maybe (StringBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods =
  (HscEnv -> ModLocation -> Module -> IO SummariseResult)
-> HscEnv
-> HomeUnit
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> [ModuleName]
-> IO SummariseResult
summariseModuleDispatch HscEnv -> ModLocation -> Module -> IO SummariseResult
k HscEnv
hsc_env HomeUnit
home_unit IsBootInterface
is_boot Located ModuleName
wanted_mod PkgQual
mb_pkg [ModuleName]
excl_mods
  where
    k :: HscEnv -> ModLocation -> Module -> IO SummariseResult
k = HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> Maybe (StringBuffer, UTCTime)
-> HscEnv
-> ModLocation
-> Module
-> IO SummariseResult
summariseModuleWithSource HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summaries IsBootInterface
is_boot Maybe (StringBuffer, UTCTime)
maybe_buf


-- | Like summariseModule but for interface files that we don't want to compile.
-- This version always returns a ModuleNodeFixed node.
summariseModuleInterface :: HscEnv
                        -> HomeUnit
                        -> IsBootInterface
                        -> Located ModuleName
                        -> PkgQual
                        -> [ModuleName]
                        -> IO SummariseResult
summariseModuleInterface :: HscEnv
-> HomeUnit
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> [ModuleName]
-> IO SummariseResult
summariseModuleInterface HscEnv
hsc_env HomeUnit
home_unit IsBootInterface
is_boot Located ModuleName
wanted_mod PkgQual
mb_pkg [ModuleName]
excl_mods =
  (HscEnv -> ModLocation -> Module -> IO SummariseResult)
-> HscEnv
-> HomeUnit
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> [ModuleName]
-> IO SummariseResult
summariseModuleDispatch HscEnv -> ModLocation -> Module -> IO SummariseResult
k HscEnv
hsc_env HomeUnit
home_unit IsBootInterface
is_boot Located ModuleName
wanted_mod PkgQual
mb_pkg [ModuleName]
excl_mods
  where
    k :: HscEnv -> ModLocation -> Module -> IO SummariseResult
k HscEnv
_hsc_env ModLocation
loc Module
mod = do
      -- The finder will return a path to the .hi-boot even if it doesn't actually
      -- exist. So check if it exists first before concluding it's there.
      Bool
does_exist <- FilePath -> IO Bool
doesFileExist (ModLocation -> FilePath
ml_hi_file ModLocation
loc)
      if Bool
does_exist
        then let key :: ModNodeKeyWithUid
key = Module -> IsBootInterface -> ModNodeKeyWithUid
moduleToMnk Module
mod IsBootInterface
is_boot
             in SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SummariseResult -> IO SummariseResult)
-> SummariseResult -> IO SummariseResult
forall a b. (a -> b) -> a -> b
$ ModuleNodeInfo -> SummariseResult
FoundHome (ModNodeKeyWithUid -> ModLocation -> ModuleNodeInfo
ModuleNodeFixed ModNodeKeyWithUid
key ModLocation
loc)
        else SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere



-- Summarise a module, and pick up source and timestamp.
summariseModuleDispatch
          :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module.
          -> HscEnv
          -> HomeUnit
          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
          -> Located ModuleName -- Imported module to be summarised
          -> PkgQual
          -> [ModuleName]               -- Modules to exclude
          -> IO SummariseResult


summariseModuleDispatch :: (HscEnv -> ModLocation -> Module -> IO SummariseResult)
-> HscEnv
-> HomeUnit
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> [ModuleName]
-> IO SummariseResult
summariseModuleDispatch HscEnv -> ModLocation -> Module -> IO SummariseResult
k HscEnv
hsc_env' HomeUnit
home_unit IsBootInterface
is_boot (L SrcSpan
_ ModuleName
wanted_mod) PkgQual
mb_pkg [ModuleName]
excl_mods
  | ModuleName
wanted_mod ModuleName -> [ModuleName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
excl_mods
  = SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
  | Bool
otherwise  = IO SummariseResult
find_it
  where
    -- Temporarily change the currently active home unit so all operations
    -- happen relative to it
    hsc_env :: HscEnv
hsc_env   = HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit HscEnv
hsc_env'

    find_it :: IO SummariseResult

    find_it :: IO SummariseResult
find_it = do
        FindResult
found <- HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult
findImportedModuleWithIsBoot HscEnv
hsc_env ModuleName
wanted_mod IsBootInterface
is_boot PkgQual
mb_pkg
        case FindResult
found of
             Found ModLocation
location Module
mod
                | Module -> UnitId
moduleUnitId Module
mod UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env ->
                        -- Home package
                         HscEnv -> ModLocation -> Module -> IO SummariseResult
k HscEnv
hsc_env ModLocation
location Module
mod
                | VirtUnit InstantiatedUnit
iud <- Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit Module
mod
                , Bool -> Bool
not (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
mod)
                  -> SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SummariseResult -> IO SummariseResult)
-> SummariseResult -> IO SummariseResult
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> SummariseResult
FoundInstantiation InstantiatedUnit
iud
                | Bool
otherwise -> SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SummariseResult -> IO SummariseResult)
-> SummariseResult -> IO SummariseResult
forall a b. (a -> b) -> a -> b
$ UnitId -> SummariseResult
External (Module -> UnitId
moduleUnitId Module
mod)
             FindResult
_ -> SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
                        -- Not found
                        -- (If it is TRULY not found at all, we'll
                        -- error when we actually try to compile)


-- | The continuation to summarise a home module if we want to find the source file
-- for it and potentially compile it.
summariseModuleWithSource
          :: HomeUnit
          -> M.Map (UnitId, FilePath) ModSummary
          -- ^ Map of old summaries
          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
          -> Maybe (StringBuffer, UTCTime)
          -> HscEnv
          -> ModLocation
          -> Module
          -> IO SummariseResult
summariseModuleWithSource :: HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> Maybe (StringBuffer, UTCTime)
-> HscEnv
-> ModLocation
-> Module
-> IO SummariseResult
summariseModuleWithSource HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map IsBootInterface
is_boot Maybe (StringBuffer, UTCTime)
maybe_buf HscEnv
hsc_env ModLocation
location Module
mod = do
        -- Adjust location to point to the hs-boot source file,
        -- hi file, object file, when is_boot says so
        let src_fn :: FilePath
src_fn = Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
expectJust (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location)

                -- Check that it exists
                -- It might have been deleted since the Finder last found it
        Maybe Fingerprint
maybe_h <- FilePath -> IO (Maybe Fingerprint)
fileHashIfExists FilePath
src_fn
        case Maybe Fingerprint
maybe_h of
          -- This situation can also happen if we have found the .hs file but the
          -- .hs-boot file doesn't exist.
          Maybe Fingerprint
Nothing -> SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
          Just Fingerprint
h  -> do
            Either DriverMessages ModSummary
fresult <- ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary_cache_check ModLocation
location Module
mod FilePath
src_fn Fingerprint
h
            return $ case Either DriverMessages ModSummary
fresult of
              Left DriverMessages
err -> (UnitId, DriverMessages) -> SummariseResult
FoundHomeWithError (Module -> UnitId
moduleUnitId Module
mod, DriverMessages
err)
              Right ModSummary
ms -> ModuleNodeInfo -> SummariseResult
FoundHome (ModSummary -> ModuleNodeInfo
ModuleNodeCompile ModSummary
ms)

  where
    dflags :: DynFlags
dflags    = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    new_summary_cache_check :: ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary_cache_check ModLocation
loc Module
mod FilePath
src_fn Fingerprint
h
      | Just ModSummary
old_summary <- (UnitId, FilePath)
-> Map (UnitId, FilePath) ModSummary -> Maybe ModSummary
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((GenUnit UnitId -> UnitId
toUnitId (Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit Module
mod), FilePath
src_fn)) Map (UnitId, FilePath) ModSummary
old_summary_map =

         -- check the hash on the source file, and
         -- return the cached summary if it hasn't changed.  If the
         -- file has changed then need to resummarise.
        case Maybe (StringBuffer, UTCTime)
maybe_buf of
           Just (StringBuffer
buf,UTCTime
_) ->
               HscEnv
-> (Fingerprint -> IO (Either DriverMessages ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash HscEnv
hsc_env (ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn) ModSummary
old_summary ModLocation
loc (StringBuffer -> Fingerprint
fingerprintStringBuffer StringBuffer
buf)
           Maybe (StringBuffer, UTCTime)
Nothing    ->
               HscEnv
-> (Fingerprint -> IO (Either DriverMessages ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash HscEnv
hsc_env (ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn) ModSummary
old_summary ModLocation
loc Fingerprint
h
      | Bool
otherwise = ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn Fingerprint
h

    new_summary :: ModLocation
                  -> Module
                  -> FilePath
                  -> Fingerprint
                  -> IO (Either DriverMessages ModSummary)
    new_summary :: ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
location Module
mod FilePath
src_fn Fingerprint
src_hash
      = ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DriverMessages IO ModSummary
 -> IO (Either DriverMessages ModSummary))
-> ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ do
        preimps :: PreprocessedImports
preimps@PreprocessedImports {FilePath
[(PkgQual, Located ModuleName)]
ModuleName
StringBuffer
SrcSpan
DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> StringBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_theimps :: PreprocessedImports -> [(PkgQual, Located ModuleName)]
pi_srcimps :: PreprocessedImports -> [(PkgQual, Located ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
pi_local_dflags :: DynFlags
pi_srcimps :: [(PkgQual, Located ModuleName)]
pi_theimps :: [(PkgQual, Located ModuleName)]
pi_hspp_fn :: FilePath
pi_hspp_buf :: StringBuffer
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
..}
            -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP
            -- See multiHomeUnits_cpp2 test
            <- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports (HasDebugCallStack => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (Module -> UnitId
moduleUnitId Module
mod) HscEnv
hsc_env) FilePath
src_fn Maybe Phase
forall a. Maybe a
Nothing Maybe (StringBuffer, UTCTime)
maybe_buf

        -- NB: Despite the fact that is_boot is a top-level parameter, we
        -- don't actually know coming into this function what the HscSource
        -- of the module in question is.  This is because we may be processing
        -- this module because another module in the graph imported it: in this
        -- case, we know if it's a boot or not because of the {-# SOURCE #-}
        -- annotation, but we don't know if it's a signature or a regular
        -- module until we actually look it up on the filesystem.
        let hsc_src :: HscSource
hsc_src
              | IsBootInterface
is_boot IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot           = HscSource
HsBootFile
              | FilePath -> Bool
isHaskellSigFilename FilePath
src_fn = HscSource
HsigFile
              | Bool
otherwise                   = HscSource
HsSrcFile

        Bool
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
pi_mod_name ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) (ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ())
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$
                DriverMessages -> ExceptT DriverMessages IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DriverMessages -> ExceptT DriverMessages IO ())
-> DriverMessages -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
pi_mod_name_loc
                       (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleName -> DriverMessage
DriverFileModuleNameMismatch ModuleName
pi_mod_name (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)

        let instantiations :: GenInstantiations UnitId
instantiations = HomeUnit -> GenInstantiations UnitId
forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit
        Bool
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& Maybe Module -> Bool
forall a. Maybe a -> Bool
isNothing (ModuleName -> GenInstantiations UnitId -> Maybe Module
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
pi_mod_name GenInstantiations UnitId
instantiations)) (ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ())
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$
            DriverMessages -> ExceptT DriverMessages IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DriverMessages -> ExceptT DriverMessages IO ())
-> DriverMessages -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
pi_mod_name_loc
                   (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ ModuleName
-> BuildingCabalPackage
-> GenInstantiations UnitId
-> DriverMessage
DriverUnexpectedSignature ModuleName
pi_mod_name (DynFlags -> BuildingCabalPackage
checkBuildingCabalPackage DynFlags
dflags) GenInstantiations UnitId
instantiations

        IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> ExceptT DriverMessages IO ModSummary)
-> IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env (MakeNewModSummary -> IO ModSummary)
-> MakeNewModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
            { nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
            , nms_src_hash :: Fingerprint
nms_src_hash = Fingerprint
src_hash
            , nms_hsc_src :: HscSource
nms_hsc_src = HscSource
hsc_src
            , nms_location :: ModLocation
nms_location = ModLocation
location
            , nms_mod :: Module
nms_mod = Module
mod
            , nms_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
            }

-- | Convenience named arguments for 'makeNewModSummary' only used to make
-- code more readable, not exported.
data MakeNewModSummary
  = MakeNewModSummary
      { MakeNewModSummary -> FilePath
nms_src_fn :: FilePath
      , MakeNewModSummary -> Fingerprint
nms_src_hash :: Fingerprint
      , MakeNewModSummary -> HscSource
nms_hsc_src :: HscSource
      , MakeNewModSummary -> ModLocation
nms_location :: ModLocation
      , MakeNewModSummary -> Module
nms_mod :: Module
      , MakeNewModSummary -> PreprocessedImports
nms_preimps :: PreprocessedImports
      }

makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env MakeNewModSummary{FilePath
Fingerprint
Module
ModLocation
HscSource
PreprocessedImports
nms_src_fn :: MakeNewModSummary -> FilePath
nms_src_hash :: MakeNewModSummary -> Fingerprint
nms_hsc_src :: MakeNewModSummary -> HscSource
nms_location :: MakeNewModSummary -> ModLocation
nms_mod :: MakeNewModSummary -> Module
nms_preimps :: MakeNewModSummary -> PreprocessedImports
nms_src_fn :: FilePath
nms_src_hash :: Fingerprint
nms_hsc_src :: HscSource
nms_location :: ModLocation
nms_mod :: Module
nms_preimps :: PreprocessedImports
..} = do
  let PreprocessedImports{FilePath
[(PkgQual, Located ModuleName)]
ModuleName
StringBuffer
SrcSpan
DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> StringBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_theimps :: PreprocessedImports -> [(PkgQual, Located ModuleName)]
pi_srcimps :: PreprocessedImports -> [(PkgQual, Located ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
pi_local_dflags :: DynFlags
pi_srcimps :: [(PkgQual, Located ModuleName)]
pi_theimps :: [(PkgQual, Located ModuleName)]
pi_hspp_fn :: FilePath
pi_hspp_buf :: StringBuffer
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
..} = PreprocessedImports
nms_preimps
  Maybe UTCTime
obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_obj_file ModLocation
nms_location)
  Maybe UTCTime
dyn_obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_dyn_obj_file ModLocation
nms_location)
  Maybe UTCTime
hi_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
nms_location)
  Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
nms_location)

  [ModuleName]
extra_sig_imports <- HscEnv -> HscSource -> ModuleName -> IO [ModuleName]
findExtraSigImports HscEnv
hsc_env HscSource
nms_hsc_src ModuleName
pi_mod_name
  ([ModuleName]
implicit_sigs, [InstantiatedUnit]
_inst_deps) <- HscEnv
-> [(PkgQual, Located ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow (HasDebugCallStack => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (Module -> UnitId
moduleUnitId Module
nms_mod) HscEnv
hsc_env) [(PkgQual, Located ModuleName)]
pi_theimps

  return $
        ModSummary
        { ms_mod :: Module
ms_mod = Module
nms_mod
        , ms_hsc_src :: HscSource
ms_hsc_src = HscSource
nms_hsc_src
        , ms_location :: ModLocation
ms_location = ModLocation
nms_location
        , ms_hspp_file :: FilePath
ms_hspp_file = FilePath
pi_hspp_fn
        , ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
pi_local_dflags
        , ms_hspp_buf :: Maybe StringBuffer
ms_hspp_buf  = StringBuffer -> Maybe StringBuffer
forall a. a -> Maybe a
Just StringBuffer
pi_hspp_buf
        , ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = Maybe HsParsedModule
forall a. Maybe a
Nothing
        , ms_srcimps :: [(PkgQual, Located ModuleName)]
ms_srcimps = [(PkgQual, Located ModuleName)]
pi_srcimps
        , ms_textual_imps :: [(PkgQual, Located ModuleName)]
ms_textual_imps =
            ((,) PkgQual
NoPkgQual (Located ModuleName -> (PkgQual, Located ModuleName))
-> (ModuleName -> Located ModuleName)
-> ModuleName
-> (PkgQual, Located ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Located ModuleName
forall e. e -> Located e
noLoc (ModuleName -> (PkgQual, Located ModuleName))
-> [ModuleName] -> [(PkgQual, Located ModuleName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
extra_sig_imports) [(PkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
forall a. [a] -> [a] -> [a]
++
            ((,) PkgQual
NoPkgQual (Located ModuleName -> (PkgQual, Located ModuleName))
-> (ModuleName -> Located ModuleName)
-> ModuleName
-> (PkgQual, Located ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Located ModuleName
forall e. e -> Located e
noLoc (ModuleName -> (PkgQual, Located ModuleName))
-> [ModuleName] -> [(PkgQual, Located ModuleName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
implicit_sigs) [(PkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
forall a. [a] -> [a] -> [a]
++
            [(PkgQual, Located ModuleName)]
pi_theimps
        , ms_hs_hash :: Fingerprint
ms_hs_hash = Fingerprint
nms_src_hash
        , ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
        , ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
        , ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
        , ms_dyn_obj_date :: Maybe UTCTime
ms_dyn_obj_date = Maybe UTCTime
dyn_obj_timestamp
        }

data PreprocessedImports
  = PreprocessedImports
      { PreprocessedImports -> DynFlags
pi_local_dflags :: DynFlags
      , PreprocessedImports -> [(PkgQual, Located ModuleName)]
pi_srcimps  :: [(PkgQual, Located ModuleName)]
      , PreprocessedImports -> [(PkgQual, Located ModuleName)]
pi_theimps  :: [(PkgQual, Located ModuleName)]
      , PreprocessedImports -> FilePath
pi_hspp_fn  :: FilePath
      , PreprocessedImports -> StringBuffer
pi_hspp_buf :: StringBuffer
      , PreprocessedImports -> SrcSpan
pi_mod_name_loc :: SrcSpan
      , PreprocessedImports -> ModuleName
pi_mod_name :: ModuleName
      }

-- Preprocess the source file and get its imports
-- The pi_local_dflags contains the OPTIONS pragmas
getPreprocessedImports
    :: HscEnv
    -> FilePath
    -> Maybe Phase
    -> Maybe (StringBuffer, UTCTime)
    -- ^ optional source code buffer and modification time
    -> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports :: HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (StringBuffer, UTCTime)
maybe_buf = do
  (DynFlags
pi_local_dflags, FilePath
pi_hspp_fn)
      <- IO (Either DriverMessages (DynFlags, FilePath))
-> ExceptT DriverMessages IO (DynFlags, FilePath)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either DriverMessages (DynFlags, FilePath))
 -> ExceptT DriverMessages IO (DynFlags, FilePath))
-> IO (Either DriverMessages (DynFlags, FilePath))
-> ExceptT DriverMessages IO (DynFlags, FilePath)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> Maybe StringBuffer
-> Maybe Phase
-> IO (Either DriverMessages (DynFlags, FilePath))
preprocess HscEnv
hsc_env FilePath
src_fn ((StringBuffer, UTCTime) -> StringBuffer
forall a b. (a, b) -> a
fst ((StringBuffer, UTCTime) -> StringBuffer)
-> Maybe (StringBuffer, UTCTime) -> Maybe StringBuffer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (StringBuffer, UTCTime)
maybe_buf) Maybe Phase
mb_phase
  StringBuffer
pi_hspp_buf <- IO StringBuffer -> ExceptT DriverMessages IO StringBuffer
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StringBuffer -> ExceptT DriverMessages IO StringBuffer)
-> IO StringBuffer -> ExceptT DriverMessages IO StringBuffer
forall a b. (a -> b) -> a -> b
$ FilePath -> IO StringBuffer
hGetStringBuffer FilePath
pi_hspp_fn
  ([(RawPkgQual, Located ModuleName)]
pi_srcimps', [(RawPkgQual, Located ModuleName)]
pi_theimps', L SrcSpan
pi_mod_name_loc ModuleName
pi_mod_name)
      <- IO
  (Either
     DriverMessages
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Located ModuleName))
-> ExceptT
     DriverMessages
     IO
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Located ModuleName)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO
   (Either
      DriverMessages
      ([(RawPkgQual, Located ModuleName)],
       [(RawPkgQual, Located ModuleName)], Located ModuleName))
 -> ExceptT
      DriverMessages
      IO
      ([(RawPkgQual, Located ModuleName)],
       [(RawPkgQual, Located ModuleName)], Located ModuleName))
-> IO
     (Either
        DriverMessages
        ([(RawPkgQual, Located ModuleName)],
         [(RawPkgQual, Located ModuleName)], Located ModuleName))
-> ExceptT
     DriverMessages
     IO
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Located ModuleName)
forall a b. (a -> b) -> a -> b
$ do
          let imp_prelude :: Bool
imp_prelude = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitPrelude DynFlags
pi_local_dflags
              popts :: ParserOpts
popts = DynFlags -> ParserOpts
initParserOpts DynFlags
pi_local_dflags
          Either
  (Messages PsMessage)
  ([(RawPkgQual, Located ModuleName)],
   [(RawPkgQual, Located ModuleName)], Located ModuleName)
mimps <- ParserOpts
-> Bool
-> StringBuffer
-> FilePath
-> FilePath
-> IO
     (Either
        (Messages PsMessage)
        ([(RawPkgQual, Located ModuleName)],
         [(RawPkgQual, Located ModuleName)], Located ModuleName))
getImports ParserOpts
popts Bool
imp_prelude StringBuffer
pi_hspp_buf FilePath
pi_hspp_fn FilePath
src_fn
          return ((Messages PsMessage -> DriverMessages)
-> Either
     (Messages PsMessage)
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Located ModuleName)
-> Either
     DriverMessages
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Located ModuleName)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Bag (MsgEnvelope DriverMessage) -> DriverMessages
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope DriverMessage) -> DriverMessages)
-> (Messages PsMessage -> Bag (MsgEnvelope DriverMessage))
-> Messages PsMessage
-> DriverMessages
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgEnvelope PsMessage -> MsgEnvelope DriverMessage)
-> Bag (MsgEnvelope PsMessage) -> Bag (MsgEnvelope DriverMessage)
forall a b. (a -> b) -> Bag a -> Bag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
mkDriverPsHeaderMessage (Bag (MsgEnvelope PsMessage) -> Bag (MsgEnvelope DriverMessage))
-> (Messages PsMessage -> Bag (MsgEnvelope PsMessage))
-> Messages PsMessage
-> Bag (MsgEnvelope DriverMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages PsMessage -> Bag (MsgEnvelope PsMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages) Either
  (Messages PsMessage)
  ([(RawPkgQual, Located ModuleName)],
   [(RawPkgQual, Located ModuleName)], Located ModuleName)
mimps)
  let rn_pkg_qual :: ModuleName -> RawPkgQual -> PkgQual
rn_pkg_qual = UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
renameRawPkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
  let rn_imps :: [(RawPkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
rn_imps = ((RawPkgQual, Located ModuleName) -> (PkgQual, Located ModuleName))
-> [(RawPkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(RawPkgQual
pk, lmn :: Located ModuleName
lmn@(L SrcSpan
_ ModuleName
mn)) -> (ModuleName -> RawPkgQual -> PkgQual
rn_pkg_qual ModuleName
mn RawPkgQual
pk, Located ModuleName
lmn))
  let pi_srcimps :: [(PkgQual, Located ModuleName)]
pi_srcimps = [(RawPkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
rn_imps [(RawPkgQual, Located ModuleName)]
pi_srcimps'
  let pi_theimps :: [(PkgQual, Located ModuleName)]
pi_theimps = [(RawPkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
rn_imps [(RawPkgQual, Located ModuleName)]
pi_theimps'
  PreprocessedImports
-> ExceptT DriverMessages IO PreprocessedImports
forall a. a -> ExceptT DriverMessages IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return PreprocessedImports {FilePath
[(PkgQual, Located ModuleName)]
ModuleName
StringBuffer
SrcSpan
DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: StringBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(PkgQual, Located ModuleName)]
pi_srcimps :: [(PkgQual, Located ModuleName)]
pi_local_dflags :: DynFlags
pi_local_dflags :: DynFlags
pi_hspp_fn :: FilePath
pi_hspp_buf :: StringBuffer
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
pi_srcimps :: [(PkgQual, Located ModuleName)]
pi_theimps :: [(PkgQual, Located ModuleName)]
..}