{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2011
--
-- This module implements multi-module compilation, and is used
-- by --make and GHCi.
--
-- -----------------------------------------------------------------------------
module GHC.Driver.Make (
        depanal, depanalE, depanalPartial,
        load, load', LoadHowMuch(..),
        instantiationNodes,

        downsweep,

        topSortModuleGraph,

        ms_home_srcimps, ms_home_imps,

        summariseModule,
        hscSourceToIsBoot,
        findExtraSigImports,
        implicitRequirementsShallow,

        noModError, cyclicModuleErr,
        moduleGraphNodes, SummaryNode,
        IsBootInterface(..),

        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert
    ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Tc.Utils.Backpack
import GHC.Tc.Utils.Monad  ( initIfaceCheck )

import GHC.Runtime.Interpreter
import qualified GHC.Linker.Loader as Linker
import GHC.Linker.Types

import GHC.Runtime.Context

import GHC.Driver.Config
import GHC.Driver.Phases
import GHC.Driver.Pipeline
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Monad
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Main

import GHC.Parser.Header
import GHC.Parser.Errors.Ppr

import GHC.Iface.Load      ( cannotFindModule )
import GHC.IfaceToCore     ( typecheckIface )
import GHC.Iface.Recomp    ( RecompileRequired ( MustCompile ) )

import GHC.Data.Bag        ( unitBag, listToBag, unionManyBags, isEmptyBag )
import GHC.Data.Graph.Directed
import GHC.Data.FastString
import GHC.Data.Maybe      ( expectJust )
import GHC.Data.StringBuffer
import qualified GHC.LanguageExtensions as LangExt

import GHC.Utils.Exception ( tryIO )
import GHC.Utils.Monad     ( allM )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.TmpFs

import GHC.Types.Basic
import GHC.Types.Target
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet
import GHC.Types.Unique.Set
import GHC.Types.Name
import GHC.Types.Name.Env

import GHC.Unit
import GHC.Unit.State
import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo

import Data.Either ( rights, partitionEithers )
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import qualified GHC.Data.FiniteMap as Map ( insertListWith )

import Control.Concurrent ( forkIOWithUnmask, killThread )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import qualified Control.Monad.Catch as MC
import Data.IORef
import Data.List (nub, sortBy, partition)
import qualified Data.List as List
import Data.Foldable (toList)
import Data.Maybe
import Data.Ord ( comparing )
import Data.Time
import Data.Bifunctor (first)
import System.Directory
import System.FilePath
import System.IO        ( fixIO )
import System.IO.Error  ( isDoesNotExistError )

import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )

label_self :: String -> IO ()
label_self :: FilePath -> IO ()
label_self FilePath
thread_name = do
    ThreadId
self_tid <- IO ThreadId
CC.myThreadId
    ThreadId -> FilePath -> IO ()
CC.labelThread ThreadId
self_tid FilePath
thread_name

-- -----------------------------------------------------------------------------
-- Loading the program

-- | Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
--
-- Dependency analysis entails parsing the @import@ directives and may
-- therefore require running certain preprocessors.
--
-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want
-- changes to the 'DynFlags' to take effect you need to call this function
-- again.
-- In case of errors, just throw them.
--
depanal :: GhcMonad m =>
           [ModuleName]  -- ^ excluded modules
        -> Bool          -- ^ allow duplicate roots
        -> m ModuleGraph
depanal :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [ModuleName]
excluded_mods Bool
allow_dup_roots = do
    (ErrorMessages
errs, ModuleGraph
mod_graph) <- [ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots
    if ErrorMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
      then ModuleGraph -> m ModuleGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleGraph
mod_graph
      else ErrorMessages -> m ModuleGraph
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
errs

-- | Perform dependency analysis like in 'depanal'.
-- In case of errors, the errors and an empty module graph are returned.
depanalE :: GhcMonad m =>     -- New for #17459
            [ModuleName]      -- ^ excluded modules
            -> Bool           -- ^ allow duplicate roots
            -> m (ErrorMessages, ModuleGraph)
depanalE :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    (ErrorMessages
errs, ModuleGraph
mod_graph) <- [ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots
    if ErrorMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
      then do
        let unused_home_mod_err :: [MsgEnvelope DecoratedSDoc]
unused_home_mod_err = HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnMissingHomeModules HscEnv
hsc_env ModuleGraph
mod_graph
            unused_pkg_err :: [MsgEnvelope DecoratedSDoc]
unused_pkg_err = HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnUnusedPackages HscEnv
hsc_env ModuleGraph
mod_graph
            warns :: [MsgEnvelope DecoratedSDoc]
warns = [MsgEnvelope DecoratedSDoc]
unused_home_mod_err [MsgEnvelope DecoratedSDoc]
-> [MsgEnvelope DecoratedSDoc] -> [MsgEnvelope DecoratedSDoc]
forall a. [a] -> [a] -> [a]
++ [MsgEnvelope DecoratedSDoc]
unused_pkg_err
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope DecoratedSDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MsgEnvelope DecoratedSDoc]
warns) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          ErrorMessages -> m ()
forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings ([MsgEnvelope DecoratedSDoc] -> ErrorMessages
forall a. [a] -> Bag a
listToBag [MsgEnvelope DecoratedSDoc]
warns)
        HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
        (ErrorMessages, ModuleGraph) -> m (ErrorMessages, ModuleGraph)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ErrorMessages
errs, ModuleGraph
mod_graph)
      else do
        -- We don't have a complete module dependency graph,
        -- The graph may be disconnected and is unusable.
        HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
emptyMG }
        (ErrorMessages, ModuleGraph) -> m (ErrorMessages, ModuleGraph)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ErrorMessages
errs, ModuleGraph
emptyMG)


-- | Perform dependency analysis like 'depanal' but return a partial module
-- graph even in the face of problems with some modules.
--
-- Modules which have parse errors in the module header, failing
-- preprocessors or other issues preventing them from being summarised will
-- simply be absent from the returned module graph.
--
-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the
-- new module graph.
depanalPartial
    :: GhcMonad m
    => [ModuleName]  -- ^ excluded modules
    -> Bool          -- ^ allow duplicate roots
    -> m (ErrorMessages, ModuleGraph)
    -- ^ possibly empty 'Bag' of errors and a module graph.
depanalPartial :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let
         dflags :: DynFlags
dflags  = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
         targets :: [Target]
targets = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
         old_graph :: ModuleGraph
old_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env
         logger :: Logger
logger  = HscEnv -> Logger
hsc_logger HscEnv
hsc_env

  Logger
-> DynFlags
-> SDoc
-> ((ErrorMessages, ModuleGraph) -> ())
-> m (ErrorMessages, ModuleGraph)
-> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags (FilePath -> SDoc
text FilePath
"Chasing dependencies") (() -> (ErrorMessages, ModuleGraph) -> ()
forall a b. a -> b -> a
const ()) (m (ErrorMessages, ModuleGraph) -> m (ErrorMessages, ModuleGraph))
-> m (ErrorMessages, ModuleGraph) -> m (ErrorMessages, ModuleGraph)
forall a b. (a -> b) -> a -> b
$ do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 ([SDoc] -> SDoc
hcat [
              FilePath -> SDoc
text FilePath
"Chasing modules from: ",
              [SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ((Target -> SDoc) -> [Target] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Target -> SDoc
pprTarget [Target]
targets))])

    -- Home package modules may have been moved or deleted, and new
    -- source files may have appeared in the home package that shadow
    -- external package modules, so we have to discard the existing
    -- cached finder data.
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
flushFinderCaches HscEnv
hsc_env

    [Either ErrorMessages ExtendedModSummary]
mod_summariesE <- IO [Either ErrorMessages ExtendedModSummary]
-> m [Either ErrorMessages ExtendedModSummary]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either ErrorMessages ExtendedModSummary]
 -> m [Either ErrorMessages ExtendedModSummary])
-> IO [Either ErrorMessages ExtendedModSummary]
-> m [Either ErrorMessages ExtendedModSummary]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [ExtendedModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ExtendedModSummary]
downsweep
      HscEnv
hsc_env (ModuleGraph -> [ExtendedModSummary]
mgExtendedModSummaries ModuleGraph
old_graph)
      [ModuleName]
excluded_mods Bool
allow_dup_roots
    let
      ([ErrorMessages]
errs, [ExtendedModSummary]
mod_summaries) = [Either ErrorMessages ExtendedModSummary]
-> ([ErrorMessages], [ExtendedModSummary])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ErrorMessages ExtendedModSummary]
mod_summariesE
      mod_graph :: ModuleGraph
mod_graph = [ModuleGraphNode] -> ModuleGraph
mkModuleGraph' ([ModuleGraphNode] -> ModuleGraph)
-> [ModuleGraphNode] -> ModuleGraph
forall a b. (a -> b) -> a -> b
$
        (ExtendedModSummary -> ModuleGraphNode)
-> [ExtendedModSummary] -> [ModuleGraphNode]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtendedModSummary -> ModuleGraphNode
ModuleNode [ExtendedModSummary]
mod_summaries [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ UnitState -> [ModuleGraphNode]
instantiationNodes (HscEnv -> UnitState
hsc_units HscEnv
hsc_env)
    (ErrorMessages, ModuleGraph) -> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ErrorMessages] -> ErrorMessages
forall a. [Bag a] -> Bag a
unionManyBags [ErrorMessages]
errs, ModuleGraph
mod_graph)

-- | 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.
--
-- In the future, perhaps more of the work of instantiation could be moved here,
-- instead of shoved in with the module compilation nodes. That could simplify
-- backpack, and maybe hs-boot too.
instantiationNodes :: UnitState -> [ModuleGraphNode]
instantiationNodes :: UnitState -> [ModuleGraphNode]
instantiationNodes UnitState
unit_state = InstantiatedUnit -> ModuleGraphNode
InstantiationNode (InstantiatedUnit -> ModuleGraphNode)
-> [InstantiatedUnit] -> [ModuleGraphNode]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [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
$ (Unit -> [InstantiatedUnit]) -> [Unit] -> [InstantiatedUnit]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Unit -> [InstantiatedUnit]
forall {unit}. GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId (UnitState -> [Unit]
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
        ]

-- Note [Missing home modules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed
-- in a command line. For example, cabal may want to enable this warning
-- when building a library, so that GHC warns user about modules, not listed
-- neither in `exposed-modules`, nor in `other-modules`.
--
-- Here "home module" means a module, that doesn't come from an other package.
--
-- For example, if GHC is invoked with modules "A" and "B" as targets,
-- but "A" imports some other module "C", then GHC will issue a warning
-- about module "C" not being listed in a command line.
--
-- The warning in enabled by `-Wmissing-home-modules`. See #13129
warnMissingHomeModules :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnMissingHomeModules :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnMissingHomeModules HscEnv
hsc_env ModuleGraph
mod_graph =
    if (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingHomeModules DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not ([ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
missing))
    then [MsgEnvelope DecoratedSDoc
warn]
    else []
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    targets :: [TargetId]
targets = (Target -> TargetId) -> [Target] -> [TargetId]
forall a b. (a -> b) -> [a] -> [b]
map Target -> TargetId
targetId (HscEnv -> [Target]
hsc_targets HscEnv
hsc_env)

    is_known_module :: ModSummary -> Bool
is_known_module ModSummary
mod = (TargetId -> Bool) -> [TargetId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ModSummary -> TargetId -> Bool
is_my_target ModSummary
mod) [TargetId]
targets

    -- We need to be careful to handle the case where (possibly
    -- path-qualified) filenames (aka 'TargetFile') rather than module
    -- names are being passed on the GHC command-line.
    --
    -- For instance, `ghc --make src-exe/Main.hs` and
    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.
    -- Note also that we can't always infer the associated module name
    -- directly from the filename argument.  See #13727.
    is_my_target :: ModSummary -> TargetId -> Bool
is_my_target ModSummary
mod (TargetModule ModuleName
name)
      = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
name
    is_my_target ModSummary
mod (TargetFile FilePath
target_file Maybe Phase
_)
      | Just FilePath
mod_file <- ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod)
      = FilePath
target_file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
mod_file Bool -> Bool -> Bool
||

           --  Don't warn on B.hs-boot if B.hs is specified (#16551)
           FilePath -> FilePath
addBootSuffix FilePath
target_file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
mod_file Bool -> Bool -> Bool
||

           --  We can get a file target even if a module name was
           --  originally specified in a command line because it can
           --  be converted in guessTarget (by appending .hs/.lhs).
           --  So let's convert it back and compare with module name
           FilePath -> ModuleName
mkModuleName ((FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath) -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> (FilePath, FilePath)
splitExtension FilePath
target_file)
            ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod)
    is_my_target ModSummary
_ TargetId
_ = Bool
False

    missing :: [ModuleName]
missing = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) ([ModSummary] -> [ModuleName]) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
      (ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ModSummary -> Bool) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Bool
is_known_module) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)

    msg :: SDoc
msg
      | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildingCabalPackage DynFlags
dflags
      = SDoc -> Int -> SDoc -> SDoc
hang
          (FilePath -> SDoc
text FilePath
"These modules are needed for compilation but not listed in your .cabal file's other-modules: ")
          Int
4
          ([SDoc] -> SDoc
sep ((ModuleName -> SDoc) -> [ModuleName] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
missing))
      | Bool
otherwise
      =
        SDoc -> Int -> SDoc -> SDoc
hang
          (FilePath -> SDoc
text FilePath
"Modules are not listed in command line but needed for compilation: ")
          Int
4
          ([SDoc] -> SDoc
sep ((ModuleName -> SDoc) -> [ModuleName] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
missing))
    warn :: MsgEnvelope DecoratedSDoc
warn = WarnReason
-> MsgEnvelope DecoratedSDoc -> MsgEnvelope DecoratedSDoc
forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning
      (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingHomeModules)
      (SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan SDoc
msg)

-- | Describes which modules of the module graph need to be loaded.
data LoadHowMuch
   = LoadAllTargets
     -- ^ Load all targets and its dependencies.
   | LoadUpTo ModuleName
     -- ^ Load only the given module and its dependencies.
   | LoadDependenciesOf ModuleName
     -- ^ Load only the dependencies of the given module, but not the module
     -- itself.

-- | Try to load the program.  See 'LoadHowMuch' for the different modes.
--
-- This function implements the core of GHC's @--make@ mode.  It preprocesses,
-- compiles and loads the specified modules, avoiding re-compilation wherever
-- possible.  Depending on the backend (see 'DynFlags.backend' field) compiling
-- and loading may result in files being created on disk.
--
-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether
-- successful or not.
--
-- If errors are encountered during dependency analysis, the module `depanalE`
-- returns together with the errors an empty ModuleGraph.
-- After processing this empty ModuleGraph, the errors of depanalE are thrown.
-- All other errors are reported using the 'defaultWarnErrLogger'.
--
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load :: forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
how_much = do
    (ErrorMessages
errs, ModuleGraph
mod_graph) <- [ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalE [] Bool
False                        -- #17459
    SuccessFlag
success <- LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
how_much (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
batchMsg) ModuleGraph
mod_graph
    if ErrorMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
      then SuccessFlag -> m SuccessFlag
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
success
      else ErrorMessages -> m SuccessFlag
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
errs

-- Note [Unused packages]
--
-- Cabal passes `--package-id` flag for each direct dependency. But GHC
-- loads them lazily, so when compilation is done, we have a list of all
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.

warnUnusedPackages :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnUnusedPackages :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnUnusedPackages HscEnv
hsc_env ModuleGraph
mod_graph =
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        state :: UnitState
state  = HscEnv -> UnitState
hsc_units HscEnv
hsc_env

    -- Only need non-source imports here because SOURCE imports are always HPT
        loadedPackages :: [UnitInfo]
loadedPackages = [[UnitInfo]] -> [UnitInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[UnitInfo]] -> [UnitInfo]) -> [[UnitInfo]] -> [UnitInfo]
forall a b. (a -> b) -> a -> b
$
          ((Maybe FastString, GenLocated SrcSpan ModuleName)
 -> Maybe [UnitInfo])
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [[UnitInfo]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Maybe FastString
fs, GenLocated SrcSpan ModuleName
mn) -> UnitState -> ModuleName -> Maybe FastString -> Maybe [UnitInfo]
lookupModulePackage UnitState
state (GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
mn) Maybe FastString
fs)
            ([(Maybe FastString, GenLocated SrcSpan ModuleName)]
 -> [[UnitInfo]])
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [[UnitInfo]]
forall a b. (a -> b) -> a -> b
$ (ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)])
-> [ModSummary]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_imps (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)

        requestedArgs :: [PackageArg]
requestedArgs = (PackageFlag -> Maybe PackageArg) -> [PackageFlag] -> [PackageArg]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PackageFlag -> Maybe PackageArg
packageArg (DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags)

        unusedArgs :: [PackageArg]
unusedArgs
          = (PackageArg -> Bool) -> [PackageArg] -> [PackageArg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PackageArg
arg -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> Bool) -> [UnitInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UnitState -> PackageArg -> UnitInfo -> Bool
matching UnitState
state PackageArg
arg) [UnitInfo]
loadedPackages)
                   [PackageArg]
requestedArgs

        warn :: MsgEnvelope DecoratedSDoc
warn = WarnReason
-> MsgEnvelope DecoratedSDoc -> MsgEnvelope DecoratedSDoc
forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning
          (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnusedPackages)
          (SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan SDoc
msg)
        msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ FilePath -> SDoc
text FilePath
"The following packages were specified" SDoc -> SDoc -> SDoc
<+>
                     FilePath -> SDoc
text FilePath
"via -package or -package-id flags,"
                   , FilePath -> SDoc
text FilePath
"but were not needed for compilation:"
                   , Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat ((PackageArg -> SDoc) -> [PackageArg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
withDash (SDoc -> SDoc) -> (PackageArg -> SDoc) -> PackageArg -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageArg -> SDoc
pprUnusedArg) [PackageArg]
unusedArgs)) ]

    in if Bool -> Bool
not ([PackageArg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageArg]
unusedArgs) Bool -> Bool -> Bool
&& WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnusedPackages DynFlags
dflags
       then [MsgEnvelope DecoratedSDoc
warn]
       else []

    where
        packageArg :: PackageFlag -> Maybe PackageArg
packageArg (ExposePackage FilePath
_ PackageArg
arg ModRenaming
_) = PackageArg -> Maybe PackageArg
forall a. a -> Maybe a
Just PackageArg
arg
        packageArg PackageFlag
_ = Maybe PackageArg
forall a. Maybe a
Nothing

        pprUnusedArg :: PackageArg -> SDoc
pprUnusedArg (PackageArg FilePath
str) = FilePath -> SDoc
text FilePath
str
        pprUnusedArg (UnitIdArg Unit
uid) = Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
uid

        withDash :: SDoc -> SDoc
withDash = SDoc -> SDoc -> SDoc
(<+>) (FilePath -> SDoc
text FilePath
"-")

        matchingStr :: String -> UnitInfo -> Bool
        matchingStr :: FilePath -> UnitInfo -> Bool
matchingStr FilePath
str UnitInfo
p
                =  FilePath
str FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> FilePath
forall u. GenUnitInfo u -> FilePath
unitPackageIdString UnitInfo
p
                Bool -> Bool -> Bool
|| FilePath
str FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> FilePath
forall u. GenUnitInfo u -> FilePath
unitPackageNameString UnitInfo
p

        matching :: UnitState -> PackageArg -> UnitInfo -> Bool
        matching :: UnitState -> PackageArg -> UnitInfo -> Bool
matching UnitState
_ (PackageArg FilePath
str) UnitInfo
p = FilePath -> UnitInfo -> Bool
matchingStr FilePath
str UnitInfo
p
        matching UnitState
state (UnitIdArg Unit
uid) UnitInfo
p = Unit
uid Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== UnitState -> UnitInfo -> Unit
realUnit UnitState
state UnitInfo
p

        -- For wired-in packages, we have to unwire their id,
        -- otherwise they won't match package flags
        realUnit :: UnitState -> UnitInfo -> Unit
        realUnit :: UnitState -> UnitInfo -> Unit
realUnit UnitState
state
          = UnitState -> Unit -> Unit
unwireUnit UnitState
state
          (Unit -> Unit) -> (UnitInfo -> Unit) -> UnitInfo -> Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit
          (Definite UnitId -> Unit)
-> (UnitInfo -> Definite UnitId) -> UnitInfo -> Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite
          (UnitId -> Definite UnitId)
-> (UnitInfo -> UnitId) -> UnitInfo -> Definite UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId

-- | Generalized version of 'load' which also supports a custom
-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
-- produced by calling 'depanal'.
load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' :: forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
how_much Maybe Messager
mHscMessage ModuleGraph
mod_graph = do
    (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
    m ()
forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

    let hpt1 :: HomePackageTable
hpt1   = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env

    -- The "bad" boot modules are the ones for which we have
    -- B.hs-boot in the module graph, but no B.hs
    -- The downsweep should have ensured this does not happen
    -- (see msDeps)
    let all_home_mods :: UniqSet ModuleName
all_home_mods =
          [ModuleName] -> UniqSet ModuleName
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [ ModSummary -> ModuleName
ms_mod_name ModSummary
s
                    | ModSummary
s <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph, ModSummary -> IsBootInterface
isBootSummary ModSummary
s IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot]
    -- TODO: Figure out what the correct form of this assert is. It's violated
    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot
    -- files without corresponding hs files.
    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
    --                              not (ms_mod_name s `elem` all_home_mods)]
    -- ASSERT( null bad_boot_mods ) return ()

    -- check that the module given in HowMuch actually exists, otherwise
    -- topSortModuleGraph will bomb later.
    let checkHowMuch :: LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch (LoadUpTo ModuleName
m)           = ModuleName -> m SuccessFlag -> m SuccessFlag
checkMod ModuleName
m
        checkHowMuch (LoadDependenciesOf ModuleName
m) = ModuleName -> m SuccessFlag -> m SuccessFlag
checkMod ModuleName
m
        checkHowMuch LoadHowMuch
_ = m SuccessFlag -> m SuccessFlag
forall a. a -> a
id

        checkMod :: ModuleName -> m SuccessFlag -> m SuccessFlag
checkMod ModuleName
m m SuccessFlag
and_then
            | ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
all_home_mods = m SuccessFlag
and_then
            | Bool
otherwise = do
                    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
errorMsg Logger
logger DynFlags
dflags
                        (FilePath -> SDoc
text FilePath
"no such module:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m))
                    SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed

    LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch LoadHowMuch
how_much (m SuccessFlag -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ do

    -- mg2_with_srcimps drops the hi-boot nodes, returning a
    -- graph with cycles.  Among other things, it is used for
    -- backing out partially complete cycles following a failed
    -- upsweep, and for removing from hpt all the modules
    -- not in strict downwards closure, during calls to compile.
    let mg2_with_srcimps :: [SCC ModSummary]
        mg2_with_srcimps :: [SCC ModSummary]
mg2_with_srcimps = [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules ([SCC ModuleGraphNode] -> [SCC ModSummary])
-> [SCC ModuleGraphNode] -> [SCC ModSummary]
forall a b. (a -> b) -> a -> b
$
          Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
True ModuleGraph
mod_graph Maybe ModuleName
forall a. Maybe a
Nothing

    -- If we can determine that any of the {-# SOURCE #-} imports
    -- are definitely unnecessary, then emit a warning.
    [SCC ModSummary] -> m ()
forall (m :: * -> *). GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports [SCC ModSummary]
mg2_with_srcimps

    let
        -- check the stability property for each module.
        stable_mods :: StableModules
stable_mods@(UniqSet ModuleName
stable_obj,UniqSet ModuleName
stable_bco)
            = HomePackageTable
-> [SCC ModSummary] -> UniqSet ModuleName -> StableModules
checkStability HomePackageTable
hpt1 [SCC ModSummary]
mg2_with_srcimps UniqSet ModuleName
all_home_mods

        -- prune bits of the HPT which are definitely redundant now,
        -- to save space.
        pruned_hpt :: HomePackageTable
pruned_hpt = HomePackageTable
-> [ModSummary] -> StableModules -> HomePackageTable
pruneHomePackageTable HomePackageTable
hpt1
                            ([SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
flattenSCCs [SCC ModSummary]
mg2_with_srcimps)
                            StableModules
stable_mods

    HomePackageTable
_ <- IO HomePackageTable -> m HomePackageTable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HomePackageTable -> m HomePackageTable)
-> IO HomePackageTable -> m HomePackageTable
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> IO HomePackageTable
forall a. a -> IO a
evaluate HomePackageTable
pruned_hpt

    -- before we unload anything, make sure we don't leave an old
    -- interactive context around pointing to dead bindings.  Also,
    -- write the pruned HPT to allow the old HPT to be GC'd.
    HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> m ()) -> HscEnv -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
discardIC (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
pruned_hpt }

    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Stable obj:" SDoc -> SDoc -> SDoc
<+> UniqSet ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqSet ModuleName
stable_obj SDoc -> SDoc -> SDoc
$$
                            FilePath -> SDoc
text FilePath
"Stable BCO:" SDoc -> SDoc -> SDoc
<+> UniqSet ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqSet ModuleName
stable_bco)

    -- Unload any modules which are going to be re-linked this time around.
    let stable_linkables :: [Linkable]
stable_linkables = [ Linkable
linkable
                           | ModuleName
m <- UniqSet ModuleName -> [ModuleName]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ModuleName
stable_obj [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++
                                  UniqSet ModuleName -> [ModuleName]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ModuleName
stable_bco,
                             -- It's OK to use nonDetEltsUniqSet here
                             -- because it only affects linking. Besides
                             -- this list only serves as a poor man's set.
                             Just HomeModInfo
hmi <- [HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
pruned_hpt ModuleName
m],
                             Just Linkable
linkable <- [HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi] ]
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> [Linkable] -> IO ()
unload Interp
interp HscEnv
hsc_env [Linkable]
stable_linkables

    -- We could at this point detect cycles which aren't broken by
    -- a source-import, and complain immediately, but it seems better
    -- to let upsweep_mods do this, so at least some useful work gets
    -- done before the upsweep is abandoned.
    --hPutStrLn stderr "after tsort:\n"
    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))

    -- Now do the upsweep, calling compile for each module in
    -- turn.  Final result is version 3 of everything.

    -- Topologically sort the module graph, this time including hi-boot
    -- nodes, and possibly just including the portion of the graph
    -- reachable from the module specified in the 2nd argument to load.
    -- This graph should be cycle-free.
    -- If we're restricting the upsweep to a portion of the graph, we
    -- also want to retain everything that is still stable.
    let full_mg, partial_mg0, partial_mg, unstable_mg :: [SCC ModuleGraphNode]
        stable_mg :: [SCC ExtendedModSummary]
        full_mg :: [SCC ModuleGraphNode]
full_mg    = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
False ModuleGraph
mod_graph Maybe ModuleName
forall a. Maybe a
Nothing

        maybe_top_mod :: Maybe ModuleName
maybe_top_mod = case LoadHowMuch
how_much of
                            LoadUpTo ModuleName
m           -> ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
m
                            LoadDependenciesOf ModuleName
m -> ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
m
                            LoadHowMuch
_                    -> Maybe ModuleName
forall a. Maybe a
Nothing

        partial_mg0 :: [SCC ModuleGraphNode]
partial_mg0 = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
False ModuleGraph
mod_graph Maybe ModuleName
maybe_top_mod

        -- LoadDependenciesOf m: we want the upsweep to stop just
        -- short of the specified module (unless the specified module
        -- is stable).
        partial_mg :: [SCC ModuleGraphNode]
partial_mg
            | LoadDependenciesOf ModuleName
_mod <- LoadHowMuch
how_much
            = ASSERT( case last partial_mg0 of
                        AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod; _ -> False )
              [SCC ModuleGraphNode] -> [SCC ModuleGraphNode]
forall a. [a] -> [a]
List.init [SCC ModuleGraphNode]
partial_mg0
            | Bool
otherwise
            = [SCC ModuleGraphNode]
partial_mg0

        stable_mg :: [SCC ExtendedModSummary]
stable_mg =
            [ ExtendedModSummary -> SCC ExtendedModSummary
forall vertex. vertex -> SCC vertex
AcyclicSCC ExtendedModSummary
ems
            | AcyclicSCC (ModuleNode ems :: ExtendedModSummary
ems@(ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_)) <- [SCC ModuleGraphNode]
full_mg
            , ModSummary -> Bool
stable_mod_summary ModSummary
ms
            ]

        stable_mod_summary :: ModSummary -> Bool
stable_mod_summary ModSummary
ms =
          ModSummary -> ModuleName
ms_mod_name ModSummary
ms ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj Bool -> Bool -> Bool
||
          ModSummary -> ModuleName
ms_mod_name ModSummary
ms ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco

        -- the modules from partial_mg that are not also stable
        -- NB. also keep cycles, we need to emit an error message later
        unstable_mg :: [SCC ModuleGraphNode]
unstable_mg = (SCC ModuleGraphNode -> Bool)
-> [SCC ModuleGraphNode] -> [SCC ModuleGraphNode]
forall a. (a -> Bool) -> [a] -> [a]
filter SCC ModuleGraphNode -> Bool
not_stable [SCC ModuleGraphNode]
partial_mg
          where not_stable :: SCC ModuleGraphNode -> Bool
not_stable (CyclicSCC [ModuleGraphNode]
_) = Bool
True
                not_stable (AcyclicSCC (InstantiationNode InstantiatedUnit
_)) = Bool
True
                not_stable (AcyclicSCC (ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_)))
                   = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ModSummary -> Bool
stable_mod_summary ModSummary
ms

        -- Load all the stable modules first, before attempting to load
        -- an unstable module (#7231).
        mg :: [SCC ModuleGraphNode]
mg = (SCC ExtendedModSummary -> SCC ModuleGraphNode)
-> [SCC ExtendedModSummary] -> [SCC ModuleGraphNode]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ExtendedModSummary -> ModuleGraphNode)
-> SCC ExtendedModSummary -> SCC ModuleGraphNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtendedModSummary -> ModuleGraphNode
ModuleNode) [SCC ExtendedModSummary]
stable_mg [SCC ModuleGraphNode]
-> [SCC ModuleGraphNode] -> [SCC ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [SCC ModuleGraphNode]
unstable_mg

    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
text FilePath
"Ready for upsweep")
                               Int
2 ([SCC ModuleGraphNode] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SCC ModuleGraphNode]
mg))

    Int
n_jobs <- case DynFlags -> Maybe Int
parMakeCount DynFlags
dflags of
                    Maybe Int
Nothing -> IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
                    Just Int
n  -> Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
    let upsweep_fn :: Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
upsweep_fn | Int
n_jobs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = Int
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
forall (m :: * -> *).
GhcMonad m =>
Int
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
parUpsweep Int
n_jobs
                   | Bool
otherwise  = Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
forall (m :: * -> *).
GhcMonad m =>
Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
upsweep

    HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
emptyHomePackageTable }
    (SuccessFlag
upsweep_ok, [ModuleGraphNode]
modsUpswept) <- m (SuccessFlag, [ModuleGraphNode])
-> m (SuccessFlag, [ModuleGraphNode])
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics (m (SuccessFlag, [ModuleGraphNode])
 -> m (SuccessFlag, [ModuleGraphNode]))
-> m (SuccessFlag, [ModuleGraphNode])
-> m (SuccessFlag, [ModuleGraphNode])
forall a b. (a -> b) -> a -> b
$
      Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
upsweep_fn Maybe Messager
mHscMessage HomePackageTable
pruned_hpt StableModules
stable_mods [SCC ModuleGraphNode]
mg

    -- Make modsDone be the summaries for each home module now
    -- available; this should equal the domain of hpt3.
    -- Get in in a roughly top .. bottom order (hence reverse).

    let nodesDone :: [ModuleGraphNode]
nodesDone = [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a]
reverse [ModuleGraphNode]
modsUpswept
        ([InstantiatedUnit]
_, [ExtendedModSummary]
modsDone) = [ModuleGraphNode] -> ([InstantiatedUnit], [ExtendedModSummary])
partitionNodes [ModuleGraphNode]
nodesDone

    -- Try and do linking in some form, depending on whether the
    -- upsweep was completely or only partially successful.

    if SuccessFlag -> Bool
succeeded SuccessFlag
upsweep_ok

     then
       -- Easy; just relink it all.
       do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Upsweep completely successful.")

          -- Clean up after ourselves
          HscEnv
hsc_env1 <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles Logger
logger (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env1) DynFlags
dflags

          -- 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.
          --
          let ofile :: Maybe FilePath
ofile = DynFlags -> Maybe FilePath
outputFile DynFlags
dflags
          let no_hs_main :: Bool
no_hs_main = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags
          let
            main_mod :: Module
main_mod = HscEnv -> Module
mainModIs HscEnv
hsc_env
            a_root_is_Main :: Bool
a_root_is_Main = ModuleGraph -> Module -> Bool
mgElemModule ModuleGraph
mod_graph Module
main_mod
            do_linking :: Bool
do_linking = Bool
a_root_is_Main 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

          -- link everything together
          HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
          SuccessFlag
linkresult <- IO SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SuccessFlag -> m SuccessFlag)
-> IO SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ GhcLink
-> Logger
-> TmpFs
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
                                      Logger
logger
                                      (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env)
                                      (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env)
                                      DynFlags
dflags
                                      (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
                                      Bool
do_linking
                                      (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env1)

          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
             then do
                IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
errorMsg Logger
logger DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text
                   (FilePath
"output was redirected with -o, " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                    FilePath
"but no output will be generated\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                    FilePath
"because there is no " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                    ModuleName -> FilePath
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
main_mod) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" module.")
                -- This should be an error, not a warning (#10895).
                SuccessFlag -> SuccessFlag -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
Failed SuccessFlag
linkresult
             else
                SuccessFlag -> SuccessFlag -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
Succeeded SuccessFlag
linkresult

     else
       -- Tricky.  We need to back out the effects of compiling any
       -- half-done cycles, both so as to clean up the top level envs
       -- and to avoid telling the interactive linker to link them.
       do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Upsweep partially successful.")

          let modsDone_names :: [Module]
modsDone_names
                 = (ExtendedModSummary -> Module) -> [ExtendedModSummary] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (ModSummary -> Module
ms_mod (ModSummary -> Module)
-> (ExtendedModSummary -> ModSummary)
-> ExtendedModSummary
-> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtendedModSummary -> ModSummary
emsModSummary) [ExtendedModSummary]
modsDone
          let mods_to_zap_names :: Set Module
mods_to_zap_names
                 = [Module] -> [SCC ModSummary] -> Set Module
findPartiallyCompletedCycles [Module]
modsDone_names
                      [SCC ModSummary]
mg2_with_srcimps
          let ([ModSummary]
mods_to_clean, [ModSummary]
mods_to_keep) =
                (ModSummary -> Bool)
-> [ModSummary] -> ([ModSummary], [ModSummary])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Module -> Set Module -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
mods_to_zap_names)(Module -> Bool) -> (ModSummary -> Module) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ModSummary -> Module
ms_mod) ([ModSummary] -> ([ModSummary], [ModSummary]))
-> [ModSummary] -> ([ModSummary], [ModSummary])
forall a b. (a -> b) -> a -> b
$
                ExtendedModSummary -> ModSummary
emsModSummary (ExtendedModSummary -> ModSummary)
-> [ExtendedModSummary] -> [ModSummary]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExtendedModSummary]
modsDone
          HscEnv
hsc_env1 <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
          let hpt4 :: HomePackageTable
hpt4 = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env1
              -- We must change the lifetime to TFL_CurrentModule for any temp
              -- file created for an element of mod_to_clean during the upsweep.
              -- These include preprocessed files and object files for loaded
              -- modules.
              unneeded_temps :: [FilePath]
unneeded_temps = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [FilePath
ms_hspp_file FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
object_files
                | ModSummary{Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod, FilePath
ms_hspp_file :: ModSummary -> FilePath
ms_hspp_file :: FilePath
ms_hspp_file} <- [ModSummary]
mods_to_clean
                , let object_files :: [FilePath]
object_files = [FilePath]
-> (Linkable -> [FilePath]) -> Maybe Linkable -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Linkable -> [FilePath]
linkableObjs (Maybe Linkable -> [FilePath]) -> Maybe Linkable -> [FilePath]
forall a b. (a -> b) -> a -> b
$
                        HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt4 (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
ms_mod)
                        Maybe HomeModInfo
-> (HomeModInfo -> Maybe Linkable) -> Maybe Linkable
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HomeModInfo -> Maybe Linkable
hm_linkable
                ]
          TmpFs
tmpfs <- HscEnv -> TmpFs
hsc_tmpfs (HscEnv -> TmpFs) -> m HscEnv -> m TmpFs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime TmpFs
tmpfs TempFileLifetime
TFL_CurrentModule [FilePath]
unneeded_temps
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles Logger
logger TmpFs
tmpfs DynFlags
dflags

          let hpt5 :: HomePackageTable
hpt5 = [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
mods_to_keep)
                                          HomePackageTable
hpt4

          -- Clean up after ourselves

          -- there should be no Nothings where linkables should be, now
          let just_linkables :: Bool
just_linkables =
                    GhcLink -> Bool
isNoLink (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
                 Bool -> Bool -> Bool
|| (HomeModInfo -> Bool) -> HomePackageTable -> Bool
allHpt (Maybe Linkable -> Bool
forall a. Maybe a -> Bool
isJust(Maybe Linkable -> Bool)
-> (HomeModInfo -> Maybe Linkable) -> HomeModInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> Maybe Linkable
hm_linkable)
                        ((HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable
filterHpt ((HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile)(HscSource -> Bool)
-> (HomeModInfo -> HscSource) -> HomeModInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ModIface_ 'ModIfaceFinal -> HscSource
forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_src(ModIface_ 'ModIfaceFinal -> HscSource)
-> (HomeModInfo -> ModIface_ 'ModIfaceFinal)
-> HomeModInfo
-> HscSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface)
                                HomePackageTable
hpt5)
          ASSERT( just_linkables ) do

          -- Link everything together
          hsc_env <- getSession
          linkresult <- liftIO $ link (ghcLink dflags)
                                      logger
                                      (hsc_tmpfs hsc_env)
                                      (hsc_hooks hsc_env)
                                      dflags
                                      (hsc_unit_env hsc_env)
                                      False
                                      hpt5

          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
          loadFinish Failed linkresult

partitionNodes
  :: [ModuleGraphNode]
  -> ( [InstantiatedUnit]
     , [ExtendedModSummary]
     )
partitionNodes :: [ModuleGraphNode] -> ([InstantiatedUnit], [ExtendedModSummary])
partitionNodes [ModuleGraphNode]
ns = [Either InstantiatedUnit ExtendedModSummary]
-> ([InstantiatedUnit], [ExtendedModSummary])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either InstantiatedUnit ExtendedModSummary]
 -> ([InstantiatedUnit], [ExtendedModSummary]))
-> [Either InstantiatedUnit ExtendedModSummary]
-> ([InstantiatedUnit], [ExtendedModSummary])
forall a b. (a -> b) -> a -> b
$ ((ModuleGraphNode -> Either InstantiatedUnit ExtendedModSummary)
 -> [ModuleGraphNode]
 -> [Either InstantiatedUnit ExtendedModSummary])
-> [ModuleGraphNode]
-> (ModuleGraphNode -> Either InstantiatedUnit ExtendedModSummary)
-> [Either InstantiatedUnit ExtendedModSummary]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleGraphNode -> Either InstantiatedUnit ExtendedModSummary)
-> [ModuleGraphNode]
-> [Either InstantiatedUnit ExtendedModSummary]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ModuleGraphNode]
ns ((ModuleGraphNode -> Either InstantiatedUnit ExtendedModSummary)
 -> [Either InstantiatedUnit ExtendedModSummary])
-> (ModuleGraphNode -> Either InstantiatedUnit ExtendedModSummary)
-> [Either InstantiatedUnit ExtendedModSummary]
forall a b. (a -> b) -> a -> b
$ \case
  InstantiationNode InstantiatedUnit
x -> InstantiatedUnit -> Either InstantiatedUnit ExtendedModSummary
forall a b. a -> Either a b
Left InstantiatedUnit
x
  ModuleNode ExtendedModSummary
x -> ExtendedModSummary -> Either InstantiatedUnit ExtendedModSummary
forall a b. b -> Either a b
Right ExtendedModSummary
x

-- | Finish up after a load.
loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag

-- If the link failed, unload everything and return.
loadFinish :: forall (m :: * -> *).
GhcMonad m =>
SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
_all_ok SuccessFlag
Failed
  = do HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
       let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
       IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> [Linkable] -> IO ()
unload Interp
interp HscEnv
hsc_env []
       (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardProg
       SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed

-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
loadFinish SuccessFlag
all_ok SuccessFlag
Succeeded
  = do (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardIC
       SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
all_ok


-- | Forget the current program, but retain the persistent info in HscEnv
discardProg :: HscEnv -> HscEnv
discardProg :: HscEnv -> HscEnv
discardProg HscEnv
hsc_env
  = HscEnv -> HscEnv
discardIC (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
emptyMG
                        , hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
emptyHomePackageTable }

-- | Discard the contents of the InteractiveContext, but keep the DynFlags and
-- the loaded plugins.  It will also keep ic_int_print and ic_monad if their
-- names are from external packages.
discardIC :: HscEnv -> HscEnv
discardIC :: HscEnv -> HscEnv
discardIC HscEnv
hsc_env
  = HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
empty_ic { ic_int_print :: Name
ic_int_print = Name
new_ic_int_print
                                , ic_monad :: Name
ic_monad     = Name
new_ic_monad
                                , ic_plugins :: [LoadedPlugin]
ic_plugins   = [LoadedPlugin]
old_plugins
                                } }
  where
  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic
  !new_ic_int_print :: Name
new_ic_int_print = (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_int_print
  !new_ic_monad :: Name
new_ic_monad = (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_monad
  !old_plugins :: [LoadedPlugin]
old_plugins = InteractiveContext -> [LoadedPlugin]
ic_plugins InteractiveContext
old_ic
  dflags :: DynFlags
dflags = InteractiveContext -> DynFlags
ic_dflags InteractiveContext
old_ic
  old_ic :: InteractiveContext
old_ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
  empty_ic :: InteractiveContext
empty_ic = DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
  keep_external_name :: (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_name
    | HomeUnit -> Name -> Bool
nameIsFromExternalPackage HomeUnit
home_unit Name
old_name = Name
old_name
    | Bool
otherwise = InteractiveContext -> Name
ic_name InteractiveContext
empty_ic
    where
    home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
    old_name :: Name
old_name = InteractiveContext -> Name
ic_name InteractiveContext
old_ic

-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
guessOutputFile :: GhcMonad m => m ()
guessOutputFile :: forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
env ->
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env
        -- Force mod_graph to avoid leaking env
        !mod_graph :: ModuleGraph
mod_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
env
        mainModuleSrcPath :: Maybe String
        mainModuleSrcPath :: Maybe FilePath
mainModuleSrcPath = do
            ModSummary
ms <- ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph
mod_graph (HscEnv -> Module
mainModIs HscEnv
env)
            ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
        name :: Maybe FilePath
name = (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
dropExtension Maybe FilePath
mainModuleSrcPath

        name_exe :: Maybe FilePath
name_exe = do
#if defined(mingw32_HOST_OS)
          -- we must add the .exe extension unconditionally here, otherwise
          -- when name has an extension of its own, the .exe extension will
          -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248
          name' <- fmap (<.> "exe") name
#else
          FilePath
name' <- Maybe FilePath
name
#endif
          FilePath
mainModuleSrcPath' <- Maybe FilePath
mainModuleSrcPath
          -- #9930: don't clobber input files (unless they ask for it)
          if FilePath
name' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
mainModuleSrcPath'
            then GhcException -> Maybe FilePath
forall a. GhcException -> a
throwGhcException (GhcException -> Maybe FilePath)
-> (FilePath -> GhcException) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcException
UsageError (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$
                 FilePath
"default output name would overwrite the input file; " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                 FilePath
"must specify -o explicitly"
            else FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
name'
    in
    case DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags of
        Just FilePath
_ -> HscEnv
env
        Maybe FilePath
Nothing -> HscEnv
env { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags { outputFile_ :: Maybe FilePath
outputFile_ = Maybe FilePath
name_exe } }

-- -----------------------------------------------------------------------------
--
-- | Prune the HomePackageTable
--
-- Before doing an upsweep, we can throw away:
--
--   - For non-stable modules:
--      - all ModDetails, all linked code
--   - all unlinked code that is out of date with respect to
--     the source file
--
-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
-- space at the end of the upsweep, because the topmost ModDetails of the
-- old HPT holds on to the entire type environment from the previous
-- compilation.
pruneHomePackageTable :: HomePackageTable
                      -> [ModSummary]
                      -> StableModules
                      -> HomePackageTable
pruneHomePackageTable :: HomePackageTable
-> [ModSummary] -> StableModules -> HomePackageTable
pruneHomePackageTable HomePackageTable
hpt [ModSummary]
summ (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco)
  = (HomeModInfo -> HomeModInfo)
-> HomePackageTable -> HomePackageTable
mapHpt HomeModInfo -> HomeModInfo
prune HomePackageTable
hpt
  where prune :: HomeModInfo -> HomeModInfo
prune HomeModInfo
hmi
          | ModuleName -> Bool
is_stable ModuleName
modl = HomeModInfo
hmi'
          | Bool
otherwise      = HomeModInfo
hmi'{ hm_details :: ModDetails
hm_details = ModDetails
emptyModDetails }
          where
           modl :: ModuleName
modl = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
hmi))
           hmi' :: HomeModInfo
hmi' | Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi, Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< ModSummary -> UTCTime
ms_hs_date ModSummary
ms
                = HomeModInfo
hmi{ hm_linkable :: Maybe Linkable
hm_linkable = Maybe Linkable
forall a. Maybe a
Nothing }
                | Bool
otherwise
                = HomeModInfo
hmi
                where ms :: ModSummary
ms = FilePath -> Maybe ModSummary -> ModSummary
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"prune" (UniqFM ModuleName ModSummary -> ModuleName -> Maybe ModSummary
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM ModuleName ModSummary
ms_map ModuleName
modl)

        ms_map :: UniqFM ModuleName ModSummary
ms_map = [(ModuleName, ModSummary)] -> UniqFM ModuleName ModSummary
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(ModSummary -> ModuleName
ms_mod_name ModSummary
ms, ModSummary
ms) | ModSummary
ms <- [ModSummary]
summ]

        is_stable :: ModuleName -> Bool
is_stable ModuleName
m =
          ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj Bool -> Bool -> Bool
||
          ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco

-- -----------------------------------------------------------------------------
--
-- | Return (names of) all those in modsDone who are part of a cycle as defined
-- by theGraph.
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set Module
findPartiallyCompletedCycles [Module]
modsDone [SCC ModSummary]
theGraph
   = [Set Module] -> Set Module
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
       [Set Module
mods_in_this_cycle
       | CyclicSCC [ModSummary]
vs <- [SCC ModSummary]
theGraph  -- Acyclic? Not interesting.
       , let names_in_this_cycle :: Set Module
names_in_this_cycle = [Module] -> Set Module
forall a. Ord a => [a] -> Set a
Set.fromList ((ModSummary -> Module) -> [ModSummary] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> Module
ms_mod [ModSummary]
vs)
             mods_in_this_cycle :: Set Module
mods_in_this_cycle =
                    Set Module -> Set Module -> Set Module
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection ([Module] -> Set Module
forall a. Ord a => [a] -> Set a
Set.fromList [Module]
modsDone) Set Module
names_in_this_cycle
         -- If size mods_in_this_cycle == size names_in_this_cycle,
         -- then this cycle has already been completed and we're not
         -- interested.
       , Set Module -> Int
forall a. Set a -> Int
Set.size Set Module
mods_in_this_cycle Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Set Module -> Int
forall a. Set a -> Int
Set.size Set Module
names_in_this_cycle]


-- ---------------------------------------------------------------------------
--
-- | Unloading
unload :: Interp -> HscEnv -> [Linkable] -> IO ()
unload :: Interp -> HscEnv -> [Linkable] -> IO ()
unload Interp
interp HscEnv
hsc_env [Linkable]
stable_linkables -- Unload everything *except* 'stable_linkables'
  = case DynFlags -> GhcLink
ghcLink (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) of
        GhcLink
LinkInMemory -> Interp -> HscEnv -> [Linkable] -> IO ()
Linker.unload Interp
interp HscEnv
hsc_env [Linkable]
stable_linkables
        GhcLink
_other -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- -----------------------------------------------------------------------------
{- |

  Stability tells us which modules definitely do not need to be recompiled.
  There are two main reasons for having stability:

   - avoid doing a complete upsweep of the module graph in GHCi when
     modules near the bottom of the tree have not changed.

   - to tell GHCi when it can load object code: we can only load object code
     for a module when we also load object code fo  all of the imports of the
     module.  So we need to know that we will definitely not be recompiling
     any of these modules, and we can use the object code.

  The stability check is as follows.  Both stableObject and
  stableBCO are used during the upsweep phase later.

@
  stable m = stableObject m || stableBCO m

  stableObject m =
        all stableObject (imports m)
        && old linkable does not exist, or is == on-disk .o
        && date(on-disk .o) > date(.hs)

  stableBCO m =
        all stable (imports m)
        && date(BCO) > date(.hs)
@

  These properties embody the following ideas:

    - if a module is stable, then:

        - if it has been compiled in a previous pass (present in HPT)
          then it does not need to be compiled or re-linked.

        - if it has not been compiled in a previous pass,
          then we only need to read its .hi file from disk and
          link it to produce a 'ModDetails'.

    - if a modules is not stable, we will definitely be at least
      re-linking, and possibly re-compiling it during the 'upsweep'.
      All non-stable modules can (and should) therefore be unlinked
      before the 'upsweep'.

    - Note that objects are only considered stable if they only depend
      on other objects.  We can't link object code against byte code.

    - Note that even if an object is stable, we may end up recompiling
      if the interface is out of date because an *external* interface
      has changed.  The current code in GHC.Driver.Make handles this case
      fairly poorly, so be careful.
-}

type StableModules =
  ( UniqSet ModuleName  -- stableObject
  , UniqSet ModuleName  -- stableBCO
  )


checkStability
        :: HomePackageTable   -- HPT from last compilation
        -> [SCC ModSummary]   -- current module graph (cyclic)
        -> UniqSet ModuleName -- all home modules
        -> StableModules

checkStability :: HomePackageTable
-> [SCC ModSummary] -> UniqSet ModuleName -> StableModules
checkStability HomePackageTable
hpt [SCC ModSummary]
sccs UniqSet ModuleName
all_home_mods =
  (StableModules -> SCC ModSummary -> StableModules)
-> StableModules -> [SCC ModSummary] -> StableModules
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' StableModules -> SCC ModSummary -> StableModules
checkSCC (UniqSet ModuleName
forall a. UniqSet a
emptyUniqSet, UniqSet ModuleName
forall a. UniqSet a
emptyUniqSet) [SCC ModSummary]
sccs
  where
   checkSCC :: StableModules -> SCC ModSummary -> StableModules
   checkSCC :: StableModules -> SCC ModSummary -> StableModules
checkSCC (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco) SCC ModSummary
scc0
     | Bool
stableObjects = (UniqSet ModuleName -> [ModuleName] -> UniqSet ModuleName
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
addListToUniqSet UniqSet ModuleName
stable_obj [ModuleName]
scc_mods, UniqSet ModuleName
stable_bco)
     | Bool
stableBCOs    = (UniqSet ModuleName
stable_obj, UniqSet ModuleName -> [ModuleName] -> UniqSet ModuleName
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
addListToUniqSet UniqSet ModuleName
stable_bco [ModuleName]
scc_mods)
     | Bool
otherwise     = (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco)
     where
        scc :: [ModSummary]
scc = SCC ModSummary -> [ModSummary]
forall vertex. SCC vertex -> [vertex]
flattenSCC SCC ModSummary
scc0
        scc_mods :: [ModuleName]
scc_mods = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
scc
        home_module :: ModuleName -> Bool
home_module ModuleName
m =
          ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
all_home_mods Bool -> Bool -> Bool
&& ModuleName
m ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
scc_mods

        scc_allimps :: [ModuleName]
scc_allimps = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ((ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter ModuleName -> Bool
home_module ((ModSummary -> [ModuleName]) -> [ModSummary] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [ModuleName]
ms_home_allimps [ModSummary]
scc))
            -- all imports outside the current SCC, but in the home pkg

        stable_obj_imps :: [Bool]
stable_obj_imps = (ModuleName -> Bool) -> [ModuleName] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj) [ModuleName]
scc_allimps
        stable_bco_imps :: [Bool]
stable_bco_imps = (ModuleName -> Bool) -> [ModuleName] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco) [ModuleName]
scc_allimps

        stableObjects :: Bool
stableObjects =
           [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
stable_obj_imps
           Bool -> Bool -> Bool
&& (ModSummary -> Bool) -> [ModSummary] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ModSummary -> Bool
object_ok [ModSummary]
scc

        stableBCOs :: Bool
stableBCOs =
           [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Bool -> Bool -> Bool) -> [Bool] -> [Bool] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(||) [Bool]
stable_obj_imps [Bool]
stable_bco_imps)
           Bool -> Bool -> Bool
&& (ModSummary -> Bool) -> [ModSummary] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ModSummary -> Bool
bco_ok [ModSummary]
scc

        object_ok :: ModSummary -> Bool
object_ok ModSummary
ms
          | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) = Bool
False
          | Just UTCTime
t <- ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
ms  =  UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
ms
                                         Bool -> Bool -> Bool
&& UTCTime -> Bool
same_as_prev UTCTime
t
          | Bool
otherwise = Bool
False
          where
             same_as_prev :: UTCTime -> Bool
same_as_prev UTCTime
t = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) of
                                Just HomeModInfo
hmi  | Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi
                                 -> Linkable -> Bool
isObjectLinkable Linkable
l Bool -> Bool -> Bool
&& UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== Linkable -> UTCTime
linkableTime Linkable
l
                                Maybe HomeModInfo
_other  -> Bool
True
                -- why '>=' rather than '>' above?  If the filesystem stores
                -- times to the nearest second, we may occasionally find that
                -- the object & source have the same modification time,
                -- especially if the source was automatically generated
                -- and compiled.  Using >= is slightly unsafe, but it matches
                -- make's behaviour.
                --
                -- But see #5527, where someone ran into this and it caused
                -- a problem.

        bco_ok :: ModSummary -> Bool
bco_ok ModSummary
ms
          | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) = Bool
False
          | Bool
otherwise = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) of
                Just HomeModInfo
hmi  | Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi ->
                        Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
l) Bool -> Bool -> Bool
&&
                        Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
ms
                Maybe HomeModInfo
_other  -> Bool
False

{- Parallel Upsweep
 -
 - The parallel upsweep attempts to concurrently compile the modules in the
 - compilation graph using multiple Haskell threads.
 -
 - The Algorithm
 -
 - A Haskell thread is spawned for each module in the module graph, waiting for
 - its direct dependencies to finish building before it itself begins to build.
 -
 - Each module is associated with an initially empty MVar that stores the
 - result of that particular module's compile. If the compile succeeded, then
 - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that
 - module, and the module's HMI is deleted from the old HPT (synchronized by an
 - IORef) to save space.
 -
 - Instead of immediately outputting messages to the standard handles, all
 - compilation output is deferred to a per-module TQueue. A QSem is used to
 - limit the number of workers that are compiling simultaneously.
 -
 - Meanwhile, the main thread sequentially loops over all the modules in the
 - module graph, outputting the messages stored in each module's TQueue.
-}

-- | Each module is given a unique 'LogQueue' to redirect compilation messages
-- to. A 'Nothing' value contains the result of compilation, and denotes the
-- end of the message queue.
data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)])
                         !(MVar ())

-- | The graph of modules to compile and their corresponding result 'MVar' and
-- 'LogQueue'.
type CompilationGraph = [(ModuleGraphNode, MVar SuccessFlag, LogQueue)]

-- | Build a 'CompilationGraph' out of a list of strongly-connected modules,
-- also returning the first, if any, encountered module cycle.
buildCompGraph :: [SCC ModuleGraphNode] -> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph :: [SCC ModuleGraphNode]
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph [] = (CompilationGraph, Maybe [ModuleGraphNode])
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe [ModuleGraphNode]
forall a. Maybe a
Nothing)
buildCompGraph (SCC ModuleGraphNode
scc:[SCC ModuleGraphNode]
sccs) = case SCC ModuleGraphNode
scc of
    AcyclicSCC ModuleGraphNode
ms -> do
        MVar SuccessFlag
mvar <- IO (MVar SuccessFlag)
forall a. IO (MVar a)
newEmptyMVar
        LogQueue
log_queue <- do
            IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref <- [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> IO (IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)])
forall a. a -> IO (IORef a)
newIORef []
            MVar ()
sem <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
            LogQueue -> IO LogQueue
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> MVar () -> LogQueue
LogQueue IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref MVar ()
sem)
        (CompilationGraph
rest,Maybe [ModuleGraphNode]
cycle) <- [SCC ModuleGraphNode]
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph [SCC ModuleGraphNode]
sccs
        (CompilationGraph, Maybe [ModuleGraphNode])
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
forall (m :: * -> *) a. Monad m => a -> m a
return ((ModuleGraphNode
ms,MVar SuccessFlag
mvar,LogQueue
log_queue)(ModuleGraphNode, MVar SuccessFlag, LogQueue)
-> CompilationGraph -> CompilationGraph
forall a. a -> [a] -> [a]
:CompilationGraph
rest, Maybe [ModuleGraphNode]
cycle)
    CyclicSCC [ModuleGraphNode]
mss -> (CompilationGraph, Maybe [ModuleGraphNode])
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [ModuleGraphNode] -> Maybe [ModuleGraphNode]
forall a. a -> Maybe a
Just [ModuleGraphNode]
mss)

-- | A Module and whether it is a boot module.
--
-- We need to treat boot modules specially when building compilation graphs,
-- since they break cycles. Regular source files and signature files are treated
-- equivalently.
data BuildModule = BuildModule_Unit {-# UNPACK #-} !InstantiatedUnit | BuildModule_Module {-# UNPACK #-} !ModuleWithIsBoot
  deriving (BuildModule -> BuildModule -> Bool
(BuildModule -> BuildModule -> Bool)
-> (BuildModule -> BuildModule -> Bool) -> Eq BuildModule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuildModule -> BuildModule -> Bool
$c/= :: BuildModule -> BuildModule -> Bool
== :: BuildModule -> BuildModule -> Bool
$c== :: BuildModule -> BuildModule -> Bool
Eq, Eq BuildModule
Eq BuildModule
-> (BuildModule -> BuildModule -> Ordering)
-> (BuildModule -> BuildModule -> Bool)
-> (BuildModule -> BuildModule -> Bool)
-> (BuildModule -> BuildModule -> Bool)
-> (BuildModule -> BuildModule -> Bool)
-> (BuildModule -> BuildModule -> BuildModule)
-> (BuildModule -> BuildModule -> BuildModule)
-> Ord BuildModule
BuildModule -> BuildModule -> Bool
BuildModule -> BuildModule -> Ordering
BuildModule -> BuildModule -> BuildModule
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
min :: BuildModule -> BuildModule -> BuildModule
$cmin :: BuildModule -> BuildModule -> BuildModule
max :: BuildModule -> BuildModule -> BuildModule
$cmax :: BuildModule -> BuildModule -> BuildModule
>= :: BuildModule -> BuildModule -> Bool
$c>= :: BuildModule -> BuildModule -> Bool
> :: BuildModule -> BuildModule -> Bool
$c> :: BuildModule -> BuildModule -> Bool
<= :: BuildModule -> BuildModule -> Bool
$c<= :: BuildModule -> BuildModule -> Bool
< :: BuildModule -> BuildModule -> Bool
$c< :: BuildModule -> BuildModule -> Bool
compare :: BuildModule -> BuildModule -> Ordering
$ccompare :: BuildModule -> BuildModule -> Ordering
Ord)

-- | Tests if an 'HscSource' is a boot file, primarily for constructing elements
-- of 'BuildModule'. We conflate signatures and modules because they are bound
-- in the same namespace; only boot interfaces can be disambiguated with
-- `import {-# SOURCE #-}`.
hscSourceToIsBoot :: HscSource -> IsBootInterface
hscSourceToIsBoot :: HscSource -> IsBootInterface
hscSourceToIsBoot HscSource
HsBootFile = IsBootInterface
IsBoot
hscSourceToIsBoot HscSource
_ = IsBootInterface
NotBoot

mkBuildModule :: ModuleGraphNode -> BuildModule
mkBuildModule :: ModuleGraphNode -> BuildModule
mkBuildModule = \case
  InstantiationNode InstantiatedUnit
x -> InstantiatedUnit -> BuildModule
BuildModule_Unit InstantiatedUnit
x
  ModuleNode ExtendedModSummary
ems -> ModuleWithIsBoot -> BuildModule
BuildModule_Module (ModuleWithIsBoot -> BuildModule)
-> ModuleWithIsBoot -> BuildModule
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleWithIsBoot
mkBuildModule0 (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems)

mkHomeBuildModule :: ModuleGraphNode -> NodeKey
mkHomeBuildModule :: ModuleGraphNode -> NodeKey
mkHomeBuildModule = \case
  InstantiationNode InstantiatedUnit
x -> InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
x
  ModuleNode ExtendedModSummary
ems -> ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey) -> ModNodeKey -> NodeKey
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModNodeKey
mkHomeBuildModule0 (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems)

mkBuildModule0 :: ModSummary -> ModuleWithIsBoot
mkBuildModule0 :: ModSummary -> ModuleWithIsBoot
mkBuildModule0 ModSummary
ms = GWIB
  { gwib_mod :: Module
gwib_mod = ModSummary -> Module
ms_mod ModSummary
ms
  , gwib_isBoot :: IsBootInterface
gwib_isBoot = ModSummary -> IsBootInterface
isBootSummary ModSummary
ms
  }

mkHomeBuildModule0 :: ModSummary -> ModuleNameWithIsBoot
mkHomeBuildModule0 :: ModSummary -> ModNodeKey
mkHomeBuildModule0 ModSummary
ms = GWIB
  { gwib_mod :: ModuleName
gwib_mod = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
ms
  , gwib_isBoot :: IsBootInterface
gwib_isBoot = ModSummary -> IsBootInterface
isBootSummary ModSummary
ms
  }

-- | The entry point to the parallel upsweep.
--
-- See also the simpler, sequential 'upsweep'.
parUpsweep
    :: GhcMonad m
    => Int
    -- ^ The number of workers we wish to run in parallel
    -> Maybe Messager
    -> HomePackageTable
    -> StableModules
    -> [SCC ModuleGraphNode]
    -> m (SuccessFlag,
          [ModuleGraphNode])
parUpsweep :: forall (m :: * -> *).
GhcMonad m =>
Int
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
parUpsweep Int
n_jobs Maybe Messager
mHscMessage HomePackageTable
old_hpt StableModules
stable_mods [SCC ModuleGraphNode]
sccs = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    let tmpfs :: TmpFs
tmpfs  = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env

    -- The bits of shared state we'll be using:

    -- The global HscEnv is updated with the module's HMI when a module
    -- successfully compiles.
    MVar HscEnv
hsc_env_var <- IO (MVar HscEnv) -> m (MVar HscEnv)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar HscEnv) -> m (MVar HscEnv))
-> IO (MVar HscEnv) -> m (MVar HscEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO (MVar HscEnv)
forall a. a -> IO (MVar a)
newMVar HscEnv
hsc_env

    -- The old HPT is used for recompilation checking in upsweep_mod. When a
    -- module successfully gets compiled, its HMI is pruned from the old HPT.
    IORef HomePackageTable
old_hpt_var <- IO (IORef HomePackageTable) -> m (IORef HomePackageTable)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef HomePackageTable) -> m (IORef HomePackageTable))
-> IO (IORef HomePackageTable) -> m (IORef HomePackageTable)
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> IO (IORef HomePackageTable)
forall a. a -> IO (IORef a)
newIORef HomePackageTable
old_hpt

    -- What we use to limit parallelism with.
    QSem
par_sem <- IO QSem -> m QSem
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO QSem -> m QSem) -> IO QSem -> m QSem
forall a b. (a -> b) -> a -> b
$ Int -> IO QSem
newQSem Int
n_jobs


    let updNumCapabilities :: m Int
updNumCapabilities = IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ do
            Int
n_capabilities <- IO Int
getNumCapabilities
            Int
n_cpus <- IO Int
getNumProcessors
            -- Setting number of capabilities more than
            -- CPU count usually leads to high userspace
            -- lock contention. #9221
            let n_caps :: Int
n_caps = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n_jobs Int
n_cpus
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n_capabilities Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
n_caps
            Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n_capabilities
    -- Reset the number of capabilities once the upsweep ends.
    let resetNumCapabilities :: Int -> m ()
resetNumCapabilities Int
orig_n = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
orig_n

    m Int
-> (Int -> m ())
-> (Int -> m (SuccessFlag, [ModuleGraphNode]))
-> m (SuccessFlag, [ModuleGraphNode])
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket m Int
updNumCapabilities Int -> m ()
forall {m :: * -> *}. MonadIO m => Int -> m ()
resetNumCapabilities ((Int -> m (SuccessFlag, [ModuleGraphNode]))
 -> m (SuccessFlag, [ModuleGraphNode]))
-> (Int -> m (SuccessFlag, [ModuleGraphNode]))
-> m (SuccessFlag, [ModuleGraphNode])
forall a b. (a -> b) -> a -> b
$ \Int
_ -> do

    -- Sync the global session with the latest HscEnv once the upsweep ends.
    let finallySyncSession :: m (SuccessFlag, [ModuleGraphNode])
-> m (SuccessFlag, [ModuleGraphNode])
finallySyncSession m (SuccessFlag, [ModuleGraphNode])
io = m (SuccessFlag, [ModuleGraphNode])
io m (SuccessFlag, [ModuleGraphNode])
-> m () -> m (SuccessFlag, [ModuleGraphNode])
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`MC.finally` do
            HscEnv
hsc_env <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ MVar HscEnv -> IO HscEnv
forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
            HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env

    m (SuccessFlag, [ModuleGraphNode])
-> m (SuccessFlag, [ModuleGraphNode])
finallySyncSession (m (SuccessFlag, [ModuleGraphNode])
 -> m (SuccessFlag, [ModuleGraphNode]))
-> m (SuccessFlag, [ModuleGraphNode])
-> m (SuccessFlag, [ModuleGraphNode])
forall a b. (a -> b) -> a -> b
$ do

    -- Build the compilation graph out of the list of SCCs. Module cycles are
    -- handled at the very end, after some useful work gets done. Note that
    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).
    (CompilationGraph
comp_graph,Maybe [ModuleGraphNode]
cycle) <- IO (CompilationGraph, Maybe [ModuleGraphNode])
-> m (CompilationGraph, Maybe [ModuleGraphNode])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CompilationGraph, Maybe [ModuleGraphNode])
 -> m (CompilationGraph, Maybe [ModuleGraphNode]))
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
-> m (CompilationGraph, Maybe [ModuleGraphNode])
forall a b. (a -> b) -> a -> b
$ [SCC ModuleGraphNode]
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph [SCC ModuleGraphNode]
sccs
    let comp_graph_w_idx :: [((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx = CompilationGraph
-> [Int] -> [((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip CompilationGraph
comp_graph [Int
1..]

    -- The list of all loops in the compilation graph.
    -- NB: For convenience, the last module of each loop (aka the module that
    -- finishes the loop) is prepended to the beginning of the loop.
    let graph :: [ModuleGraphNode]
graph = ((ModuleGraphNode, MVar SuccessFlag, LogQueue) -> ModuleGraphNode)
-> CompilationGraph -> [ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleGraphNode, MVar SuccessFlag, LogQueue) -> ModuleGraphNode
forall a b c. (a, b, c) -> a
fstOf3 (CompilationGraph -> CompilationGraph
forall a. [a] -> [a]
reverse CompilationGraph
comp_graph)
        boot_modules :: ModuleSet
boot_modules = [Module] -> ModuleSet
mkModuleSet
          [ModSummary -> Module
ms_mod ModSummary
ms | ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_) <- [ModuleGraphNode]
graph, ModSummary -> IsBootInterface
isBootSummary ModSummary
ms IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot]
        comp_graph_loops :: [[BuildModule]]
comp_graph_loops = [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
graph ModuleSet
boot_modules
          where
            remove :: ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
bm = case ModSummary -> IsBootInterface
isBootSummary ModSummary
ms of
              IsBootInterface
IsBoot -> ModuleSet -> Module -> ModuleSet
delModuleSet ModuleSet
bm (ModSummary -> Module
ms_mod ModSummary
ms)
              IsBootInterface
NotBoot -> ModuleSet
bm
            go :: [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [] ModuleSet
_ = []
            go (InstantiationNode InstantiatedUnit
_ : [ModuleGraphNode]
mss) ModuleSet
boot_modules
              = [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
mss ModuleSet
boot_modules
            go mg :: [ModuleGraphNode]
mg@(mnode :: ModuleGraphNode
mnode@(ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_)) : [ModuleGraphNode]
mss) ModuleSet
boot_modules
              | Just [ModuleGraphNode]
loop <- ModSummary
-> [ModuleGraphNode] -> (Module -> Bool) -> Maybe [ModuleGraphNode]
getModLoop ModSummary
ms [ModuleGraphNode]
mg (Module -> ModuleSet -> Bool
`elemModuleSet` ModuleSet
boot_modules)
              = (ModuleGraphNode -> BuildModule)
-> [ModuleGraphNode] -> [BuildModule]
forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> BuildModule
mkBuildModule (ModuleGraphNode
mnode ModuleGraphNode -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. a -> [a] -> [a]
: [ModuleGraphNode]
loop) [BuildModule] -> [[BuildModule]] -> [[BuildModule]]
forall a. a -> [a] -> [a]
: [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
mss (ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
boot_modules)
              | Bool
otherwise
              = [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
mss (ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
boot_modules)

    -- Build a Map out of the compilation graph with which we can efficiently
    -- look up the result MVar associated with a particular home module.
    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
        home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
home_mod_map =
            [(BuildModule, (MVar SuccessFlag, Int))]
-> Map BuildModule (MVar SuccessFlag, Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ModuleGraphNode -> BuildModule
mkBuildModule ModuleGraphNode
ms, (MVar SuccessFlag
mvar, Int
idx))
                         | ((ModuleGraphNode
ms,MVar SuccessFlag
mvar,LogQueue
_),Int
idx) <- [((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx ]


    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self FilePath
"main --make thread"

    -- Make the logger thread_safe: we only make the "log" action thread-safe in
    -- each worker by setting a LogAction hook, so we need to make the logger
    -- thread-safe for other actions (DumpAction, TraceAction).
    Logger
thread_safe_logger <- IO Logger -> m Logger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Logger -> m Logger) -> IO Logger -> m Logger
forall a b. (a -> b) -> a -> b
$ Logger -> IO Logger
makeThreadSafe Logger
logger

    -- For each module in the module graph, spawn a worker thread that will
    -- compile this module.
    let { spawnWorkers :: IO [ThreadId]
spawnWorkers = [((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)]
-> (((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)
    -> IO ThreadId)
-> IO [ThreadId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx ((((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)
  -> IO ThreadId)
 -> IO [ThreadId])
-> (((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)
    -> IO ThreadId)
-> IO [ThreadId]
forall a b. (a -> b) -> a -> b
$ \((ModuleGraphNode
mod,!MVar SuccessFlag
mvar,!LogQueue
log_queue),!Int
mod_idx) ->
            ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
                IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ [ FilePath
"worker --make thread" ]
                    , case ModuleGraphNode
mod of
                        InstantiationNode InstantiatedUnit
iuid ->
                          [ FilePath
"for instantiation of unit"
                          , Unit -> FilePath
forall a. Show a => a -> FilePath
show (Unit -> FilePath) -> Unit -> FilePath
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid
                          ]
                        ModuleNode ExtendedModSummary
ems ->
                          [ FilePath
"for module"
                          , FilePath -> FilePath
forall a. Show a => a -> FilePath
show (ModuleName -> FilePath
moduleNameString (ModSummary -> ModuleName
ms_mod_name (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems)))
                          ]
                    , [FilePath
"number"
                      , Int -> FilePath
forall a. Show a => a -> FilePath
show Int
mod_idx
                      ]
                    ]
                -- Replace the default log_action with one that writes each
                -- message to the module's log_queue. The main thread will
                -- deal with synchronously printing these messages.
                let lcl_logger :: Logger
lcl_logger = (LogAction -> LogAction) -> Logger -> Logger
pushLogHook (LogAction -> LogAction -> LogAction
forall a b. a -> b -> a
const (LogQueue -> LogAction
parLogAction LogQueue
log_queue)) Logger
thread_safe_logger

                -- Use a local TmpFs so that we can clean up intermediate files
                -- in a timely fashion (as soon as compilation for that module
                -- is finished) without having to worry about accidentally
                -- deleting a simultaneous compile's important files.
                TmpFs
lcl_tmpfs <- TmpFs -> IO TmpFs
forkTmpFsFrom TmpFs
tmpfs

                -- Unmask asynchronous exceptions and perform the thread-local
                -- work to compile the module (see parUpsweep_one).
                Either SomeException SuccessFlag
m_res <- IO SuccessFlag -> IO (Either SomeException SuccessFlag)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try (IO SuccessFlag -> IO (Either SomeException SuccessFlag))
-> IO SuccessFlag -> IO (Either SomeException SuccessFlag)
forall a b. (a -> b) -> a -> b
$ IO SuccessFlag -> IO SuccessFlag
forall a. IO a -> IO a
unmask (IO SuccessFlag -> IO SuccessFlag)
-> IO SuccessFlag -> IO SuccessFlag
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors DynFlags
dflags (IO SuccessFlag -> IO SuccessFlag)
-> IO SuccessFlag -> IO SuccessFlag
forall a b. (a -> b) -> a -> b
$
                  case ModuleGraphNode
mod of
                    InstantiationNode InstantiatedUnit
iuid -> do
                      HscEnv
hsc_env <- MVar HscEnv -> IO HscEnv
forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
                      IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe Messager -> Int -> Int -> InstantiatedUnit -> IO ()
upsweep_inst HscEnv
hsc_env Maybe Messager
mHscMessage Int
mod_idx ([SCC ModuleGraphNode] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModuleGraphNode]
sccs) InstantiatedUnit
iuid
                      SuccessFlag -> IO SuccessFlag
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
Succeeded
                    ModuleNode ExtendedModSummary
ems ->
                      ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> Logger
-> TmpFs
-> DynFlags
-> HomeUnit
-> Maybe Messager
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> StableModules
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems) Map BuildModule (MVar SuccessFlag, Int)
home_mod_map [[BuildModule]]
comp_graph_loops
                                     Logger
lcl_logger TmpFs
lcl_tmpfs DynFlags
dflags (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env)
                                     Maybe Messager
mHscMessage
                                     QSem
par_sem MVar HscEnv
hsc_env_var IORef HomePackageTable
old_hpt_var
                                     StableModules
stable_mods Int
mod_idx ([SCC ModuleGraphNode] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModuleGraphNode]
sccs)

                SuccessFlag
res <- case Either SomeException SuccessFlag
m_res of
                    Right SuccessFlag
flag -> SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
flag
                    Left SomeException
exc -> do
                        -- Don't print ThreadKilled exceptions: they are used
                        -- to kill the worker thread in the event of a user
                        -- interrupt, and the user doesn't have to be informed
                        -- about that.
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc Maybe AsyncException -> Maybe AsyncException -> Bool
forall a. Eq a => a -> a -> Bool
/= AsyncException -> Maybe AsyncException
forall a. a -> Maybe a
Just AsyncException
ThreadKilled)
                             (Logger -> DynFlags -> SDoc -> IO ()
errorMsg Logger
lcl_logger DynFlags
dflags (FilePath -> SDoc
text (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
exc)))
                        SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed

                -- Populate the result MVar.
                MVar SuccessFlag -> SuccessFlag -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar SuccessFlag
mvar SuccessFlag
res

                -- Write the end marker to the message queue, telling the main
                -- thread that it can stop waiting for messages from this
                -- particular compile.
                LogQueue -> Maybe (WarnReason, Severity, SrcSpan, SDoc) -> IO ()
writeLogQueue LogQueue
log_queue Maybe (WarnReason, Severity, SrcSpan, SDoc)
forall a. Maybe a
Nothing

                -- Add the remaining files that weren't cleaned up to the
                -- global TmpFs, for cleanup later.
                TmpFs -> TmpFs -> IO ()
mergeTmpFsInto TmpFs
lcl_tmpfs TmpFs
tmpfs

        -- Kill all the workers, masking interrupts (since killThread is
        -- interruptible). XXX: This is not ideal.
        ; killWorkers :: [ThreadId] -> IO ()
killWorkers = IO () -> IO ()
forall (m :: * -> *) a. MonadMask m => m a -> m a
MC.uninterruptibleMask_ (IO () -> IO ()) -> ([ThreadId] -> IO ()) -> [ThreadId] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread }


    -- Spawn the workers, making sure to kill them later. Collect the results
    -- of each compile.
    [Maybe ModuleGraphNode]
results <- IO [Maybe ModuleGraphNode] -> m [Maybe ModuleGraphNode]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Maybe ModuleGraphNode] -> m [Maybe ModuleGraphNode])
-> IO [Maybe ModuleGraphNode] -> m [Maybe ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ IO [ThreadId]
-> ([ThreadId] -> IO ())
-> ([ThreadId] -> IO [Maybe ModuleGraphNode])
-> IO [Maybe ModuleGraphNode]
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO [ThreadId]
spawnWorkers [ThreadId] -> IO ()
killWorkers (([ThreadId] -> IO [Maybe ModuleGraphNode])
 -> IO [Maybe ModuleGraphNode])
-> ([ThreadId] -> IO [Maybe ModuleGraphNode])
-> IO [Maybe ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ \[ThreadId]
_ ->
        -- Loop over each module in the compilation graph in order, printing
        -- each message from its log_queue.
        CompilationGraph
-> ((ModuleGraphNode, MVar SuccessFlag, LogQueue)
    -> IO (Maybe ModuleGraphNode))
-> IO [Maybe ModuleGraphNode]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM CompilationGraph
comp_graph (((ModuleGraphNode, MVar SuccessFlag, LogQueue)
  -> IO (Maybe ModuleGraphNode))
 -> IO [Maybe ModuleGraphNode])
-> ((ModuleGraphNode, MVar SuccessFlag, LogQueue)
    -> IO (Maybe ModuleGraphNode))
-> IO [Maybe ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ \(ModuleGraphNode
mod,MVar SuccessFlag
mvar,LogQueue
log_queue) -> do
            Logger -> DynFlags -> LogQueue -> IO ()
printLogs Logger
logger DynFlags
dflags LogQueue
log_queue
            SuccessFlag
result <- MVar SuccessFlag -> IO SuccessFlag
forall a. MVar a -> IO a
readMVar MVar SuccessFlag
mvar
            if SuccessFlag -> Bool
succeeded SuccessFlag
result then Maybe ModuleGraphNode -> IO (Maybe ModuleGraphNode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleGraphNode -> Maybe ModuleGraphNode
forall a. a -> Maybe a
Just ModuleGraphNode
mod) else Maybe ModuleGraphNode -> IO (Maybe ModuleGraphNode)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleGraphNode
forall a. Maybe a
Nothing


    -- Collect and return the ModSummaries of all the successful compiles.
    -- NB: Reverse this list to maintain output parity with the sequential upsweep.
    let ok_results :: [ModuleGraphNode]
ok_results = [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a]
reverse ([Maybe ModuleGraphNode] -> [ModuleGraphNode]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ModuleGraphNode]
results)

    -- Handle any cycle in the original compilation graph and return the result
    -- of the upsweep.
    case Maybe [ModuleGraphNode]
cycle of
        Just [ModuleGraphNode]
mss -> do
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
fatalErrorMsg Logger
logger DynFlags
dflags ([ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
mss)
            (SuccessFlag, [ModuleGraphNode])
-> m (SuccessFlag, [ModuleGraphNode])
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed,[ModuleGraphNode]
ok_results)
        Maybe [ModuleGraphNode]
Nothing  -> do
            let success_flag :: SuccessFlag
success_flag = Bool -> SuccessFlag
successIf ((Maybe ModuleGraphNode -> Bool) -> [Maybe ModuleGraphNode] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe ModuleGraphNode -> Bool
forall a. Maybe a -> Bool
isJust [Maybe ModuleGraphNode]
results)
            (SuccessFlag, [ModuleGraphNode])
-> m (SuccessFlag, [ModuleGraphNode])
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
success_flag,[ModuleGraphNode]
ok_results)

  where
    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,SDoc) -> IO ()
    writeLogQueue :: LogQueue -> Maybe (WarnReason, Severity, SrcSpan, SDoc) -> IO ()
writeLogQueue (LogQueue IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref MVar ()
sem) Maybe (WarnReason, Severity, SrcSpan, SDoc)
msg = do
        IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
    -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)], ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref (([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
  -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)], ()))
 -> IO ())
-> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
    -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)], ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs -> (Maybe (WarnReason, Severity, SrcSpan, SDoc)
msgMaybe (WarnReason, Severity, SrcSpan, SDoc)
-> [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
forall a. a -> [a] -> [a]
:[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs,())
        Bool
_ <- MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
sem ()
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- The log_action callback that is used to synchronize messages from a
    -- worker thread.
    parLogAction :: LogQueue -> LogAction
    parLogAction :: LogQueue -> LogAction
parLogAction LogQueue
log_queue DynFlags
_dflags !WarnReason
reason !Severity
severity !SrcSpan
srcSpan !SDoc
msg =
        LogQueue -> Maybe (WarnReason, Severity, SrcSpan, SDoc) -> IO ()
writeLogQueue LogQueue
log_queue ((WarnReason, Severity, SrcSpan, SDoc)
-> Maybe (WarnReason, Severity, SrcSpan, SDoc)
forall a. a -> Maybe a
Just (WarnReason
reason,Severity
severity,SrcSpan
srcSpan,SDoc
msg))

    -- Print each message from the log_queue using the log_action from the
    -- session's DynFlags.
    printLogs :: Logger -> DynFlags -> LogQueue -> IO ()
    printLogs :: Logger -> DynFlags -> LogQueue -> IO ()
printLogs !Logger
logger !DynFlags
dflags (LogQueue IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref MVar ()
sem) = IO ()
read_msgs
      where read_msgs :: IO ()
read_msgs = do
                MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
sem
                [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs <- IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
    -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)],
        [Maybe (WarnReason, Severity, SrcSpan, SDoc)]))
-> IO [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref (([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
  -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)],
      [Maybe (WarnReason, Severity, SrcSpan, SDoc)]))
 -> IO [Maybe (WarnReason, Severity, SrcSpan, SDoc)])
-> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
    -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)],
        [Maybe (WarnReason, Severity, SrcSpan, SDoc)]))
-> IO [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
forall a b. (a -> b) -> a -> b
$ \[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs -> ([], [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
forall a. [a] -> [a]
reverse [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs)
                [Maybe (WarnReason, Severity, SrcSpan, SDoc)] -> IO ()
print_loop [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs

            print_loop :: [Maybe (WarnReason, Severity, SrcSpan, SDoc)] -> IO ()
print_loop [] = IO ()
read_msgs
            print_loop (Maybe (WarnReason, Severity, SrcSpan, SDoc)
x:[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs) = case Maybe (WarnReason, Severity, SrcSpan, SDoc)
x of
                Just (WarnReason
reason,Severity
severity,SrcSpan
srcSpan,SDoc
msg) -> do
                    Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
reason Severity
severity SrcSpan
srcSpan SDoc
msg
                    [Maybe (WarnReason, Severity, SrcSpan, SDoc)] -> IO ()
print_loop [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs
                -- Exit the loop once we encounter the end marker.
                Maybe (WarnReason, Severity, SrcSpan, SDoc)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- The interruptible subset of the worker threads' work.
parUpsweep_one
    :: ModSummary
    -- ^ The module we wish to compile
    -> Map BuildModule (MVar SuccessFlag, Int)
    -- ^ The map of home modules and their result MVar
    -> [[BuildModule]]
    -- ^ The list of all module loops within the compilation graph.
    -> Logger
    -- ^ The thread-local Logger
    -> TmpFs
    -- ^ The thread-local TmpFs
    -> DynFlags
    -- ^ The thread-local DynFlags
    -> HomeUnit
    -- ^ The home-unit
    -> Maybe Messager
    -- ^ The messager
    -> QSem
    -- ^ The semaphore for limiting the number of simultaneous compiles
    -> MVar HscEnv
    -- ^ The MVar that synchronizes updates to the global HscEnv
    -> IORef HomePackageTable
    -- ^ The old HPT
    -> StableModules
    -- ^ Sets of stable objects and BCOs
    -> Int
    -- ^ The index of this module
    -> Int
    -- ^ The total number of modules
    -> IO SuccessFlag
    -- ^ The result of this compile
parUpsweep_one :: ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> Logger
-> TmpFs
-> DynFlags
-> HomeUnit
-> Maybe Messager
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> StableModules
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one ModSummary
mod Map BuildModule (MVar SuccessFlag, Int)
home_mod_map [[BuildModule]]
comp_graph_loops Logger
lcl_logger TmpFs
lcl_tmpfs DynFlags
lcl_dflags HomeUnit
home_unit Maybe Messager
mHscMessage QSem
par_sem
               MVar HscEnv
hsc_env_var IORef HomePackageTable
old_hpt_var StableModules
stable_mods Int
mod_index Int
num_mods = do

    let this_build_mod :: ModuleWithIsBoot
this_build_mod = ModSummary -> ModuleWithIsBoot
mkBuildModule0 ModSummary
mod

    let home_imps :: [ModuleName]
home_imps     = (GenLocated SrcSpan ModuleName -> ModuleName)
-> [GenLocated SrcSpan ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc ([GenLocated SrcSpan ModuleName] -> [ModuleName])
-> [GenLocated SrcSpan ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
mod
    let home_src_imps :: [ModuleName]
home_src_imps = (GenLocated SrcSpan ModuleName -> ModuleName)
-> [GenLocated SrcSpan ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc ([GenLocated SrcSpan ModuleName] -> [ModuleName])
-> [GenLocated SrcSpan ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
mod

    -- All the textual imports of this module.
    let textual_deps :: Set BuildModule
textual_deps = [BuildModule] -> Set BuildModule
forall a. Ord a => [a] -> Set a
Set.fromList ([BuildModule] -> Set BuildModule)
-> [BuildModule] -> Set BuildModule
forall a b. (a -> b) -> a -> b
$
            (ModuleName -> IsBootInterface -> BuildModule)
-> [ModuleName] -> [IsBootInterface] -> [BuildModule]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ModuleName -> IsBootInterface -> BuildModule
f [ModuleName]
home_imps     (IsBootInterface -> [IsBootInterface]
forall a. a -> [a]
repeat IsBootInterface
NotBoot) [BuildModule] -> [BuildModule] -> [BuildModule]
forall a. [a] -> [a] -> [a]
++
            (ModuleName -> IsBootInterface -> BuildModule)
-> [ModuleName] -> [IsBootInterface] -> [BuildModule]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ModuleName -> IsBootInterface -> BuildModule
f [ModuleName]
home_src_imps (IsBootInterface -> [IsBootInterface]
forall a. a -> [a]
repeat IsBootInterface
IsBoot)
          where f :: ModuleName -> IsBootInterface -> BuildModule
f ModuleName
mn IsBootInterface
isBoot = ModuleWithIsBoot -> BuildModule
BuildModule_Module (ModuleWithIsBoot -> BuildModule)
-> ModuleWithIsBoot -> BuildModule
forall a b. (a -> b) -> a -> b
$ GWIB
                  { gwib_mod :: Module
gwib_mod = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mn
                  , gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
isBoot
                  }

    -- Dealing with module loops
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~
    --
    -- Not only do we have to deal with explicit textual dependencies, we also
    -- have to deal with implicit dependencies introduced by import cycles that
    -- are broken by an hs-boot file. We have to ensure that:
    --
    -- 1. A module that breaks a loop must depend on all the modules in the
    --    loop (transitively or otherwise). This is normally always fulfilled
    --    by the module's textual dependencies except in degenerate loops,
    --    e.g.:
    --
    --    A.hs imports B.hs-boot
    --    B.hs doesn't import A.hs
    --    C.hs imports A.hs, B.hs
    --
    --    In this scenario, getModLoop will detect the module loop [A,B] but
    --    the loop finisher B doesn't depend on A. So we have to explicitly add
    --    A in as a dependency of B when we are compiling B.
    --
    -- 2. A module that depends on a module in an external loop can't proceed
    --    until the entire loop is re-typechecked.
    --
    -- These two invariants have to be maintained to correctly build a
    -- compilation graph with one or more loops.


    -- The loop that this module will finish. After this module successfully
    -- compiles, this loop is going to get re-typechecked.
    let finish_loop :: Maybe [ModuleWithIsBoot]
        finish_loop :: Maybe [ModuleWithIsBoot]
finish_loop = [[ModuleWithIsBoot]] -> Maybe [ModuleWithIsBoot]
forall a. [a] -> Maybe a
listToMaybe
          [ ((BuildModule -> Maybe ModuleWithIsBoot)
 -> [BuildModule] -> [ModuleWithIsBoot])
-> [BuildModule]
-> (BuildModule -> Maybe ModuleWithIsBoot)
-> [ModuleWithIsBoot]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (BuildModule -> Maybe ModuleWithIsBoot)
-> [BuildModule] -> [ModuleWithIsBoot]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([BuildModule] -> [BuildModule]
forall a. [a] -> [a]
tail [BuildModule]
loop) ((BuildModule -> Maybe ModuleWithIsBoot) -> [ModuleWithIsBoot])
-> (BuildModule -> Maybe ModuleWithIsBoot) -> [ModuleWithIsBoot]
forall a b. (a -> b) -> a -> b
$ \case
              BuildModule_Unit InstantiatedUnit
_ -> Maybe ModuleWithIsBoot
forall a. Maybe a
Nothing
              BuildModule_Module ModuleWithIsBoot
ms -> ModuleWithIsBoot -> Maybe ModuleWithIsBoot
forall a. a -> Maybe a
Just ModuleWithIsBoot
ms
          | [BuildModule]
loop <- [[BuildModule]]
comp_graph_loops
          , [BuildModule] -> BuildModule
forall a. [a] -> a
head [BuildModule]
loop BuildModule -> BuildModule -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleWithIsBoot -> BuildModule
BuildModule_Module ModuleWithIsBoot
this_build_mod
          ]

    -- If this module finishes a loop then it must depend on all the other
    -- modules in that loop because the entire module loop is going to be
    -- re-typechecked once this module gets compiled. These extra dependencies
    -- are this module's "internal" loop dependencies, because this module is
    -- inside the loop in question.
    let int_loop_deps :: Set.Set BuildModule
        int_loop_deps :: Set BuildModule
int_loop_deps = [BuildModule] -> Set BuildModule
forall a. Ord a => [a] -> Set a
Set.fromList ([BuildModule] -> Set BuildModule)
-> [BuildModule] -> Set BuildModule
forall a b. (a -> b) -> a -> b
$
            case Maybe [ModuleWithIsBoot]
finish_loop of
                Maybe [ModuleWithIsBoot]
Nothing   -> []
                Just [ModuleWithIsBoot]
loop -> ModuleWithIsBoot -> BuildModule
BuildModule_Module (ModuleWithIsBoot -> BuildModule)
-> [ModuleWithIsBoot] -> [BuildModule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModuleWithIsBoot -> Bool)
-> [ModuleWithIsBoot] -> [ModuleWithIsBoot]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleWithIsBoot -> ModuleWithIsBoot -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleWithIsBoot
this_build_mod) [ModuleWithIsBoot]
loop

    -- If this module depends on a module within a loop then it must wait for
    -- that loop to get re-typechecked, i.e. it must wait on the module that
    -- finishes that loop. These extra dependencies are this module's
    -- "external" loop dependencies, because this module is outside of the
    -- loop(s) in question.
    let ext_loop_deps :: Set.Set BuildModule
        ext_loop_deps :: Set BuildModule
ext_loop_deps = [BuildModule] -> Set BuildModule
forall a. Ord a => [a] -> Set a
Set.fromList
            [ [BuildModule] -> BuildModule
forall a. [a] -> a
head [BuildModule]
loop | [BuildModule]
loop <- [[BuildModule]]
comp_graph_loops
                        , (BuildModule -> Bool) -> [BuildModule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (BuildModule -> Set BuildModule -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BuildModule
textual_deps) [BuildModule]
loop
                        , ModuleWithIsBoot -> BuildModule
BuildModule_Module ModuleWithIsBoot
this_build_mod BuildModule -> [BuildModule] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [BuildModule]
loop ]


    let all_deps :: Set BuildModule
all_deps = (Set BuildModule -> Set BuildModule -> Set BuildModule)
-> [Set BuildModule] -> Set BuildModule
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Set BuildModule -> Set BuildModule -> Set BuildModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union [Set BuildModule
textual_deps, Set BuildModule
int_loop_deps, Set BuildModule
ext_loop_deps]

    -- All of the module's home-module dependencies.
    let home_deps_with_idx :: [(MVar SuccessFlag, Int)]
home_deps_with_idx =
            [ (MVar SuccessFlag, Int)
home_dep | BuildModule
dep <- Set BuildModule -> [BuildModule]
forall a. Set a -> [a]
Set.toList Set BuildModule
all_deps
                       , Just (MVar SuccessFlag, Int)
home_dep <- [BuildModule
-> Map BuildModule (MVar SuccessFlag, Int)
-> Maybe (MVar SuccessFlag, Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BuildModule
dep Map BuildModule (MVar SuccessFlag, Int)
home_mod_map]
                       ]

    -- Sort the list of dependencies in reverse-topological order. This way, by
    -- the time we get woken up by the result of an earlier dependency,
    -- subsequent dependencies are more likely to have finished. This step
    -- effectively reduces the number of MVars that each thread blocks on.
    let home_deps :: [MVar SuccessFlag]
home_deps = ((MVar SuccessFlag, Int) -> MVar SuccessFlag)
-> [(MVar SuccessFlag, Int)] -> [MVar SuccessFlag]
forall a b. (a -> b) -> [a] -> [b]
map (MVar SuccessFlag, Int) -> MVar SuccessFlag
forall a b. (a, b) -> a
fst ([(MVar SuccessFlag, Int)] -> [MVar SuccessFlag])
-> [(MVar SuccessFlag, Int)] -> [MVar SuccessFlag]
forall a b. (a -> b) -> a -> b
$ ((MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering)
-> [(MVar SuccessFlag, Int)] -> [(MVar SuccessFlag, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering)
-> (MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((MVar SuccessFlag, Int) -> Int)
-> (MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (MVar SuccessFlag, Int) -> Int
forall a b. (a, b) -> b
snd)) [(MVar SuccessFlag, Int)]
home_deps_with_idx

    -- Wait for the all the module's dependencies to finish building.
    Bool
deps_ok <- (MVar SuccessFlag -> IO Bool) -> [MVar SuccessFlag] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM ((SuccessFlag -> Bool) -> IO SuccessFlag -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SuccessFlag -> Bool
succeeded (IO SuccessFlag -> IO Bool)
-> (MVar SuccessFlag -> IO SuccessFlag)
-> MVar SuccessFlag
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar SuccessFlag -> IO SuccessFlag
forall a. MVar a -> IO a
readMVar) [MVar SuccessFlag]
home_deps

    -- We can't build this module if any of its dependencies failed to build.
    if Bool -> Bool
not Bool
deps_ok
      then SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
      else do
        -- Any hsc_env at this point is OK to use since we only really require
        -- that the HPT contains the HMIs of our dependencies.
        HscEnv
hsc_env <- MVar HscEnv -> IO HscEnv
forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
        HomePackageTable
old_hpt <- IORef HomePackageTable -> IO HomePackageTable
forall a. IORef a -> IO a
readIORef IORef HomePackageTable
old_hpt_var

        let logg :: SourceError -> IO ()
logg SourceError
err = Logger -> DynFlags -> ErrorMessages -> IO ()
forall a.
RenderableDiagnostic a =>
Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
printBagOfErrors Logger
lcl_logger DynFlags
lcl_dflags (SourceError -> ErrorMessages
srcErrorMessages SourceError
err)

        -- Limit the number of parallel compiles.
        let withSem :: QSem -> IO b -> IO b
withSem QSem
sem = IO () -> IO () -> IO b -> IO b
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
MC.bracket_ (QSem -> IO ()
waitQSem QSem
sem) (QSem -> IO ()
signalQSem QSem
sem)
        Maybe HomeModInfo
mb_mod_info <- QSem -> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall {b}. QSem -> IO b -> IO b
withSem QSem
par_sem (IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$
            (SourceError -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
err -> do SourceError -> IO ()
logg SourceError
err; Maybe HomeModInfo -> IO (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HomeModInfo
forall a. Maybe a
Nothing) (IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
                -- Have the HscEnv point to our local logger and tmpfs.
                let lcl_hsc_env :: HscEnv
lcl_hsc_env = HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env

                -- Re-typecheck the loop
                -- This is necessary to make sure the knot is tied when
                -- we close a recursive module loop, see bug #12035.
                IORef (NameEnv TyThing)
type_env_var <- IO (IORef (NameEnv TyThing)) -> IO (IORef (NameEnv TyThing))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (NameEnv TyThing)) -> IO (IORef (NameEnv TyThing)))
-> IO (IORef (NameEnv TyThing)) -> IO (IORef (NameEnv TyThing))
forall a b. (a -> b) -> a -> b
$ NameEnv TyThing -> IO (IORef (NameEnv TyThing))
forall a. a -> IO (IORef a)
newIORef NameEnv TyThing
forall a. NameEnv a
emptyNameEnv
                let lcl_hsc_env' :: HscEnv
lcl_hsc_env' = HscEnv
lcl_hsc_env { hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var =
                                    (Module, IORef (NameEnv TyThing))
-> Maybe (Module, IORef (NameEnv TyThing))
forall a. a -> Maybe a
Just (ModSummary -> Module
ms_mod ModSummary
mod, IORef (NameEnv TyThing)
type_env_var) }
                HscEnv
lcl_hsc_env'' <- case Maybe [ModuleWithIsBoot]
finish_loop of
                    Maybe [ModuleWithIsBoot]
Nothing   -> HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
lcl_hsc_env'
                    -- In the non-parallel case, the retypecheck prior to
                    -- typechecking the loop closer includes all modules
                    -- EXCEPT the loop closer.  However, our precomputed
                    -- SCCs include the loop closer, so we have to filter
                    -- it out.
                    Just [ModuleWithIsBoot]
loop -> DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
lcl_dflags HscEnv
lcl_hsc_env' ([ModuleName] -> IO HscEnv) -> [ModuleName] -> IO HscEnv
forall a b. (a -> b) -> a -> b
$
                                 (ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModuleWithIsBoot -> Module
forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleWithIsBoot
this_build_mod)) ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
                                 (ModuleWithIsBoot -> ModuleName)
-> [ModuleWithIsBoot] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (ModuleWithIsBoot -> Module) -> ModuleWithIsBoot -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleWithIsBoot -> Module
forall mod. GenWithIsBoot mod -> mod
gwib_mod) [ModuleWithIsBoot]
loop

                -- Compile the module.
                HomeModInfo
mod_info <- HscEnv
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
lcl_hsc_env'' Maybe Messager
mHscMessage HomePackageTable
old_hpt StableModules
stable_mods
                                        ModSummary
mod Int
mod_index Int
num_mods
                Maybe HomeModInfo -> IO (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just HomeModInfo
mod_info)

        case Maybe HomeModInfo
mb_mod_info of
            Maybe HomeModInfo
Nothing -> SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
            Just HomeModInfo
mod_info -> do
                let this_mod :: ModuleName
this_mod = ModSummary -> ModuleName
ms_mod_name ModSummary
mod

                -- Prune the old HPT unless this is an hs-boot module.
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ModSummary -> IsBootInterface
isBootSummary ModSummary
mod IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    IORef HomePackageTable
-> (HomePackageTable -> (HomePackageTable, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef HomePackageTable
old_hpt_var ((HomePackageTable -> (HomePackageTable, ())) -> IO ())
-> (HomePackageTable -> (HomePackageTable, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HomePackageTable
old_hpt ->
                        (HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt HomePackageTable
old_hpt ModuleName
this_mod, ())

                -- Update and fetch the global HscEnv.
                HscEnv
lcl_hsc_env' <- MVar HscEnv -> (HscEnv -> IO (HscEnv, HscEnv)) -> IO HscEnv
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar HscEnv
hsc_env_var ((HscEnv -> IO (HscEnv, HscEnv)) -> IO HscEnv)
-> (HscEnv -> IO (HscEnv, HscEnv)) -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
                    let hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env
                                     { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
                                                           ModuleName
this_mod HomeModInfo
mod_info }
                    -- We've finished typechecking the module, now we must
                    -- retypecheck the loop AGAIN to ensure unfoldings are
                    -- updated.  This time, however, we include the loop
                    -- closer!
                    HscEnv
hsc_env'' <- case Maybe [ModuleWithIsBoot]
finish_loop of
                        Maybe [ModuleWithIsBoot]
Nothing   -> HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env'
                        Just [ModuleWithIsBoot]
loop -> DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
lcl_dflags HscEnv
hsc_env' ([ModuleName] -> IO HscEnv) -> [ModuleName] -> IO HscEnv
forall a b. (a -> b) -> a -> b
$
                                     (ModuleWithIsBoot -> ModuleName)
-> [ModuleWithIsBoot] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (ModuleWithIsBoot -> Module) -> ModuleWithIsBoot -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleWithIsBoot -> Module
forall mod. GenWithIsBoot mod -> mod
gwib_mod) [ModuleWithIsBoot]
loop
                    (HscEnv, HscEnv) -> IO (HscEnv, HscEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env'', HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env'')

                -- Clean up any intermediate files.
                Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles (HscEnv -> Logger
hsc_logger HscEnv
lcl_hsc_env')
                                            (HscEnv -> TmpFs
hsc_tmpfs  HscEnv
lcl_hsc_env')
                                            (HscEnv -> DynFlags
hsc_dflags HscEnv
lcl_hsc_env')
                SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded

  where
    localize_hsc_env :: HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env
        = HscEnv
hsc_env { hsc_logger :: Logger
hsc_logger = Logger
lcl_logger
                  , hsc_tmpfs :: TmpFs
hsc_tmpfs  = TmpFs
lcl_tmpfs
                  }

-- -----------------------------------------------------------------------------
--
-- | The upsweep
--
-- This is where we compile each module in the module graph, in a pass
-- from the bottom to the top of the graph.
--
-- There better had not be any cyclic groups here -- we check for them.
upsweep
    :: forall m
    .  GhcMonad m
    => Maybe Messager
    -> HomePackageTable            -- ^ HPT from last time round (pruned)
    -> StableModules               -- ^ stable modules (see checkStability)
    -> [SCC ModuleGraphNode]       -- ^ Mods to do (the worklist)
    -> m (SuccessFlag,
          [ModuleGraphNode])
       -- ^ Returns:
       --
       --  1. A flag whether the complete upsweep was successful.
       --  2. The 'HscEnv' in the monad has an updated HPT
       --  3. A list of modules which succeeded loading.

upsweep :: forall (m :: * -> *).
GhcMonad m =>
Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
upsweep Maybe Messager
mHscMessage HomePackageTable
old_hpt StableModules
stable_mods [SCC ModuleGraphNode]
sccs = do
   (SuccessFlag
res, ModuleGraph
done) <- HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
emptyMG [SCC ModuleGraphNode]
sccs Int
1 ([SCC ModuleGraphNode] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModuleGraphNode]
sccs)
   (SuccessFlag, [ModuleGraphNode])
-> m (SuccessFlag, [ModuleGraphNode])
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
res, [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a]
reverse ([ModuleGraphNode] -> [ModuleGraphNode])
-> [ModuleGraphNode] -> [ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
done)
 where
  keep_going
    :: [NodeKey]
    -> HomePackageTable
    -> ModuleGraph
    -> [SCC ModuleGraphNode]
    -> Int
    -> Int
    -> m (SuccessFlag, ModuleGraph)
  keep_going :: [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
keep_going [NodeKey]
this_mods HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods Int
mod_index Int
nmods = do
    let sum_deps :: [NodeKey] -> SCC ModuleGraphNode -> [NodeKey]
sum_deps [NodeKey]
ms (AcyclicSCC ModuleGraphNode
iuidOrMod) =
          if (NodeKey -> Bool) -> [NodeKey] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((NodeKey -> [NodeKey] -> Bool) -> [NodeKey] -> NodeKey -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip NodeKey -> [NodeKey] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ([NodeKey] -> NodeKey -> Bool) -> [NodeKey] -> NodeKey -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> ModuleGraphNode -> [NodeKey]
unfilteredEdges Bool
False ModuleGraphNode
iuidOrMod) ([NodeKey] -> Bool) -> [NodeKey] -> Bool
forall a b. (a -> b) -> a -> b
$ [NodeKey]
ms
          then ModuleGraphNode -> NodeKey
mkHomeBuildModule ModuleGraphNode
iuidOrMod NodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
: [NodeKey]
ms
          else [NodeKey]
ms
        sum_deps [NodeKey]
ms SCC ModuleGraphNode
_ = [NodeKey]
ms
        dep_closure :: [NodeKey]
dep_closure = ([NodeKey] -> SCC ModuleGraphNode -> [NodeKey])
-> [NodeKey] -> [SCC ModuleGraphNode] -> [NodeKey]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [NodeKey] -> SCC ModuleGraphNode -> [NodeKey]
sum_deps [NodeKey]
this_mods [SCC ModuleGraphNode]
mods
        dropped_ms :: [NodeKey]
dropped_ms = Int -> [NodeKey] -> [NodeKey]
forall a. Int -> [a] -> [a]
drop ([NodeKey] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeKey]
this_mods) ([NodeKey] -> [NodeKey]
forall a. [a] -> [a]
reverse [NodeKey]
dep_closure)
        prunable :: SCC ModuleGraphNode -> Bool
prunable (AcyclicSCC ModuleGraphNode
node) = NodeKey -> [NodeKey] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (ModuleGraphNode -> NodeKey
mkHomeBuildModule ModuleGraphNode
node) [NodeKey]
dep_closure
        prunable SCC ModuleGraphNode
_ = Bool
False
        mods' :: [SCC ModuleGraphNode]
mods' = (SCC ModuleGraphNode -> Bool)
-> [SCC ModuleGraphNode] -> [SCC ModuleGraphNode]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (SCC ModuleGraphNode -> Bool) -> SCC ModuleGraphNode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC ModuleGraphNode -> Bool
prunable) [SCC ModuleGraphNode]
mods
        nmods' :: Int
nmods' = Int
nmods Int -> Int -> Int
forall a. Num a => a -> a -> a
- [NodeKey] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeKey]
dropped_ms

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [NodeKey] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeKey]
dropped_ms) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
        Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
fatalErrorMsg Logger
logger DynFlags
dflags ([NodeKey] -> SDoc
keepGoingPruneErr ([NodeKey] -> SDoc) -> [NodeKey] -> SDoc
forall a b. (a -> b) -> a -> b
$ [NodeKey]
dropped_ms)
    (SuccessFlag
_, ModuleGraph
done') <- HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods' (Int
mod_indexInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
nmods'
    (SuccessFlag, ModuleGraph) -> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done')

  upsweep'
    :: HomePackageTable
    -> ModuleGraph
    -> [SCC ModuleGraphNode]
    -> Int
    -> Int
    -> m (SuccessFlag, ModuleGraph)
  upsweep' :: HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
_old_hpt ModuleGraph
done
     [] Int
_ Int
_
     = (SuccessFlag, ModuleGraph) -> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Succeeded, ModuleGraph
done)

  upsweep' HomePackageTable
_old_hpt ModuleGraph
done
     (CyclicSCC [ModuleGraphNode]
ms : [SCC ModuleGraphNode]
mods) Int
mod_index Int
nmods
   = do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
        Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
fatalErrorMsg Logger
logger DynFlags
dflags ([ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
ms)
        if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepGoing DynFlags
dflags
          then [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
keep_going (ModuleGraphNode -> NodeKey
mkHomeBuildModule (ModuleGraphNode -> NodeKey) -> [ModuleGraphNode] -> [NodeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleGraphNode]
ms) HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods Int
mod_index Int
nmods
          else (SuccessFlag, ModuleGraph) -> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done)

  upsweep' HomePackageTable
old_hpt ModuleGraph
done
     (AcyclicSCC (InstantiationNode InstantiatedUnit
iuid) : [SCC ModuleGraphNode]
mods) Int
mod_index Int
nmods
   = do HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe Messager -> Int -> Int -> InstantiatedUnit -> IO ()
upsweep_inst HscEnv
hsc_env Maybe Messager
mHscMessage Int
mod_index Int
nmods InstantiatedUnit
iuid
        HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods (Int
mod_indexInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
nmods

  upsweep' HomePackageTable
old_hpt ModuleGraph
done
     (AcyclicSCC (ModuleNode ems :: ExtendedModSummary
ems@(ExtendedModSummary ModSummary
mod [InstantiatedUnit]
_)) : [SCC ModuleGraphNode]
mods) Int
mod_index Int
nmods
   = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
        --                     (moduleEnvElts (hsc_HPT hsc_env)))
        let logg :: p -> Maybe SourceError -> m ()
logg p
_mod = Maybe SourceError -> m ()
WarnErrLogger
defaultWarnErrLogger

        HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

        -- Remove unwanted tmp files between compilations
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
                                             (HscEnv -> TmpFs
hsc_tmpfs  HscEnv
hsc_env)
                                             (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)

        -- Get ready to tie the knot
        IORef (NameEnv TyThing)
type_env_var <- IO (IORef (NameEnv TyThing)) -> m (IORef (NameEnv TyThing))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (NameEnv TyThing)) -> m (IORef (NameEnv TyThing)))
-> IO (IORef (NameEnv TyThing)) -> m (IORef (NameEnv TyThing))
forall a b. (a -> b) -> a -> b
$ NameEnv TyThing -> IO (IORef (NameEnv TyThing))
forall a. a -> IO (IORef a)
newIORef NameEnv TyThing
forall a. NameEnv a
emptyNameEnv
        let hsc_env1 :: HscEnv
hsc_env1 = HscEnv
hsc_env { hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var =
                                    (Module, IORef (NameEnv TyThing))
-> Maybe (Module, IORef (NameEnv TyThing))
forall a. a -> Maybe a
Just (ModSummary -> Module
ms_mod ModSummary
mod, IORef (NameEnv TyThing)
type_env_var) }
        HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env1

        -- Lazily reload the HPT modules participating in the loop.
        -- See Note [Tying the knot]--if we don't throw out the old HPT
        -- and reinitalize the knot-tying process, anything that was forced
        -- while we were previously typechecking won't get updated, this
        -- was bug #12035.
        HscEnv
hsc_env2 <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env1 ModSummary
mod ModuleGraph
done
        HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env2

        Maybe HomeModInfo
mb_mod_info
            <- (SourceError -> m (Maybe HomeModInfo))
-> m (Maybe HomeModInfo) -> m (Maybe HomeModInfo)
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError
                   (\SourceError
err -> do ModSummary -> Maybe SourceError -> m ()
forall {m :: * -> *} {p}.
GhcMonad m =>
p -> Maybe SourceError -> m ()
logg ModSummary
mod (SourceError -> Maybe SourceError
forall a. a -> Maybe a
Just SourceError
err); Maybe HomeModInfo -> m (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HomeModInfo
forall a. Maybe a
Nothing) (m (Maybe HomeModInfo) -> m (Maybe HomeModInfo))
-> m (Maybe HomeModInfo) -> m (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
                 HomeModInfo
mod_info <- IO HomeModInfo -> m HomeModInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HomeModInfo -> m HomeModInfo)
-> IO HomeModInfo -> m HomeModInfo
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
hsc_env2 Maybe Messager
mHscMessage HomePackageTable
old_hpt StableModules
stable_mods
                                                  ModSummary
mod Int
mod_index Int
nmods
                 ModSummary -> Maybe SourceError -> m ()
forall {m :: * -> *} {p}.
GhcMonad m =>
p -> Maybe SourceError -> m ()
logg ModSummary
mod Maybe SourceError
forall a. Maybe a
Nothing -- log warnings
                 Maybe HomeModInfo -> m (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just HomeModInfo
mod_info)

        case Maybe HomeModInfo
mb_mod_info of
          Maybe HomeModInfo
Nothing -> do
                DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
                if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepGoing DynFlags
dflags
                  then [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
keep_going [ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey) -> ModNodeKey -> NodeKey
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModNodeKey
mkHomeBuildModule0 ModSummary
mod] HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods Int
mod_index Int
nmods
                  else (SuccessFlag, ModuleGraph) -> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done)
          Just HomeModInfo
mod_info -> do
                let this_mod :: ModuleName
this_mod = ModSummary -> ModuleName
ms_mod_name ModSummary
mod

                        -- Add new info to hsc_env
                    hpt1 :: HomePackageTable
hpt1     = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env2) ModuleName
this_mod HomeModInfo
mod_info
                    hsc_env3 :: HscEnv
hsc_env3 = HscEnv
hsc_env2 { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
hpt1, hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var = Maybe (Module, IORef (NameEnv TyThing))
forall a. Maybe a
Nothing }

                        -- Space-saving: delete the old HPT entry
                        -- for mod BUT if mod is a hs-boot
                        -- node, don't delete it.  For the
                        -- interface, the HPT entry is probably for the
                        -- main Haskell source file.  Deleting it
                        -- would force the real module to be recompiled
                        -- every time.
                    old_hpt1 :: HomePackageTable
old_hpt1 = case ModSummary -> IsBootInterface
isBootSummary ModSummary
mod of
                      IsBootInterface
IsBoot -> HomePackageTable
old_hpt
                      IsBootInterface
NotBoot -> HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt HomePackageTable
old_hpt ModuleName
this_mod

                    done' :: ModuleGraph
done' = ModuleGraph -> ExtendedModSummary -> ModuleGraph
extendMG ModuleGraph
done ExtendedModSummary
ems

                        -- fixup our HomePackageTable after we've finished compiling
                        -- a mutually-recursive loop.  We have to do this again
                        -- to make sure we have the final unfoldings, which may
                        -- not have been computed accurately in the previous
                        -- retypecheck.
                HscEnv
hsc_env4 <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env3 ModSummary
mod ModuleGraph
done'
                HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env4

                        -- Add any necessary entries to the static pointer
                        -- table. See Note [Grand plan for static forms] in
                        -- GHC.Iface.Tidy.StaticPtrTable.
                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env4) Backend -> Backend -> Bool
forall a. Eq a => a -> a -> Bool
== Backend
Interpreter) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env4
                                 [ SptEntry
spt
                                 | Just Linkable
linkable <- Maybe Linkable -> [Maybe Linkable]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Linkable -> [Maybe Linkable])
-> Maybe Linkable -> [Maybe Linkable]
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
mod_info
                                 , Unlinked
unlinked <- Linkable -> [Unlinked]
linkableUnlinked Linkable
linkable
                                 , BCOs CompiledByteCode
_ [SptEntry]
spts <- Unlinked -> [Unlinked]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Unlinked
unlinked
                                 , SptEntry
spt <- [SptEntry]
spts
                                 ]

                HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt1 ModuleGraph
done' [SCC ModuleGraphNode]
mods (Int
mod_indexInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
nmods

maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate DynFlags
dflags ModLocation
location
 | DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags
    -- Minor optimization: it should be harmless to check the hi file location
    -- always, but it's better to avoid hitting the filesystem if possible.
    = FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
location)
 | Bool
otherwise
    = Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing

upsweep_inst :: HscEnv
             -> Maybe Messager
             -> Int  -- index of module
             -> Int  -- total number of modules
             -> InstantiatedUnit
             -> IO ()
upsweep_inst :: HscEnv -> Maybe Messager -> Int -> Int -> InstantiatedUnit -> IO ()
upsweep_inst HscEnv
hsc_env Maybe Messager
mHscMessage Int
mod_index Int
nmods InstantiatedUnit
iuid = do
        case Maybe Messager
mHscMessage of
            Just Messager
hscMessage -> Messager
hscMessage HscEnv
hsc_env (Int
mod_index, Int
nmods) RecompileRequired
MustCompile (InstantiatedUnit -> ModuleGraphNode
InstantiationNode InstantiatedUnit
iuid)
            Maybe Messager
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        HscEnv -> Hsc () -> IO ()
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc () -> IO ()) -> Hsc () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Messages DecoratedSDoc, Maybe ()) -> Hsc ()
forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages DecoratedSDoc, Maybe ()) -> Hsc ())
-> IO (Messages DecoratedSDoc, Maybe ()) -> Hsc ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> Unit -> IO (Messages DecoratedSDoc, Maybe ())
tcRnCheckUnit HscEnv
hsc_env (Unit -> IO (Messages DecoratedSDoc, Maybe ()))
-> Unit -> IO (Messages DecoratedSDoc, Maybe ())
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid
        () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Compile a single module.  Always produce a Linkable for it if
-- successful.  If no compilation happened, return the old Linkable.
upsweep_mod :: HscEnv
            -> Maybe Messager
            -> HomePackageTable
            -> StableModules
            -> ModSummary
            -> Int  -- index of module
            -> Int  -- total number of modules
            -> IO HomeModInfo
upsweep_mod :: HscEnv
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
hsc_env Maybe Messager
mHscMessage HomePackageTable
old_hpt (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco) ModSummary
summary Int
mod_index Int
nmods
   =    let
            this_mod_name :: ModuleName
this_mod_name = ModSummary -> ModuleName
ms_mod_name ModSummary
summary
            this_mod :: Module
this_mod    = ModSummary -> Module
ms_mod ModSummary
summary
            mb_obj_date :: Maybe UTCTime
mb_obj_date = ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
summary
            mb_if_date :: Maybe UTCTime
mb_if_date  = ModSummary -> Maybe UTCTime
ms_iface_date ModSummary
summary
            obj_fn :: FilePath
obj_fn      = ModLocation -> FilePath
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
summary)
            hs_date :: UTCTime
hs_date     = ModSummary -> UTCTime
ms_hs_date ModSummary
summary

            is_stable_obj :: Bool
is_stable_obj = ModuleName
this_mod_name ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj
            is_stable_bco :: Bool
is_stable_bco = ModuleName
this_mod_name ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco

            old_hmi :: Maybe HomeModInfo
old_hmi = HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
old_hpt ModuleName
this_mod_name

            -- We're using the dflags for this module now, obtained by
            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
            lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary
            prevailing_backend :: Backend
prevailing_backend = DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
            local_backend :: Backend
local_backend      = DynFlags -> Backend
backend DynFlags
lcl_dflags

            -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that
            -- we don't do anything dodgy: these should only work to change
            -- from -fllvm to -fasm and vice-versa, or away from -fno-code,
            -- otherwise we could end up trying to link object code to byte
            -- code.
            bcknd :: Backend
bcknd = case (Backend
prevailing_backend,Backend
local_backend) of
               (Backend
LLVM,Backend
NCG) -> Backend
NCG
               (Backend
NCG,Backend
LLVM) -> Backend
LLVM
               (Backend
NoBackend,Backend
b)
                  | Backend -> Bool
backendProducesObject Backend
b -> Backend
b
               (Backend
Interpreter,Backend
b)
                  | Backend -> Bool
backendProducesObject Backend
b -> Backend
b
               (Backend, Backend)
_ -> Backend
prevailing_backend

            -- store the corrected backend into the summary
            summary' :: ModSummary
summary' = ModSummary
summary{ ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
lcl_dflags { backend :: Backend
backend = Backend
bcknd } }

            -- The old interface is ok if
            --  a) we're compiling a source file, and the old HPT
            --     entry is for a source file
            --  b) we're compiling a hs-boot file
            -- Case (b) allows an hs-boot file to get the interface of its
            -- real source file on the second iteration of the compilation
            -- manager, but that does no harm.  Otherwise the hs-boot file
            -- will always be recompiled

            mb_old_iface :: Maybe (ModIface_ 'ModIfaceFinal)
mb_old_iface
                = case Maybe HomeModInfo
old_hmi of
                     Maybe HomeModInfo
Nothing                                        -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. Maybe a
Nothing
                     Just HomeModInfo
hm_info | ModSummary -> IsBootInterface
isBootSummary ModSummary
summary IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot -> ModIface_ 'ModIfaceFinal -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. a -> Maybe a
Just ModIface_ 'ModIfaceFinal
iface
                                  | ModIface_ 'ModIfaceFinal -> IsBootInterface
mi_boot ModIface_ 'ModIfaceFinal
iface IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot        -> ModIface_ 'ModIfaceFinal -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. a -> Maybe a
Just ModIface_ 'ModIfaceFinal
iface
                                  | Bool
otherwise                       -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. Maybe a
Nothing
                                   where
                                     iface :: ModIface_ 'ModIfaceFinal
iface = HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
hm_info

            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it  Maybe Linkable
mb_linkable SourceModified
src_modified =
                  Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe (ModIface_ 'ModIfaceFinal)
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' Maybe TcGblEnv
forall a. Maybe a
Nothing Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary' Int
mod_index Int
nmods
                             Maybe (ModIface_ 'ModIfaceFinal)
mb_old_iface Maybe Linkable
mb_linkable SourceModified
src_modified

            compile_it_discard_iface :: Maybe Linkable -> SourceModified
                                     -> IO HomeModInfo
            compile_it_discard_iface :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it_discard_iface Maybe Linkable
mb_linkable  SourceModified
src_modified =
                  Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe (ModIface_ 'ModIfaceFinal)
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' Maybe TcGblEnv
forall a. Maybe a
Nothing Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary' Int
mod_index Int
nmods
                             Maybe (ModIface_ 'ModIfaceFinal)
forall a. Maybe a
Nothing Maybe Linkable
mb_linkable SourceModified
src_modified

            -- With NoBackend we create empty linkables to avoid recompilation.
            -- We have to detect these to recompile anyway if the backend changed
            -- since the last compile.
            is_fake_linkable :: Bool
is_fake_linkable
               | Just HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi, Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi =
                  [Unlinked] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Linkable -> [Unlinked]
linkableUnlinked Linkable
l)
               | Bool
otherwise =
                   -- we have no linkable, so it cannot be fake
                   Bool
False

            implies :: Bool -> Bool -> Bool
implies Bool
False Bool
_ = Bool
True
            implies Bool
True Bool
x  = Bool
x

            debug_trace :: Int -> SDoc -> IO ()
debug_trace Int
n SDoc
t = IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int
n SDoc
t

        in
        case () of
         ()
_
                -- Regardless of whether we're generating object code or
                -- byte code, we can always use an existing object file
                -- if it is *stable* (see checkStability).
          | Bool
is_stable_obj, Just HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi -> do
                Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"skipping stable obj mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi
                -- object is stable, and we have an entry in the
                -- old HPT: nothing to do

          | Bool
is_stable_obj, Maybe HomeModInfo -> Bool
forall a. Maybe a -> Bool
isNothing Maybe HomeModInfo
old_hmi -> do
                Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling stable on-disk mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                Linkable
linkable <- IO Linkable -> IO Linkable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Linkable -> IO Linkable) -> IO Linkable -> IO Linkable
forall a b. (a -> b) -> a -> b
$ Module -> FilePath -> UTCTime -> IO Linkable
findObjectLinkable Module
this_mod FilePath
obj_fn
                              (FilePath -> Maybe UTCTime -> UTCTime
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"upsweep1" Maybe UTCTime
mb_obj_date)
                Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable) SourceModified
SourceUnmodifiedAndStable
                -- object is stable, but we need to load the interface
                -- off disk to make a HMI.

          | Bool -> Bool
not (Backend -> Bool
backendProducesObject Backend
bcknd), Bool
is_stable_bco,
            (Backend
bcknd Backend -> Backend -> Bool
forall a. Eq a => a -> a -> Bool
/= Backend
NoBackend) Bool -> Bool -> Bool
`implies` Bool -> Bool
not Bool
is_fake_linkable ->
                ASSERT(isJust old_hmi) -- must be in the old_hpt
                let Just HomeModInfo
hmi = Maybe HomeModInfo
old_hmi in do
                Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"skipping stable BCO mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi
                -- BCO is stable: nothing to do

          | Bool -> Bool
not (Backend -> Bool
backendProducesObject Backend
bcknd),
            Just HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi,
            Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi,
            Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
l),
            (Backend
bcknd Backend -> Backend -> Bool
forall a. Eq a => a -> a -> Bool
/= Backend
NoBackend) Bool -> Bool -> Bool
`implies` Bool -> Bool
not Bool
is_fake_linkable,
            Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
summary -> do
                Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling non-stable BCO mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
l) SourceModified
SourceUnmodified
                -- we have an old BCO that is up to date with respect
                -- to the source: do a recompilation check as normal.

          -- When generating object code, if there's an up-to-date
          -- object file on the disk, then we can use it.
          -- However, if the object file is new (compared to any
          -- linkable we had from a previous compilation), then we
          -- must discard any in-memory interface, because this
          -- means the user has compiled the source file
          -- separately and generated a new interface, that we must
          -- read from the disk.
          --
          | Backend -> Bool
backendProducesObject Backend
bcknd,
            Just UTCTime
obj_date <- Maybe UTCTime
mb_obj_date,
            UTCTime
obj_date UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
hs_date -> do
                case Maybe HomeModInfo
old_hmi of
                  Just HomeModInfo
hmi
                    | Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi,
                      Linkable -> Bool
isObjectLinkable Linkable
l Bool -> Bool -> Bool
&& Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
obj_date -> do
                          Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling mod with new on-disk obj:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                          Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
l) SourceModified
SourceUnmodified
                  Maybe HomeModInfo
_otherwise -> do
                          Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling mod with new on-disk obj2:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                          Linkable
linkable <- IO Linkable -> IO Linkable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Linkable -> IO Linkable) -> IO Linkable -> IO Linkable
forall a b. (a -> b) -> a -> b
$ Module -> FilePath -> UTCTime -> IO Linkable
findObjectLinkable Module
this_mod FilePath
obj_fn UTCTime
obj_date
                          Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it_discard_iface (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable) SourceModified
SourceUnmodified

          -- See Note [Recompilation checking in -fno-code mode]
          | DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
lcl_dflags,
            Just UTCTime
if_date <- Maybe UTCTime
mb_if_date,
            UTCTime
if_date UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
hs_date -> do
                Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"skipping tc'd mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it Maybe Linkable
forall a. Maybe a
Nothing SourceModified
SourceUnmodified

         ()
_otherwise -> do
                Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it Maybe Linkable
forall a. Maybe a
Nothing SourceModified
SourceModified


{- Note [-fno-code mode]
~~~~~~~~~~~~~~~~~~~~~~~~
GHC offers the flag -fno-code for the purpose of parsing and typechecking a
program without generating object files. This is intended to be used by tooling
and IDEs to provide quick feedback on any parser or type errors as cheaply as
possible.

When GHC is invoked with -fno-code no object files or linked output will be
generated. As many errors and warnings as possible will be generated, as if
-fno-code had not been passed. The session DynFlags will have
backend == NoBackend.

-fwrite-interface
~~~~~~~~~~~~~~~~
Whether interface files are generated in -fno-code mode is controlled by the
-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
not also passed. Recompilation avoidance requires interface files, so passing
-fno-code without -fwrite-interface should be avoided. If -fno-code were
re-implemented today, -fwrite-interface would be discarded and it would be
considered always on; this behaviour is as it is for backwards compatibility.

================================================================
IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
================================================================

Template Haskell
~~~~~~~~~~~~~~~~
A module using template haskell may invoke an imported function from inside a
splice. This will cause the type-checker to attempt to execute that code, which
would fail if no object files had been generated. See #8025. To rectify this,
during the downsweep we patch the DynFlags in the ModSummary of any home module
that is imported by a module that uses template haskell, to generate object
code.

The flavour of generated object code is chosen by defaultObjectTarget for the
target platform. It would likely be faster to generate bytecode, but this is not
supported on all platforms(?Please Confirm?), and does not support the entirety
of GHC haskell. See #1257.

The object files (and interface files if -fwrite-interface is disabled) produced
for template haskell are written to temporary files.

Note that since template haskell can run arbitrary IO actions, -fno-code mode
is no more secure than running without it.

Potential TODOS:
~~~~~
* Remove -fwrite-interface and have interface files always written in -fno-code
  mode
* Both .o and .dyn_o files are generated for template haskell, but we only need
  .dyn_o. Fix it.
* In make mode, a message like
  Compiling A (A.hs, /tmp/ghc_123.o)
  is shown if downsweep enabled object code generation for A. Perhaps we should
  show "nothing" or "temporary object file" instead. Note that one
  can currently use -keep-tmp-files and inspect the generated file with the
  current behaviour.
* Offer a -no-codedir command line option, and write what were temporary
  object files there. This would speed up recompilation.
* Use existing object files (if they are up to date) instead of always
  generating temporary ones.
-}

-- Note [Recompilation checking in -fno-code mode]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- If we are compiling with -fno-code -fwrite-interface, there won't
-- be any object code that we can compare against, nor should there
-- be: we're *just* generating interface files.  In this case, we
-- want to check if the interface file is new, in lieu of the object
-- file.  See also #9243.

-- Filter modules in the HPT
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs [ModuleName]
keep_these HomePackageTable
hpt
   = [(ModuleName, HomeModInfo)] -> HomePackageTable
listToHpt   [ (ModuleName
mod, FilePath -> Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"retain" Maybe HomeModInfo
mb_mod_info)
                 | ModuleName
mod <- [ModuleName]
keep_these
                 , let mb_mod_info :: Maybe HomeModInfo
mb_mod_info = HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt ModuleName
mod
                 , Maybe HomeModInfo -> Bool
forall a. Maybe a -> Bool
isJust Maybe HomeModInfo
mb_mod_info ]

-- ---------------------------------------------------------------------------
-- Typecheck module loops
{-
See bug #930.  This code fixes a long-standing bug in --make.  The
problem is that when compiling the modules *inside* a loop, a data
type that is only defined at the top of the loop looks opaque; but
after the loop is done, the structure of the data type becomes
apparent.

The difficulty is then that two different bits of code have
different notions of what the data type looks like.

The idea is that after we compile a module which also has an .hs-boot
file, we re-generate the ModDetails for each of the modules that
depends on the .hs-boot file, so that everyone points to the proper
TyCons, Ids etc. defined by the real module, not the boot module.
Fortunately re-generating a ModDetails from a ModIface is easy: the
function GHC.IfaceToCore.typecheckIface does exactly that.

Picking the modules to re-typecheck is slightly tricky.  Starting from
the module graph consisting of the modules that have already been
compiled, we reverse the edges (so they point from the imported module
to the importing module), and depth-first-search from the .hs-boot
node.  This gives us all the modules that depend transitively on the
.hs-boot module, and those are exactly the modules that we need to
re-typecheck.

Following this fix, GHC can compile itself with --make -O2.
-}

reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env ModSummary
ms ModuleGraph
graph
  | Just [ModuleGraphNode]
loop <- ModSummary
-> [ModuleGraphNode] -> (Module -> Bool) -> Maybe [ModuleGraphNode]
getModLoop ModSummary
ms [ModuleGraphNode]
mss Module -> Bool
appearsAsBoot
  -- SOME hs-boot files should still
  -- get used, just not the loop-closer.
  , let non_boot :: [ModSummary]
non_boot = ((ModuleGraphNode -> Maybe ModSummary)
 -> [ModuleGraphNode] -> [ModSummary])
-> [ModuleGraphNode]
-> (ModuleGraphNode -> Maybe ModSummary)
-> [ModSummary]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleGraphNode -> Maybe ModSummary)
-> [ModuleGraphNode] -> [ModSummary]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [ModuleGraphNode]
loop ((ModuleGraphNode -> Maybe ModSummary) -> [ModSummary])
-> (ModuleGraphNode -> Maybe ModSummary) -> [ModSummary]
forall a b. (a -> b) -> a -> b
$ \case
          InstantiationNode InstantiatedUnit
_ -> Maybe ModSummary
forall a. Maybe a
Nothing
          ModuleNode ExtendedModSummary
ems -> do
            let l :: ModSummary
l = ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ModSummary -> IsBootInterface
isBootSummary ModSummary
l IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot Bool -> Bool -> Bool
&& ModSummary -> Module
ms_mod ModSummary
l Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> Module
ms_mod ModSummary
ms
            ModSummary -> Maybe ModSummary
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModSummary
l
  = DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) HscEnv
hsc_env ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
non_boot)
  | Bool
otherwise
  = HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
  where
  mss :: [ModuleGraphNode]
mss = ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
graph
  appearsAsBoot :: Module -> Bool
appearsAsBoot = (Module -> ModuleSet -> Bool
`elemModuleSet` ModuleGraph -> ModuleSet
mgBootModules ModuleGraph
graph)

-- | Given a non-boot ModSummary @ms@ of a module, for which there exists a
-- corresponding boot file in @graph@, return the set of modules which
-- transitively depend on this boot file.  This function is slightly misnamed,
-- but its name "getModLoop" alludes to the fact that, when getModLoop is called
-- with a graph that does not contain @ms@ (non-parallel case) or is an
-- SCC with hs-boot nodes dropped (parallel-case), the modules which
-- depend on the hs-boot file are typically (but not always) the
-- modules participating in the recursive module loop.  The returned
-- list includes the hs-boot file.
--
-- Example:
--      let g represent the module graph:
--          C.hs
--          A.hs-boot imports C.hs
--          B.hs imports A.hs-boot
--          A.hs imports B.hs
--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs]
--
--      It would also be permissible to omit A.hs from the graph,
--      in which case the result is [A.hs-boot, B.hs]
--
-- Example:
--      A counter-example to the claim that modules returned
--      by this function participate in the loop occurs here:
--
--      let g represent the module graph:
--          C.hs
--          A.hs-boot imports C.hs
--          B.hs imports A.hs-boot
--          A.hs imports B.hs
--          D.hs imports A.hs-boot
--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs]
--
--      Arguably, D.hs should import A.hs, not A.hs-boot, but
--      a dependency on the boot file is not illegal.
--
getModLoop
  :: ModSummary
  -> [ModuleGraphNode]
  -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'
  -> Maybe [ModuleGraphNode]
getModLoop :: ModSummary
-> [ModuleGraphNode] -> (Module -> Bool) -> Maybe [ModuleGraphNode]
getModLoop ModSummary
ms [ModuleGraphNode]
graph Module -> Bool
appearsAsBoot
  | ModSummary -> IsBootInterface
isBootSummary ModSummary
ms IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot
  , Module -> Bool
appearsAsBoot Module
this_mod
  , let mss :: [ModuleGraphNode]
mss = ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]
reachableBackwards (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) [ModuleGraphNode]
graph
  = [ModuleGraphNode] -> Maybe [ModuleGraphNode]
forall a. a -> Maybe a
Just [ModuleGraphNode]
mss
  | Bool
otherwise
  = Maybe [ModuleGraphNode]
forall a. Maybe a
Nothing
 where
  this_mod :: Module
this_mod = ModSummary -> Module
ms_mod ModSummary
ms

-- NB: sometimes mods has duplicates; this is harmless because
-- any duplicates get clobbered in addListToHpt and never get forced.
typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
dflags HscEnv
hsc_env [ModuleName]
mods = do
  Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
     FilePath -> SDoc
text FilePath
"Re-typechecking loop: " SDoc -> SDoc -> SDoc
<> [ModuleName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
mods
  HomePackageTable
new_hpt <-
    (HomePackageTable -> IO HomePackageTable) -> IO HomePackageTable
forall a. (a -> IO a) -> IO a
fixIO ((HomePackageTable -> IO HomePackageTable) -> IO HomePackageTable)
-> (HomePackageTable -> IO HomePackageTable) -> IO HomePackageTable
forall a b. (a -> b) -> a -> b
$ \HomePackageTable
new_hpt -> do
      let new_hsc_env :: HscEnv
new_hsc_env = HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
new_hpt }
      [ModDetails]
mds <- SDoc -> HscEnv -> IfG [ModDetails] -> IO [ModDetails]
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (FilePath -> SDoc
text FilePath
"typecheckLoop") HscEnv
new_hsc_env (IfG [ModDetails] -> IO [ModDetails])
-> IfG [ModDetails] -> IO [ModDetails]
forall a b. (a -> b) -> a -> b
$
                (HomeModInfo -> IOEnv (Env IfGblEnv ()) ModDetails)
-> [HomeModInfo] -> IfG [ModDetails]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModIface_ 'ModIfaceFinal -> IOEnv (Env IfGblEnv ()) ModDetails
typecheckIface (ModIface_ 'ModIfaceFinal -> IOEnv (Env IfGblEnv ()) ModDetails)
-> (HomeModInfo -> ModIface_ 'ModIfaceFinal)
-> HomeModInfo
-> IOEnv (Env IfGblEnv ()) ModDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface) [HomeModInfo]
hmis
      let new_hpt :: HomePackageTable
new_hpt = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt HomePackageTable
old_hpt
                        ([ModuleName] -> [HomeModInfo] -> [(ModuleName, HomeModInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
mods [ HomeModInfo
hmi{ hm_details :: ModDetails
hm_details = ModDetails
details }
                                  | (HomeModInfo
hmi,ModDetails
details) <- [HomeModInfo] -> [ModDetails] -> [(HomeModInfo, ModDetails)]
forall a b. [a] -> [b] -> [(a, b)]
zip [HomeModInfo]
hmis [ModDetails]
mds ])
      HomePackageTable -> IO HomePackageTable
forall (m :: * -> *) a. Monad m => a -> m a
return HomePackageTable
new_hpt
  HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
new_hpt }
  where
    logger :: Logger
logger  = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    old_hpt :: HomePackageTable
old_hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
    hmis :: [HomeModInfo]
hmis    = (ModuleName -> HomeModInfo) -> [ModuleName] -> [HomeModInfo]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"typecheckLoop" (Maybe HomeModInfo -> HomeModInfo)
-> (ModuleName -> Maybe HomeModInfo) -> ModuleName -> HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
old_hpt) [ModuleName]
mods

reachableBackwards :: ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]
reachableBackwards :: ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]
reachableBackwards ModuleName
mod [ModuleGraphNode]
summaries
  = [ Node Int ModuleGraphNode -> ModuleGraphNode
forall key payload. Node key payload -> payload
node_payload Node Int ModuleGraphNode
node | Node Int ModuleGraphNode
node <- Graph (Node Int ModuleGraphNode)
-> Node Int ModuleGraphNode -> [Node Int ModuleGraphNode]
forall node. Graph node -> node -> [node]
reachableG (Graph (Node Int ModuleGraphNode)
-> Graph (Node Int ModuleGraphNode)
forall node. Graph node -> Graph node
transposeG Graph (Node Int ModuleGraphNode)
graph) Node Int ModuleGraphNode
root ]
  where -- the rest just sets up the graph:
        (Graph (Node Int ModuleGraphNode)
graph, NodeKey -> Maybe (Node Int ModuleGraphNode)
lookup_node) = Bool
-> [ModuleGraphNode]
-> (Graph (Node Int ModuleGraphNode),
    NodeKey -> Maybe (Node Int ModuleGraphNode))
moduleGraphNodes Bool
False [ModuleGraphNode]
summaries
        root :: Node Int ModuleGraphNode
root  = FilePath
-> Maybe (Node Int ModuleGraphNode) -> Node Int ModuleGraphNode
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"reachableBackwards" (NodeKey -> Maybe (Node Int ModuleGraphNode)
lookup_node (NodeKey -> Maybe (Node Int ModuleGraphNode))
-> NodeKey -> Maybe (Node Int ModuleGraphNode)
forall a b. (a -> b) -> a -> b
$ ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey) -> ModNodeKey -> NodeKey
forall a b. (a -> b) -> a -> b
$ ModuleName -> IsBootInterface -> ModNodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mod IsBootInterface
IsBoot)

-- ---------------------------------------------------------------------------
--
-- | Topological sort of the module graph
topSortModuleGraph
          :: Bool
          -- ^ Drop hi-boot nodes? (see below)
          -> ModuleGraph
          -> Maybe ModuleName
             -- ^ Root module name.  If @Nothing@, use the full graph.
          -> [SCC ModuleGraphNode]
-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
-- The resulting list of strongly-connected-components is in topologically
-- sorted order, starting with the module(s) at the bottom of the
-- dependency graph (ie compile them first) and ending with the ones at
-- the top.
--
-- Drop hi-boot nodes (first boolean arg)?
--
-- - @False@:   treat the hi-boot summaries as nodes of the graph,
--              so the graph must be acyclic
--
-- - @True@:    eliminate the hi-boot nodes, and instead pretend
--              the a source-import of Foo is an import of Foo
--              The resulting graph has no hi-boot nodes, but can be cyclic

topSortModuleGraph :: Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
drop_hs_boot_nodes ModuleGraph
module_graph Maybe ModuleName
mb_root_mod
  = (SCC (Node Int ModuleGraphNode) -> SCC ModuleGraphNode)
-> [SCC (Node Int ModuleGraphNode)] -> [SCC ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
map ((Node Int ModuleGraphNode -> ModuleGraphNode)
-> SCC (Node Int ModuleGraphNode) -> SCC ModuleGraphNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node Int ModuleGraphNode -> ModuleGraphNode
summaryNodeSummary) ([SCC (Node Int ModuleGraphNode)] -> [SCC ModuleGraphNode])
-> [SCC (Node Int ModuleGraphNode)] -> [SCC ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ Graph (Node Int ModuleGraphNode)
-> [SCC (Node Int ModuleGraphNode)]
forall node. Graph node -> [SCC node]
stronglyConnCompG Graph (Node Int ModuleGraphNode)
initial_graph
  where
    summaries :: [ModuleGraphNode]
summaries = ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
module_graph
    -- stronglyConnCompG flips the original order, so if we reverse
    -- the summaries we get a stable topological sort.
    (Graph (Node Int ModuleGraphNode)
graph, NodeKey -> Maybe (Node Int ModuleGraphNode)
lookup_node) =
      Bool
-> [ModuleGraphNode]
-> (Graph (Node Int ModuleGraphNode),
    NodeKey -> Maybe (Node Int ModuleGraphNode))
moduleGraphNodes Bool
drop_hs_boot_nodes ([ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a]
reverse [ModuleGraphNode]
summaries)

    initial_graph :: Graph (Node Int ModuleGraphNode)
initial_graph = case Maybe ModuleName
mb_root_mod of
        Maybe ModuleName
Nothing -> Graph (Node Int ModuleGraphNode)
graph
        Just ModuleName
root_mod ->
            -- restrict the graph to just those modules reachable from
            -- the specified module.  We do this by building a graph with
            -- the full set of nodes, and determining the reachable set from
            -- the specified node.
            let root :: Node Int ModuleGraphNode
root | Just Node Int ModuleGraphNode
node <- NodeKey -> Maybe (Node Int ModuleGraphNode)
lookup_node (NodeKey -> Maybe (Node Int ModuleGraphNode))
-> NodeKey -> Maybe (Node Int ModuleGraphNode)
forall a b. (a -> b) -> a -> b
$ ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey) -> ModNodeKey -> NodeKey
forall a b. (a -> b) -> a -> b
$ ModuleName -> IsBootInterface -> ModNodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
root_mod IsBootInterface
NotBoot
                     , Graph (Node Int ModuleGraphNode)
graph Graph (Node Int ModuleGraphNode)
-> Node Int ModuleGraphNode -> Bool
forall node. Graph node -> node -> Bool
`hasVertexG` Node Int ModuleGraphNode
node
                     = Node Int ModuleGraphNode
node
                     | Bool
otherwise
                     = GhcException -> Node Int ModuleGraphNode
forall a. GhcException -> a
throwGhcException (FilePath -> GhcException
ProgramError FilePath
"module does not exist")
            in [Node Int ModuleGraphNode] -> Graph (Node Int ModuleGraphNode)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq (Node Int ModuleGraphNode
-> [Node Int ModuleGraphNode] -> [Node Int ModuleGraphNode]
seq Node Int ModuleGraphNode
root (Graph (Node Int ModuleGraphNode)
-> Node Int ModuleGraphNode -> [Node Int ModuleGraphNode]
forall node. Graph node -> node -> [node]
reachableG Graph (Node Int ModuleGraphNode)
graph Node Int ModuleGraphNode
root))

type SummaryNode = Node Int ModuleGraphNode

summaryNodeKey :: SummaryNode -> Int
summaryNodeKey :: Node Int ModuleGraphNode -> Int
summaryNodeKey = Node Int ModuleGraphNode -> Int
forall key payload. Node key payload -> key
node_key

summaryNodeSummary :: SummaryNode -> ModuleGraphNode
summaryNodeSummary :: Node Int ModuleGraphNode -> ModuleGraphNode
summaryNodeSummary = Node Int ModuleGraphNode -> ModuleGraphNode
forall key payload. Node key payload -> payload
node_payload

-- | Collect the immediate dependencies of a ModuleGraphNode,
-- optionally avoiding hs-boot dependencies.
-- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is
-- an equivalent .hs-boot, add a link from the former to the latter.  This
-- has the effect of detecting bogus cases where the .hs-boot depends on the
-- .hs, by introducing a cycle.  Additionally, it ensures that we will always
-- process the .hs-boot before the .hs, and so the HomePackageTable will always
-- have the most up to date information.
unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]
unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]
unfilteredEdges Bool
drop_hs_boot_nodes = \case
    InstantiationNode InstantiatedUnit
iuid ->
      ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey)
-> (ModuleName -> ModNodeKey) -> ModuleName -> NodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> IsBootInterface -> ModNodeKey)
-> IsBootInterface -> ModuleName -> ModNodeKey
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleName -> IsBootInterface -> ModNodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB IsBootInterface
NotBoot (ModuleName -> NodeKey) -> [ModuleName] -> [NodeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UniqDSet ModuleName -> [ModuleName]
forall a. UniqDSet a -> [a]
uniqDSetToList (InstantiatedUnit -> UniqDSet ModuleName
forall unit. GenInstantiatedUnit unit -> UniqDSet ModuleName
instUnitHoles InstantiatedUnit
iuid)
    ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bds) ->
      (ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey)
-> (GenLocated SrcSpan ModuleName -> ModNodeKey)
-> GenLocated SrcSpan ModuleName
-> NodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> IsBootInterface -> ModNodeKey)
-> IsBootInterface -> ModuleName -> ModNodeKey
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleName -> IsBootInterface -> ModNodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB IsBootInterface
hs_boot_key (ModuleName -> ModNodeKey)
-> (GenLocated SrcSpan ModuleName -> ModuleName)
-> GenLocated SrcSpan ModuleName
-> ModNodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan ModuleName -> NodeKey)
-> [GenLocated SrcSpan ModuleName] -> [NodeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
ms) [NodeKey] -> [NodeKey] -> [NodeKey]
forall a. [a] -> [a] -> [a]
++
      (ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey)
-> (GenLocated SrcSpan ModuleName -> ModNodeKey)
-> GenLocated SrcSpan ModuleName
-> NodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> IsBootInterface -> ModNodeKey)
-> IsBootInterface -> ModuleName -> ModNodeKey
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleName -> IsBootInterface -> ModNodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB IsBootInterface
NotBoot     (ModuleName -> ModNodeKey)
-> (GenLocated SrcSpan ModuleName -> ModuleName)
-> GenLocated SrcSpan ModuleName
-> ModNodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan ModuleName -> NodeKey)
-> [GenLocated SrcSpan ModuleName] -> [NodeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
ms) [NodeKey] -> [NodeKey] -> [NodeKey]
forall a. [a] -> [a] -> [a]
++
      [ ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey) -> ModNodeKey -> NodeKey
forall a b. (a -> b) -> a -> b
$ ModuleName -> IsBootInterface -> ModNodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
IsBoot
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
drop_hs_boot_nodes Bool -> Bool -> Bool
|| ModSummary -> HscSource
ms_hsc_src ModSummary
ms HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsBootFile
      ] [NodeKey] -> [NodeKey] -> [NodeKey]
forall a. [a] -> [a] -> [a]
++
      [ InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
inst_unit
      | InstantiatedUnit
inst_unit <- [InstantiatedUnit]
bds
      ]
  where
    -- Drop hs-boot nodes by using HsSrcFile as the key
    hs_boot_key :: IsBootInterface
hs_boot_key | Bool
drop_hs_boot_nodes = IsBootInterface
NotBoot -- is regular mod or signature
                | Bool
otherwise          = IsBootInterface
IsBoot

moduleGraphNodes :: Bool -> [ModuleGraphNode]
  -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes :: Bool
-> [ModuleGraphNode]
-> (Graph (Node Int ModuleGraphNode),
    NodeKey -> Maybe (Node Int ModuleGraphNode))
moduleGraphNodes Bool
drop_hs_boot_nodes [ModuleGraphNode]
summaries =
  ([Node Int ModuleGraphNode] -> Graph (Node Int ModuleGraphNode)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [Node Int ModuleGraphNode]
nodes, NodeKey -> Maybe (Node Int ModuleGraphNode)
lookup_node)
  where
    numbered_summaries :: [(ModuleGraphNode, Int)]
numbered_summaries = [ModuleGraphNode] -> [Int] -> [(ModuleGraphNode, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleGraphNode]
summaries [Int
1..]

    lookup_node :: NodeKey -> Maybe SummaryNode
    lookup_node :: NodeKey -> Maybe (Node Int ModuleGraphNode)
lookup_node NodeKey
key = NodeKey
-> Map NodeKey (Node Int ModuleGraphNode)
-> Maybe (Node Int ModuleGraphNode)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeKey
key (NodeMap (Node Int ModuleGraphNode)
-> Map NodeKey (Node Int ModuleGraphNode)
forall a. NodeMap a -> Map NodeKey a
unNodeMap NodeMap (Node Int ModuleGraphNode)
node_map)

    lookup_key :: NodeKey -> Maybe Int
    lookup_key :: NodeKey -> Maybe Int
lookup_key = (Node Int ModuleGraphNode -> Int)
-> Maybe (Node Int ModuleGraphNode) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node Int ModuleGraphNode -> Int
summaryNodeKey (Maybe (Node Int ModuleGraphNode) -> Maybe Int)
-> (NodeKey -> Maybe (Node Int ModuleGraphNode))
-> NodeKey
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> Maybe (Node Int ModuleGraphNode)
lookup_node

    node_map :: NodeMap SummaryNode
    node_map :: NodeMap (Node Int ModuleGraphNode)
node_map = Map NodeKey (Node Int ModuleGraphNode)
-> NodeMap (Node Int ModuleGraphNode)
forall a. Map NodeKey a -> NodeMap a
NodeMap (Map NodeKey (Node Int ModuleGraphNode)
 -> NodeMap (Node Int ModuleGraphNode))
-> Map NodeKey (Node Int ModuleGraphNode)
-> NodeMap (Node Int ModuleGraphNode)
forall a b. (a -> b) -> a -> b
$
      [(NodeKey, Node Int ModuleGraphNode)]
-> Map NodeKey (Node Int ModuleGraphNode)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ModuleGraphNode -> NodeKey
mkHomeBuildModule ModuleGraphNode
s, Node Int ModuleGraphNode
node)
                   | Node Int ModuleGraphNode
node <- [Node Int ModuleGraphNode]
nodes
                   , let s :: ModuleGraphNode
s = Node Int ModuleGraphNode -> ModuleGraphNode
summaryNodeSummary Node Int ModuleGraphNode
node
                   ]

    -- We use integers as the keys for the SCC algorithm
    nodes :: [SummaryNode]
    nodes :: [Node Int ModuleGraphNode]
nodes = [ ModuleGraphNode -> Int -> [Int] -> Node Int ModuleGraphNode
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode ModuleGraphNode
s Int
key ([Int] -> Node Int ModuleGraphNode)
-> [Int] -> Node Int ModuleGraphNode
forall a b. (a -> b) -> a -> b
$ [NodeKey] -> [Int]
out_edge_keys ([NodeKey] -> [Int]) -> [NodeKey] -> [Int]
forall a b. (a -> b) -> a -> b
$ Bool -> ModuleGraphNode -> [NodeKey]
unfilteredEdges Bool
drop_hs_boot_nodes ModuleGraphNode
s
            | (ModuleGraphNode
s, Int
key) <- [(ModuleGraphNode, Int)]
numbered_summaries
             -- Drop the hi-boot ones if told to do so
            , case ModuleGraphNode
s of
                InstantiationNode InstantiatedUnit
_ -> Bool
True
                ModuleNode ExtendedModSummary
ems -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ModSummary -> IsBootInterface
isBootSummary (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems) IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot Bool -> Bool -> Bool
&& Bool
drop_hs_boot_nodes
            ]

    out_edge_keys :: [NodeKey] -> [Int]
    out_edge_keys :: [NodeKey] -> [Int]
out_edge_keys = (NodeKey -> Maybe Int) -> [NodeKey] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe Int
lookup_key
        -- If we want keep_hi_boot_nodes, then we do lookup_key with
        -- IsBoot; else False

-- The nodes of the graph are keyed by (mod, is boot?) pairs for the current
-- modules, and indefinite unit IDs for dependencies which are instantiated with
-- our holes.
--
-- NB: hsig files show up as *normal* nodes (not boot!), since they don't
-- participate in cycles (for now)
type ModNodeKey = ModuleNameWithIsBoot
newtype ModNodeMap a = ModNodeMap { forall a. ModNodeMap a -> Map ModNodeKey a
unModNodeMap :: Map.Map ModNodeKey a }
  deriving ((forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b)
-> (forall a b. a -> ModNodeMap b -> ModNodeMap a)
-> Functor ModNodeMap
forall a b. a -> ModNodeMap b -> ModNodeMap a
forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
$c<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
fmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
$cfmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
Functor, Functor ModNodeMap
Foldable ModNodeMap
Functor ModNodeMap
-> Foldable ModNodeMap
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> ModNodeMap a -> f (ModNodeMap b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    ModNodeMap (f a) -> f (ModNodeMap a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> ModNodeMap a -> m (ModNodeMap b))
-> (forall (m :: * -> *) a.
    Monad m =>
    ModNodeMap (m a) -> m (ModNodeMap a))
-> Traversable ModNodeMap
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
sequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
Traversable, (forall m. Monoid m => ModNodeMap m -> m)
-> (forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m)
-> (forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m)
-> (forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b)
-> (forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b)
-> (forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b)
-> (forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b)
-> (forall a. (a -> a -> a) -> ModNodeMap a -> a)
-> (forall a. (a -> a -> a) -> ModNodeMap a -> a)
-> (forall a. ModNodeMap a -> [a])
-> (forall a. ModNodeMap a -> Bool)
-> (forall a. ModNodeMap a -> Int)
-> (forall a. Eq a => a -> ModNodeMap a -> Bool)
-> (forall a. Ord a => ModNodeMap a -> a)
-> (forall a. Ord a => ModNodeMap a -> a)
-> (forall a. Num a => ModNodeMap a -> a)
-> (forall a. Num a => ModNodeMap a -> a)
-> Foldable ModNodeMap
forall a. Eq a => a -> ModNodeMap a -> Bool
forall a. Num a => ModNodeMap a -> a
forall a. Ord a => ModNodeMap a -> a
forall m. Monoid m => ModNodeMap m -> m
forall a. ModNodeMap a -> Bool
forall a. ModNodeMap a -> Int
forall a. ModNodeMap a -> [a]
forall a. (a -> a -> a) -> ModNodeMap a -> a
forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => ModNodeMap a -> a
$cproduct :: forall a. Num a => ModNodeMap a -> a
sum :: forall a. Num a => ModNodeMap a -> a
$csum :: forall a. Num a => ModNodeMap a -> a
minimum :: forall a. Ord a => ModNodeMap a -> a
$cminimum :: forall a. Ord a => ModNodeMap a -> a
maximum :: forall a. Ord a => ModNodeMap a -> a
$cmaximum :: forall a. Ord a => ModNodeMap a -> a
elem :: forall a. Eq a => a -> ModNodeMap a -> Bool
$celem :: forall a. Eq a => a -> ModNodeMap a -> Bool
length :: forall a. ModNodeMap a -> Int
$clength :: forall a. ModNodeMap a -> Int
null :: forall a. ModNodeMap a -> Bool
$cnull :: forall a. ModNodeMap a -> Bool
toList :: forall a. ModNodeMap a -> [a]
$ctoList :: forall a. ModNodeMap a -> [a]
foldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
fold :: forall m. Monoid m => ModNodeMap m -> m
$cfold :: forall m. Monoid m => ModNodeMap m -> m
Foldable)

emptyModNodeMap :: ModNodeMap a
emptyModNodeMap :: forall a. ModNodeMap a
emptyModNodeMap = Map ModNodeKey a -> ModNodeMap a
forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap Map ModNodeKey a
forall k a. Map k a
Map.empty

modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert :: forall a. ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert ModNodeKey
k a
v (ModNodeMap Map ModNodeKey a
m) = Map ModNodeKey a -> ModNodeMap a
forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap (ModNodeKey -> a -> Map ModNodeKey a -> Map ModNodeKey a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ModNodeKey
k a
v Map ModNodeKey a
m)

modNodeMapElems :: ModNodeMap a -> [a]
modNodeMapElems :: forall a. ModNodeMap a -> [a]
modNodeMapElems (ModNodeMap Map ModNodeKey a
m) = Map ModNodeKey a -> [a]
forall k a. Map k a -> [a]
Map.elems Map ModNodeKey a
m

modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup :: forall a. ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup ModNodeKey
k (ModNodeMap Map ModNodeKey a
m) = ModNodeKey -> Map ModNodeKey a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModNodeKey
k Map ModNodeKey a
m

data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey
  deriving (NodeKey -> NodeKey -> Bool
(NodeKey -> NodeKey -> Bool)
-> (NodeKey -> NodeKey -> Bool) -> Eq NodeKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeKey -> NodeKey -> Bool
$c/= :: NodeKey -> NodeKey -> Bool
== :: NodeKey -> NodeKey -> Bool
$c== :: NodeKey -> NodeKey -> Bool
Eq, Eq NodeKey
Eq NodeKey
-> (NodeKey -> NodeKey -> Ordering)
-> (NodeKey -> NodeKey -> Bool)
-> (NodeKey -> NodeKey -> Bool)
-> (NodeKey -> NodeKey -> Bool)
-> (NodeKey -> NodeKey -> Bool)
-> (NodeKey -> NodeKey -> NodeKey)
-> (NodeKey -> NodeKey -> NodeKey)
-> Ord NodeKey
NodeKey -> NodeKey -> Bool
NodeKey -> NodeKey -> Ordering
NodeKey -> NodeKey -> NodeKey
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
min :: NodeKey -> NodeKey -> NodeKey
$cmin :: NodeKey -> NodeKey -> NodeKey
max :: NodeKey -> NodeKey -> NodeKey
$cmax :: NodeKey -> NodeKey -> NodeKey
>= :: NodeKey -> NodeKey -> Bool
$c>= :: NodeKey -> NodeKey -> Bool
> :: NodeKey -> NodeKey -> Bool
$c> :: NodeKey -> NodeKey -> Bool
<= :: NodeKey -> NodeKey -> Bool
$c<= :: NodeKey -> NodeKey -> Bool
< :: NodeKey -> NodeKey -> Bool
$c< :: NodeKey -> NodeKey -> Bool
compare :: NodeKey -> NodeKey -> Ordering
$ccompare :: NodeKey -> NodeKey -> Ordering
Ord)

newtype NodeMap a = NodeMap { forall a. NodeMap a -> Map NodeKey a
unNodeMap :: Map.Map NodeKey a }
  deriving ((forall a b. (a -> b) -> NodeMap a -> NodeMap b)
-> (forall a b. a -> NodeMap b -> NodeMap a) -> Functor NodeMap
forall a b. a -> NodeMap b -> NodeMap a
forall a b. (a -> b) -> NodeMap a -> NodeMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> NodeMap b -> NodeMap a
$c<$ :: forall a b. a -> NodeMap b -> NodeMap a
fmap :: forall a b. (a -> b) -> NodeMap a -> NodeMap b
$cfmap :: forall a b. (a -> b) -> NodeMap a -> NodeMap b
Functor, Functor NodeMap
Foldable NodeMap
Functor NodeMap
-> Foldable NodeMap
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> NodeMap a -> f (NodeMap b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    NodeMap (f a) -> f (NodeMap a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> NodeMap a -> m (NodeMap b))
-> (forall (m :: * -> *) a.
    Monad m =>
    NodeMap (m a) -> m (NodeMap a))
-> Traversable NodeMap
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => NodeMap (m a) -> m (NodeMap a)
forall (f :: * -> *) a.
Applicative f =>
NodeMap (f a) -> f (NodeMap a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NodeMap a -> m (NodeMap b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NodeMap a -> f (NodeMap b)
sequence :: forall (m :: * -> *) a. Monad m => NodeMap (m a) -> m (NodeMap a)
$csequence :: forall (m :: * -> *) a. Monad m => NodeMap (m a) -> m (NodeMap a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NodeMap a -> m (NodeMap b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NodeMap a -> m (NodeMap b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
NodeMap (f a) -> f (NodeMap a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
NodeMap (f a) -> f (NodeMap a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NodeMap a -> f (NodeMap b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NodeMap a -> f (NodeMap b)
Traversable, (forall m. Monoid m => NodeMap m -> m)
-> (forall m a. Monoid m => (a -> m) -> NodeMap a -> m)
-> (forall m a. Monoid m => (a -> m) -> NodeMap a -> m)
-> (forall a b. (a -> b -> b) -> b -> NodeMap a -> b)
-> (forall a b. (a -> b -> b) -> b -> NodeMap a -> b)
-> (forall b a. (b -> a -> b) -> b -> NodeMap a -> b)
-> (forall b a. (b -> a -> b) -> b -> NodeMap a -> b)
-> (forall a. (a -> a -> a) -> NodeMap a -> a)
-> (forall a. (a -> a -> a) -> NodeMap a -> a)
-> (forall a. NodeMap a -> [a])
-> (forall a. NodeMap a -> Bool)
-> (forall a. NodeMap a -> Int)
-> (forall a. Eq a => a -> NodeMap a -> Bool)
-> (forall a. Ord a => NodeMap a -> a)
-> (forall a. Ord a => NodeMap a -> a)
-> (forall a. Num a => NodeMap a -> a)
-> (forall a. Num a => NodeMap a -> a)
-> Foldable NodeMap
forall a. Eq a => a -> NodeMap a -> Bool
forall a. Num a => NodeMap a -> a
forall a. Ord a => NodeMap a -> a
forall m. Monoid m => NodeMap m -> m
forall a. NodeMap a -> Bool
forall a. NodeMap a -> Int
forall a. NodeMap a -> [a]
forall a. (a -> a -> a) -> NodeMap a -> a
forall m a. Monoid m => (a -> m) -> NodeMap a -> m
forall b a. (b -> a -> b) -> b -> NodeMap a -> b
forall a b. (a -> b -> b) -> b -> NodeMap a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => NodeMap a -> a
$cproduct :: forall a. Num a => NodeMap a -> a
sum :: forall a. Num a => NodeMap a -> a
$csum :: forall a. Num a => NodeMap a -> a
minimum :: forall a. Ord a => NodeMap a -> a
$cminimum :: forall a. Ord a => NodeMap a -> a
maximum :: forall a. Ord a => NodeMap a -> a
$cmaximum :: forall a. Ord a => NodeMap a -> a
elem :: forall a. Eq a => a -> NodeMap a -> Bool
$celem :: forall a. Eq a => a -> NodeMap a -> Bool
length :: forall a. NodeMap a -> Int
$clength :: forall a. NodeMap a -> Int
null :: forall a. NodeMap a -> Bool
$cnull :: forall a. NodeMap a -> Bool
toList :: forall a. NodeMap a -> [a]
$ctoList :: forall a. NodeMap a -> [a]
foldl1 :: forall a. (a -> a -> a) -> NodeMap a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> NodeMap a -> a
foldr1 :: forall a. (a -> a -> a) -> NodeMap a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> NodeMap a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
foldl :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
foldr :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
fold :: forall m. Monoid m => NodeMap m -> m
$cfold :: forall m. Monoid m => NodeMap m -> m
Foldable)

msKey :: ModSummary -> ModNodeKey
msKey :: ModSummary -> ModNodeKey
msKey = ModSummary -> ModNodeKey
mkHomeBuildModule0

mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey = \case
  InstantiationNode InstantiatedUnit
x -> InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
x
  ModuleNode ExtendedModSummary
x -> ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey) -> ModNodeKey -> NodeKey
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModNodeKey
mkHomeBuildModule0 (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
x)

pprNodeKey :: NodeKey -> SDoc
pprNodeKey :: NodeKey -> SDoc
pprNodeKey (NodeKey_Unit InstantiatedUnit
iu) = InstantiatedUnit -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
iu
pprNodeKey (NodeKey_Module ModNodeKey
mk) = ModNodeKey -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModNodeKey
mk

mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
mkNodeMap [ExtendedModSummary]
summaries = Map ModNodeKey ExtendedModSummary -> ModNodeMap ExtendedModSummary
forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap (Map ModNodeKey ExtendedModSummary
 -> ModNodeMap ExtendedModSummary)
-> Map ModNodeKey ExtendedModSummary
-> ModNodeMap ExtendedModSummary
forall a b. (a -> b) -> a -> b
$ [(ModNodeKey, ExtendedModSummary)]
-> Map ModNodeKey ExtendedModSummary
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (ModSummary -> ModNodeKey
msKey (ModSummary -> ModNodeKey) -> ModSummary -> ModNodeKey
forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
s, ExtendedModSummary
s) | ExtendedModSummary
s <- [ExtendedModSummary]
summaries]

-- | If there are {-# SOURCE #-} imports between strongly connected
-- components in the topological sort, then those imports can
-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
-- were necessary, then the edge would be part of a cycle.
warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports :: forall (m :: * -> *). GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports [SCC ModSummary]
sccs = do
  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnusedImports DynFlags
dflags)
    (ErrorMessages -> m ()
forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings ([MsgEnvelope DecoratedSDoc] -> ErrorMessages
forall a. [a] -> Bag a
listToBag ((SCC ModSummary -> [MsgEnvelope DecoratedSDoc])
-> [SCC ModSummary] -> [MsgEnvelope DecoratedSDoc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([ModSummary] -> [MsgEnvelope DecoratedSDoc]
check ([ModSummary] -> [MsgEnvelope DecoratedSDoc])
-> (SCC ModSummary -> [ModSummary])
-> SCC ModSummary
-> [MsgEnvelope DecoratedSDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC ModSummary -> [ModSummary]
forall vertex. SCC vertex -> [vertex]
flattenSCC) [SCC ModSummary]
sccs)))
  where check :: [ModSummary] -> [MsgEnvelope DecoratedSDoc]
check [ModSummary]
ms =
           let mods_in_this_cycle :: [ModuleName]
mods_in_this_cycle = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
ms in
           [ GenLocated SrcSpan ModuleName -> MsgEnvelope DecoratedSDoc
warn GenLocated SrcSpan ModuleName
i | ModSummary
m <- [ModSummary]
ms, GenLocated SrcSpan ModuleName
i <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
m,
                      GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
i ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`  [ModuleName]
mods_in_this_cycle ]

        warn :: Located ModuleName -> WarnMsg
        warn :: GenLocated SrcSpan ModuleName -> MsgEnvelope DecoratedSDoc
warn (L SrcSpan
loc ModuleName
mod) =
           SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc
                (FilePath -> SDoc
text FilePath
"Warning: {-# SOURCE #-} unnecessary in import of "
                 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod))


-----------------------------------------------------------------------------
--
-- | Downsweep (dependency analysis)
--
-- 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 list of [ModSummary] nodes 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.
downsweep :: HscEnv
          -> [ExtendedModSummary]
          -- ^ 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 [Either ErrorMessages ExtendedModSummary]
                -- 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
-> [ExtendedModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ExtendedModSummary]
downsweep HscEnv
hsc_env [ExtendedModSummary]
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots
   = do
       [Either ErrorMessages ExtendedModSummary]
rootSummaries <- (Target -> IO (Either ErrorMessages ExtendedModSummary))
-> [Target] -> IO [Either ErrorMessages ExtendedModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Target -> IO (Either ErrorMessages ExtendedModSummary)
getRootSummary [Target]
roots
       let ([ErrorMessages]
errs, [ExtendedModSummary]
rootSummariesOk) = [Either ErrorMessages ExtendedModSummary]
-> ([ErrorMessages], [ExtendedModSummary])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ErrorMessages ExtendedModSummary]
rootSummaries -- #17549
           root_map :: ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map = [ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
mkRootMap [ExtendedModSummary]
rootSummariesOk
       ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO ()
checkDuplicates ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map
       ModNodeMap [Either ErrorMessages ExtendedModSummary]
map0 <- [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop ((ExtendedModSummary
 -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)])
-> [ExtendedModSummary]
-> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ExtendedModSummary
-> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
calcDeps [ExtendedModSummary]
rootSummariesOk) ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map
       -- 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
       let default_backend :: Backend
default_backend = Platform -> Backend
platformDefaultBackend (DynFlags -> Platform
targetPlatform DynFlags
dflags)
       let home_unit :: HomeUnit
home_unit       = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
       let tmpfs :: TmpFs
tmpfs           = HscEnv -> TmpFs
hsc_tmpfs     HscEnv
hsc_env
       ModNodeMap [Either ErrorMessages ExtendedModSummary]
map1 <- case DynFlags -> Backend
backend DynFlags
dflags of
         Backend
NoBackend   -> Logger
-> TmpFs
-> HomeUnit
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenForTH Logger
logger TmpFs
tmpfs HomeUnit
home_unit Backend
default_backend ModNodeMap [Either ErrorMessages ExtendedModSummary]
map0
         Backend
_           -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return ModNodeMap [Either ErrorMessages ExtendedModSummary]
map0
       if [ErrorMessages] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorMessages]
errs
         then [Either ErrorMessages ExtendedModSummary]
-> IO [Either ErrorMessages ExtendedModSummary]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either ErrorMessages ExtendedModSummary]
 -> IO [Either ErrorMessages ExtendedModSummary])
-> [Either ErrorMessages ExtendedModSummary]
-> IO [Either ErrorMessages ExtendedModSummary]
forall a b. (a -> b) -> a -> b
$ [[Either ErrorMessages ExtendedModSummary]]
-> [Either ErrorMessages ExtendedModSummary]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either ErrorMessages ExtendedModSummary]]
 -> [Either ErrorMessages ExtendedModSummary])
-> [[Either ErrorMessages ExtendedModSummary]]
-> [Either ErrorMessages ExtendedModSummary]
forall a b. (a -> b) -> a -> b
$ ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> [[Either ErrorMessages ExtendedModSummary]]
forall a. ModNodeMap a -> [a]
modNodeMapElems ModNodeMap [Either ErrorMessages ExtendedModSummary]
map1
         else [Either ErrorMessages ExtendedModSummary]
-> IO [Either ErrorMessages ExtendedModSummary]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either ErrorMessages ExtendedModSummary]
 -> IO [Either ErrorMessages ExtendedModSummary])
-> [Either ErrorMessages ExtendedModSummary]
-> IO [Either ErrorMessages ExtendedModSummary]
forall a b. (a -> b) -> a -> b
$ (ErrorMessages -> Either ErrorMessages ExtendedModSummary)
-> [ErrorMessages] -> [Either ErrorMessages ExtendedModSummary]
forall a b. (a -> b) -> [a] -> [b]
map ErrorMessages -> Either ErrorMessages ExtendedModSummary
forall a b. a -> Either a b
Left [ErrorMessages]
errs
     where
        -- TODO(@Ericson2314): Probably want to include backpack instantiations
        -- in the map eventually for uniformity
        calcDeps :: ExtendedModSummary
-> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
calcDeps (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_bkp_deps) = ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
msDeps ModSummary
ms

        dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
        roots :: [Target]
roots = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env

        old_summary_map :: ModNodeMap ExtendedModSummary
        old_summary_map :: ModNodeMap ExtendedModSummary
old_summary_map = [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
mkNodeMap [ExtendedModSummary]
old_summaries

        getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)
        getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)
getRootSummary (Target (TargetFile FilePath
file Maybe Phase
mb_phase) Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf)
           = do Bool
exists <- IO Bool -> IO Bool
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
file
                if Bool
exists Bool -> Bool -> Bool
|| Maybe (InputFileBuffer, UTCTime) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (InputFileBuffer, UTCTime)
maybe_buf
                    then HscEnv
-> [ExtendedModSummary]
-> FilePath
-> Maybe Phase
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either ErrorMessages ExtendedModSummary)
summariseFile HscEnv
hsc_env [ExtendedModSummary]
old_summaries FilePath
file Maybe Phase
mb_phase
                                       Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf
                    else Either ErrorMessages ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMessages ExtendedModSummary
 -> IO (Either ErrorMessages ExtendedModSummary))
-> Either ErrorMessages ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> Either ErrorMessages ExtendedModSummary
forall a b. a -> Either a b
Left (ErrorMessages -> Either ErrorMessages ExtendedModSummary)
-> ErrorMessages -> Either ErrorMessages ExtendedModSummary
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a. a -> Bag a
unitBag (MsgEnvelope DecoratedSDoc -> ErrorMessages)
-> MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan (SDoc -> MsgEnvelope DecoratedSDoc)
-> SDoc -> MsgEnvelope DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
                           FilePath -> SDoc
text FilePath
"can't find file:" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
file
        getRootSummary (Target (TargetModule ModuleName
modl) Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf)
           = do Maybe (Either ErrorMessages ExtendedModSummary)
maybe_summary <- HscEnv
-> ModNodeMap ExtendedModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
summariseModule HscEnv
hsc_env ModNodeMap ExtendedModSummary
old_summary_map IsBootInterface
NotBoot
                                           (SrcSpan -> ModuleName -> GenLocated SrcSpan ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
rootLoc ModuleName
modl) Bool
obj_allowed
                                           Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
                case Maybe (Either ErrorMessages ExtendedModSummary)
maybe_summary of
                   Maybe (Either ErrorMessages ExtendedModSummary)
Nothing -> Either ErrorMessages ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMessages ExtendedModSummary
 -> IO (Either ErrorMessages ExtendedModSummary))
-> Either ErrorMessages ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> Either ErrorMessages ExtendedModSummary
forall a b. a -> Either a b
Left (ErrorMessages -> Either ErrorMessages ExtendedModSummary)
-> ErrorMessages -> Either ErrorMessages ExtendedModSummary
forall a b. (a -> b) -> a -> b
$ ModuleName -> ErrorMessages
moduleNotFoundErr ModuleName
modl
                   Just Either ErrorMessages ExtendedModSummary
s  -> Either ErrorMessages ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return Either ErrorMessages ExtendedModSummary
s

        rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"<command line>")

        -- 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
          :: ModNodeMap
               [Either ErrorMessages
                       ExtendedModSummary]
          -> IO ()
        checkDuplicates :: ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO ()
checkDuplicates ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map
           | Bool
allow_dup_roots = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           | [[ExtendedModSummary]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ExtendedModSummary]]
dup_roots  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           | Bool
otherwise       = IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [ModSummary] -> IO ()
multiRootsErr (ExtendedModSummary -> ModSummary
emsModSummary (ExtendedModSummary -> ModSummary)
-> [ExtendedModSummary] -> [ModSummary]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[ExtendedModSummary]] -> [ExtendedModSummary]
forall a. [a] -> a
head [[ExtendedModSummary]]
dup_roots)
           where
             dup_roots :: [[ExtendedModSummary]]        -- Each at least of length 2
             dup_roots :: [[ExtendedModSummary]]
dup_roots = ([ExtendedModSummary] -> Bool)
-> [[ExtendedModSummary]] -> [[ExtendedModSummary]]
forall a. (a -> Bool) -> [a] -> [a]
filterOut [ExtendedModSummary] -> Bool
forall a. [a] -> Bool
isSingleton ([[ExtendedModSummary]] -> [[ExtendedModSummary]])
-> [[ExtendedModSummary]] -> [[ExtendedModSummary]]
forall a b. (a -> b) -> a -> b
$ ([Either ErrorMessages ExtendedModSummary] -> [ExtendedModSummary])
-> [[Either ErrorMessages ExtendedModSummary]]
-> [[ExtendedModSummary]]
forall a b. (a -> b) -> [a] -> [b]
map [Either ErrorMessages ExtendedModSummary] -> [ExtendedModSummary]
forall a b. [Either a b] -> [b]
rights ([[Either ErrorMessages ExtendedModSummary]]
 -> [[ExtendedModSummary]])
-> [[Either ErrorMessages ExtendedModSummary]]
-> [[ExtendedModSummary]]
forall a b. (a -> b) -> a -> b
$ ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> [[Either ErrorMessages ExtendedModSummary]]
forall a. ModNodeMap a -> [a]
modNodeMapElems ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map

        loop :: [GenWithIsBoot (Located ModuleName)]
                        -- Work list: process these modules
             -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
                        -- Visited set; the range is a list because
                        -- the roots can have the same module names
                        -- if allow_dup_roots is True
             -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
                        -- The result is the completed NodeMap
        loop :: [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop [] ModNodeMap [Either ErrorMessages ExtendedModSummary]
done = ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return ModNodeMap [Either ErrorMessages ExtendedModSummary]
done
        loop (GenWithIsBoot (GenLocated SrcSpan ModuleName)
s : [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss) ModNodeMap [Either ErrorMessages ExtendedModSummary]
done
          | Just [Either ErrorMessages ExtendedModSummary]
summs <- ModNodeKey
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> Maybe [Either ErrorMessages ExtendedModSummary]
forall a. ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup ModNodeKey
key ModNodeMap [Either ErrorMessages ExtendedModSummary]
done
          = if [Either ErrorMessages ExtendedModSummary] -> Bool
forall a. [a] -> Bool
isSingleton [Either ErrorMessages ExtendedModSummary]
summs then
                [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss ModNodeMap [Either ErrorMessages ExtendedModSummary]
done
            else
                do { [ModSummary] -> IO ()
multiRootsErr (ExtendedModSummary -> ModSummary
emsModSummary (ExtendedModSummary -> ModSummary)
-> [ExtendedModSummary] -> [ModSummary]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either ErrorMessages ExtendedModSummary] -> [ExtendedModSummary]
forall a b. [Either a b] -> [b]
rights [Either ErrorMessages ExtendedModSummary]
summs)
                   ; ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ModNodeKey [Either ErrorMessages ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap Map ModNodeKey [Either ErrorMessages ExtendedModSummary]
forall k a. Map k a
Map.empty)
                   }
          | Bool
otherwise
          = do Maybe (Either ErrorMessages ExtendedModSummary)
mb_s <- HscEnv
-> ModNodeMap ExtendedModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
summariseModule HscEnv
hsc_env ModNodeMap ExtendedModSummary
old_summary_map
                                       IsBootInterface
is_boot GenLocated SrcSpan ModuleName
wanted_mod Bool
True
                                       Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing [ModuleName]
excl_mods
               case Maybe (Either ErrorMessages ExtendedModSummary)
mb_s of
                   Maybe (Either ErrorMessages ExtendedModSummary)
Nothing -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss ModNodeMap [Either ErrorMessages ExtendedModSummary]
done
                   Just (Left ErrorMessages
e) -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss (ModNodeKey
-> [Either ErrorMessages ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
forall a. ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert ModNodeKey
key [ErrorMessages -> Either ErrorMessages ExtendedModSummary
forall a b. a -> Either a b
Left ErrorMessages
e] ModNodeMap [Either ErrorMessages ExtendedModSummary]
done)
                   Just (Right ExtendedModSummary
s)-> do
                     ModNodeMap [Either ErrorMessages ExtendedModSummary]
new_map <-
                       [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop (ExtendedModSummary
-> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
calcDeps ExtendedModSummary
s) (ModNodeKey
-> [Either ErrorMessages ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
forall a. ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert ModNodeKey
key [ExtendedModSummary -> Either ErrorMessages ExtendedModSummary
forall a b. b -> Either a b
Right ExtendedModSummary
s] ModNodeMap [Either ErrorMessages ExtendedModSummary]
done)
                     [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss ModNodeMap [Either ErrorMessages ExtendedModSummary]
new_map
          where
            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 (GenLocated SrcSpan ModuleName)
s
            wanted_mod :: GenLocated SrcSpan ModuleName
wanted_mod = SrcSpan -> ModuleName -> GenLocated SrcSpan ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc ModuleName
mod
            key :: ModNodeKey
key = GWIB
                    { gwib_mod :: ModuleName
gwib_mod = GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
wanted_mod
                    , gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
is_boot
                    }

-- | 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
  -> HomeUnit
  -> Backend
  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenForTH :: Logger
-> TmpFs
-> HomeUnit
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenForTH Logger
logger TmpFs
tmpfs HomeUnit
home_unit =
  Logger
-> TmpFs
-> (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenWhen Logger
logger TmpFs
tmpfs ModSummary -> Bool
condition ModSummary -> Bool
should_modify TempFileLifetime
TFL_CurrentModule TempFileLifetime
TFL_GhcSession
  where
    condition :: ModSummary -> Bool
condition = ModSummary -> Bool
isTemplateHaskellOrQQNonBoot
    should_modify :: ModSummary -> Bool
should_modify (ModSummary { ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags }) =
      DynFlags -> Backend
backend DynFlags
dflags Backend -> Backend -> Bool
forall a. Eq a => a -> a -> Bool
== Backend
NoBackend 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 HomeUnit
home_unit

-- | 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
  -> (ModSummary -> Bool)
  -> (ModSummary -> Bool)
  -> TempFileLifetime
  -> TempFileLifetime
  -> Backend
  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenWhen :: Logger
-> TmpFs
-> (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenWhen Logger
logger TmpFs
tmpfs ModSummary -> Bool
condition ModSummary -> Bool
should_modify TempFileLifetime
staticLife TempFileLifetime
dynLife Backend
bcknd ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap =
  ([Either ErrorMessages ExtendedModSummary]
 -> IO [Either ErrorMessages ExtendedModSummary])
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either ErrorMessages ExtendedModSummary
 -> IO (Either ErrorMessages ExtendedModSummary))
-> [Either ErrorMessages ExtendedModSummary]
-> IO [Either ErrorMessages ExtendedModSummary]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ExtendedModSummary -> IO ExtendedModSummary)
-> Either ErrorMessages ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ExtendedModSummary -> IO ExtendedModSummary
enable_code_gen)) ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap
  where
    enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary
    enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary
enable_code_gen (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bkp_deps)
      | ModSummary
        { ms_mod :: ModSummary -> Module
ms_mod = Module
ms_mod
        , 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
      , ModSummary -> Bool
should_modify ModSummary
ms
      , Module
ms_mod Module -> Set Module -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
needs_codegen_set
      = do
        let new_temp_file :: FilePath -> FilePath -> IO FilePath
new_temp_file FilePath
suf FilePath
dynsuf = do
              FilePath
tn <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs 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]
              FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
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.
          --
        (FilePath
hi_file, FilePath
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 (FilePath, FilePath) -> IO (FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModLocation -> FilePath
ml_hi_file ModLocation
ms_location, ModLocation -> FilePath
ml_obj_file ModLocation
ms_location)
            else (,) (FilePath -> FilePath -> (FilePath, FilePath))
-> IO FilePath -> IO (FilePath -> (FilePath, FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> IO FilePath
new_temp_file (DynFlags -> FilePath
hiSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynHiSuf_ DynFlags
dflags))
                     IO (FilePath -> (FilePath, FilePath))
-> IO FilePath -> IO (FilePath, FilePath)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> FilePath -> IO FilePath
new_temp_file (DynFlags -> FilePath
objectSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynObjectSuf_ DynFlags
dflags))
        let ms' :: ModSummary
ms' = ModSummary
ms
              { ms_location :: ModLocation
ms_location =
                  ModLocation
ms_location {ml_hi_file :: FilePath
ml_hi_file = FilePath
hi_file, ml_obj_file :: FilePath
ml_obj_file = FilePath
o_file}
              , ms_hspp_opts :: DynFlags
ms_hspp_opts = Int -> DynFlags -> DynFlags
updOptLevel Int
0 (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
dflags {backend :: Backend
backend = Backend
bcknd}
              }
        ExtendedModSummary -> IO ExtendedModSummary
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModSummary -> [InstantiatedUnit] -> ExtendedModSummary
ExtendedModSummary ModSummary
ms' [InstantiatedUnit]
bkp_deps)
      | Bool
otherwise = ExtendedModSummary -> IO ExtendedModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> [InstantiatedUnit] -> ExtendedModSummary
ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bkp_deps)

    needs_codegen_set :: Set Module
needs_codegen_set = [ModSummary] -> Set Module
transitive_deps_set
      [ ModSummary
ms
      | [Either ErrorMessages ExtendedModSummary]
mss <- ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> [[Either ErrorMessages ExtendedModSummary]]
forall a. ModNodeMap a -> [a]
modNodeMapElems ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap
      , Right (ExtendedModSummary { emsModSummary :: ExtendedModSummary -> ModSummary
emsModSummary = ModSummary
ms }) <- [Either ErrorMessages ExtendedModSummary]
mss
      , ModSummary -> Bool
condition ModSummary
ms
      ]

    -- find the set of all transitive dependencies of a list of modules.
    transitive_deps_set :: [ModSummary] -> Set.Set Module
    transitive_deps_set :: [ModSummary] -> Set Module
transitive_deps_set [ModSummary]
modSums = (Set Module -> ModSummary -> Set Module)
-> Set Module -> [ModSummary] -> Set Module
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Module -> ModSummary -> Set Module
go Set Module
forall a. Set a
Set.empty [ModSummary]
modSums
      where
        go :: Set Module -> ModSummary -> Set Module
go Set Module
marked_mods ms :: ModSummary
ms@ModSummary{Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod}
          | Module
ms_mod Module -> Set Module -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
marked_mods = Set Module
marked_mods
          | Bool
otherwise =
            let deps :: [ModSummary]
deps =
                  [ ModSummary
dep_ms
                  -- If a module imports a boot module, msDeps helpfully adds a
                  -- dependency to that non-boot module in it's result. This
                  -- means we don't have to think about boot modules here.
                  | GenWithIsBoot (GenLocated SrcSpan ModuleName)
dep <- ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
msDeps ModSummary
ms
                  , IsBootInterface
NotBoot IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== GenWithIsBoot (GenLocated SrcSpan ModuleName) -> IsBootInterface
forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot GenWithIsBoot (GenLocated SrcSpan ModuleName)
dep
                  , [Either ErrorMessages ExtendedModSummary]
dep_ms_0 <- Maybe [Either ErrorMessages ExtendedModSummary]
-> [[Either ErrorMessages ExtendedModSummary]]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe [Either ErrorMessages ExtendedModSummary]
 -> [[Either ErrorMessages ExtendedModSummary]])
-> Maybe [Either ErrorMessages ExtendedModSummary]
-> [[Either ErrorMessages ExtendedModSummary]]
forall a b. (a -> b) -> a -> b
$ ModNodeKey
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> Maybe [Either ErrorMessages ExtendedModSummary]
forall a. ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup (GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan ModuleName -> ModuleName)
-> GenWithIsBoot (GenLocated SrcSpan ModuleName) -> ModNodeKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenWithIsBoot (GenLocated SrcSpan ModuleName)
dep) ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap
                  , Either ErrorMessages ExtendedModSummary
dep_ms_1 <- [Either ErrorMessages ExtendedModSummary]
-> [Either ErrorMessages ExtendedModSummary]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ([Either ErrorMessages ExtendedModSummary]
 -> [Either ErrorMessages ExtendedModSummary])
-> [Either ErrorMessages ExtendedModSummary]
-> [Either ErrorMessages ExtendedModSummary]
forall a b. (a -> b) -> a -> b
$ [Either ErrorMessages ExtendedModSummary]
dep_ms_0
                  , (ExtendedModSummary { emsModSummary :: ExtendedModSummary -> ModSummary
emsModSummary = ModSummary
dep_ms }) <- Either ErrorMessages ExtendedModSummary -> [ExtendedModSummary]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Either ErrorMessages ExtendedModSummary -> [ExtendedModSummary])
-> Either ErrorMessages ExtendedModSummary -> [ExtendedModSummary]
forall a b. (a -> b) -> a -> b
$ Either ErrorMessages ExtendedModSummary
dep_ms_1
                  ]
                new_marked_mods :: Set Module
new_marked_mods = Module -> Set Module -> Set Module
forall a. Ord a => a -> Set a -> Set a
Set.insert Module
ms_mod Set Module
marked_mods
            in (Set Module -> ModSummary -> Set Module)
-> Set Module -> [ModSummary] -> Set Module
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Module -> ModSummary -> Set Module
go Set Module
new_marked_mods [ModSummary]
deps

mkRootMap
  :: [ExtendedModSummary]
  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
mkRootMap :: [ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
mkRootMap [ExtendedModSummary]
summaries = Map ModNodeKey [Either ErrorMessages ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap (Map ModNodeKey [Either ErrorMessages ExtendedModSummary]
 -> ModNodeMap [Either ErrorMessages ExtendedModSummary])
-> Map ModNodeKey [Either ErrorMessages ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
forall a b. (a -> b) -> a -> b
$ ([Either ErrorMessages ExtendedModSummary]
 -> [Either ErrorMessages ExtendedModSummary]
 -> [Either ErrorMessages ExtendedModSummary])
-> [(ModNodeKey, [Either ErrorMessages ExtendedModSummary])]
-> Map ModNodeKey [Either ErrorMessages ExtendedModSummary]
-> Map ModNodeKey [Either ErrorMessages ExtendedModSummary]
forall key elt.
Ord key =>
(elt -> elt -> elt) -> [(key, elt)] -> Map key elt -> Map key elt
Map.insertListWith
  (([Either ErrorMessages ExtendedModSummary]
 -> [Either ErrorMessages ExtendedModSummary]
 -> [Either ErrorMessages ExtendedModSummary])
-> [Either ErrorMessages ExtendedModSummary]
-> [Either ErrorMessages ExtendedModSummary]
-> [Either ErrorMessages ExtendedModSummary]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Either ErrorMessages ExtendedModSummary]
-> [Either ErrorMessages ExtendedModSummary]
-> [Either ErrorMessages ExtendedModSummary]
forall a. [a] -> [a] -> [a]
(++))
  [ (ModSummary -> ModNodeKey
msKey (ModSummary -> ModNodeKey) -> ModSummary -> ModNodeKey
forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
s, [ExtendedModSummary -> Either ErrorMessages ExtendedModSummary
forall a b. b -> Either a b
Right ExtendedModSummary
s]) | ExtendedModSummary
s <- [ExtendedModSummary]
summaries ]
  Map ModNodeKey [Either ErrorMessages ExtendedModSummary]
forall k a. Map k a
Map.empty

-- | Returns the dependencies of the ModSummary s.
-- A wrinkle is that for a {-# SOURCE #-} import we return
--      *both* the hs-boot file
--      *and* the source file
-- as "dependencies".  That ensures that the list of all relevant
-- modules always contains B.hs if it contains B.hs-boot.
-- Remember, this pass isn't doing the topological sort.  It's
-- just gathering the list of all relevant ModSummaries
msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]
msDeps :: ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
msDeps ModSummary
s = [ GenWithIsBoot (GenLocated SrcSpan ModuleName)
d
           | GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
s
           , GenWithIsBoot (GenLocated SrcSpan ModuleName)
d <- [ GWIB { gwib_mod :: GenLocated SrcSpan ModuleName
gwib_mod = GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
IsBoot }
                  , GWIB { gwib_mod :: GenLocated SrcSpan ModuleName
gwib_mod = GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
                  ]
           ]
        [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++ [ GWIB { gwib_mod :: GenLocated SrcSpan ModuleName
gwib_mod = GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
           | GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
s
           ]

-----------------------------------------------------------------------------
-- 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
        -> [ExtendedModSummary]         -- old summaries
        -> FilePath                     -- source file name
        -> Maybe Phase                  -- start phase
        -> Bool                         -- object code allowed?
        -> Maybe (StringBuffer,UTCTime)
        -> IO (Either ErrorMessages ExtendedModSummary)

summariseFile :: HscEnv
-> [ExtendedModSummary]
-> FilePath
-> Maybe Phase
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either ErrorMessages ExtendedModSummary)
summariseFile HscEnv
hsc_env [ExtendedModSummary]
old_summaries FilePath
src_fn Maybe Phase
mb_phase Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf
        -- we can use a cached summary if one is available and the
        -- source file hasn't changed,  But we have to look up the summary
        -- by source file, rather than module name as we do in summarise.
   | Just ExtendedModSummary
old_summary <- [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary
findSummaryBySourceFile [ExtendedModSummary]
old_summaries FilePath
src_fn
   = do
        let location :: ModLocation
location = ModSummary -> ModLocation
ms_location (ModSummary -> ModLocation) -> ModSummary -> ModLocation
forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
old_summary
            dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

        UTCTime
src_timestamp <- IO UTCTime
get_src_timestamp
                -- The file exists; we checked in getRootSummary above.
                -- If it gets removed subsequently, then this
                -- getModificationUTCTime may fail, but that's the right
                -- behaviour.

                -- return the cached summary if the source didn't change
        HscEnv
-> DynFlags
-> Bool
-> IsBootInterface
-> (UTCTime -> IO (Either ErrorMessages ExtendedModSummary))
-> ExtendedModSummary
-> ModLocation
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBootInterface
-> (UTCTime -> IO (Either e ExtendedModSummary))
-> ExtendedModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ExtendedModSummary)
checkSummaryTimestamp
            HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBootInterface
NotBoot (FilePath -> UTCTime -> IO (Either ErrorMessages ExtendedModSummary)
new_summary FilePath
src_fn)
            ExtendedModSummary
old_summary ModLocation
location UTCTime
src_timestamp

   | Bool
otherwise
   = do UTCTime
src_timestamp <- IO UTCTime
get_src_timestamp
        FilePath -> UTCTime -> IO (Either ErrorMessages ExtendedModSummary)
new_summary FilePath
src_fn UTCTime
src_timestamp
  where
    get_src_timestamp :: IO UTCTime
get_src_timestamp = case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
                           Just (InputFileBuffer
_,UTCTime
t) -> UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
t
                           Maybe (InputFileBuffer, UTCTime)
Nothing    -> IO UTCTime -> IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> IO UTCTime) -> IO UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationUTCTime FilePath
src_fn
                        -- getModificationUTCTime may fail

    new_summary :: FilePath -> UTCTime -> IO (Either ErrorMessages ExtendedModSummary)
new_summary FilePath
src_fn UTCTime
src_timestamp = ExceptT ErrorMessages IO ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorMessages IO ExtendedModSummary
 -> IO (Either ErrorMessages ExtendedModSummary))
-> ExceptT ErrorMessages IO ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall a b. (a -> b) -> a -> b
$ do
        preimps :: PreprocessedImports
preimps@PreprocessedImports {FilePath
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
ModuleName
DynFlags
InputFileBuffer
SrcSpan
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_theimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
..}
            <- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf


        -- Make a ModLocation for this file
        ModLocation
location <- IO ModLocation -> ExceptT ErrorMessages IO ModLocation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModLocation -> ExceptT ErrorMessages IO ModLocation)
-> IO ModLocation -> ExceptT ErrorMessages IO ModLocation
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> FilePath -> IO ModLocation
mkHomeModLocation (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) ModuleName
pi_mod_name FilePath
src_fn

        -- 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 ErrorMessages IO Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> ExceptT ErrorMessages IO Module)
-> IO Module -> ExceptT ErrorMessages IO Module
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env ModuleName
pi_mod_name ModLocation
location

        IO ExtendedModSummary
-> ExceptT ErrorMessages IO ExtendedModSummary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExtendedModSummary
 -> ExceptT ErrorMessages IO ExtendedModSummary)
-> IO ExtendedModSummary
-> ExceptT ErrorMessages IO ExtendedModSummary
forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
makeNewModSummary HscEnv
hsc_env (MakeNewModSummary -> IO ExtendedModSummary)
-> MakeNewModSummary -> IO ExtendedModSummary
forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
            { nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
            , nms_src_timestamp :: UTCTime
nms_src_timestamp = UTCTime
src_timestamp
            , nms_is_boot :: IsBootInterface
nms_is_boot = IsBootInterface
NotBoot
            , nms_hsc_src :: HscSource
nms_hsc_src =
                if FilePath -> Bool
isHaskellSigFilename FilePath
src_fn
                   then HscSource
HsigFile
                   else HscSource
HsSrcFile
            , nms_location :: ModLocation
nms_location = ModLocation
location
            , nms_mod :: Module
nms_mod = Module
mod
            , nms_obj_allowed :: Bool
nms_obj_allowed = Bool
obj_allowed
            , nms_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
            }

findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary
findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary
findSummaryBySourceFile [ExtendedModSummary]
summaries FilePath
file = case
    [ ExtendedModSummary
ms
    | ExtendedModSummary
ms <- [ExtendedModSummary]
summaries
    , HscSource
HsSrcFile <- [ModSummary -> HscSource
ms_hsc_src (ModSummary -> HscSource) -> ModSummary -> HscSource
forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ms]
    , let derived_file :: Maybe FilePath
derived_file = ModLocation -> Maybe FilePath
ml_hs_file (ModLocation -> Maybe FilePath) -> ModLocation -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location (ModSummary -> ModLocation) -> ModSummary -> ModLocation
forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ms
    , FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"findSummaryBySourceFile" Maybe FilePath
derived_file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
file
    ]
  of
    [] -> Maybe ExtendedModSummary
forall a. Maybe a
Nothing
    (ExtendedModSummary
x:[ExtendedModSummary]
_) -> ExtendedModSummary -> Maybe ExtendedModSummary
forall a. a -> Maybe a
Just ExtendedModSummary
x

checkSummaryTimestamp
    :: HscEnv -> DynFlags -> Bool -> IsBootInterface
    -> (UTCTime -> IO (Either e ExtendedModSummary))
    -> ExtendedModSummary -> ModLocation -> UTCTime
    -> IO (Either e ExtendedModSummary)
checkSummaryTimestamp :: forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBootInterface
-> (UTCTime -> IO (Either e ExtendedModSummary))
-> ExtendedModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ExtendedModSummary)
checkSummaryTimestamp
  HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBootInterface
is_boot UTCTime -> IO (Either e ExtendedModSummary)
new_summary
  (ExtendedModSummary { emsModSummary :: ExtendedModSummary -> ModSummary
emsModSummary = ModSummary
old_summary, emsInstantiatedUnits :: ExtendedModSummary -> [InstantiatedUnit]
emsInstantiatedUnits = [InstantiatedUnit]
bkp_deps})
  ModLocation
location UTCTime
src_timestamp
  | ModSummary -> UTCTime
ms_hs_date ModSummary
old_summary UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
src_timestamp 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 <-
             if Backend -> Bool
backendProducesObject (DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
                 Bool -> Bool -> Bool
|| Bool
obj_allowed -- bug #1205
                 then IO (Maybe UTCTime) -> IO (Maybe UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UTCTime) -> IO (Maybe UTCTime))
-> IO (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
location IsBootInterface
is_boot
                 else Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing

           -- 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.
           Module
_ <- HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env
                  (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
old_summary)) ModLocation
location

           Maybe UTCTime
hi_timestamp <- DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate DynFlags
dflags ModLocation
location
           Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
location)

           Either e ExtendedModSummary -> IO (Either e ExtendedModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e ExtendedModSummary -> IO (Either e ExtendedModSummary))
-> Either e ExtendedModSummary -> IO (Either e ExtendedModSummary)
forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> Either e ExtendedModSummary
forall a b. b -> Either a b
Right
             ( ExtendedModSummary { emsModSummary :: ModSummary
emsModSummary = ModSummary
old_summary
                     { ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
                     , ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
                     , ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
                     }
                   , emsInstantiatedUnits :: [InstantiatedUnit]
emsInstantiatedUnits = [InstantiatedUnit]
bkp_deps
                   }
             )

   | Bool
otherwise =
           -- source changed: re-summarise.
           UTCTime -> IO (Either e ExtendedModSummary)
new_summary UTCTime
src_timestamp

-- Summarise a module, and pick up source and timestamp.
summariseModule
          :: HscEnv
          -> ModNodeMap ExtendedModSummary
          -- ^ Map of old summaries
          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
          -> Located ModuleName -- Imported module to be summarised
          -> Bool               -- object code allowed?
          -> Maybe (StringBuffer, UTCTime)
          -> [ModuleName]               -- Modules to exclude
          -> IO (Maybe (Either ErrorMessages ExtendedModSummary))      -- Its new summary

summariseModule :: HscEnv
-> ModNodeMap ExtendedModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
summariseModule HscEnv
hsc_env ModNodeMap ExtendedModSummary
old_summary_map IsBootInterface
is_boot (L SrcSpan
loc ModuleName
wanted_mod)
                Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
  | ModuleName
wanted_mod ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
excl_mods
  = Maybe (Either ErrorMessages ExtendedModSummary)
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either ErrorMessages ExtendedModSummary)
forall a. Maybe a
Nothing

  | Just ExtendedModSummary
old_summary <- ModNodeKey
-> ModNodeMap ExtendedModSummary -> Maybe ExtendedModSummary
forall a. ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup
      (GWIB { gwib_mod :: ModuleName
gwib_mod = ModuleName
wanted_mod, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
is_boot })
      ModNodeMap ExtendedModSummary
old_summary_map
  = do          -- Find its new timestamp; all the
                -- ModSummaries in the old map have valid ml_hs_files
        let location :: ModLocation
location = ModSummary -> ModLocation
ms_location (ModSummary -> ModLocation) -> ModSummary -> ModLocation
forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
old_summary
            src_fn :: FilePath
src_fn = FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"summariseModule" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location)

                -- check the modification time on the source file, and
                -- return the cached summary if it hasn't changed.  If the
                -- file has disappeared, we need to call the Finder again.
        case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
           Just (InputFileBuffer
_,UTCTime
t) ->
               Either ErrorMessages ExtendedModSummary
-> Maybe (Either ErrorMessages ExtendedModSummary)
forall a. a -> Maybe a
Just (Either ErrorMessages ExtendedModSummary
 -> Maybe (Either ErrorMessages ExtendedModSummary))
-> IO (Either ErrorMessages ExtendedModSummary)
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtendedModSummary
-> ModLocation
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
check_timestamp ExtendedModSummary
old_summary ModLocation
location FilePath
src_fn UTCTime
t
           Maybe (InputFileBuffer, UTCTime)
Nothing    -> do
                Either IOException UTCTime
m <- IO UTCTime -> IO (Either IOException UTCTime)
forall a. IO a -> IO (Either IOException a)
tryIO (FilePath -> IO UTCTime
getModificationUTCTime FilePath
src_fn)
                case Either IOException UTCTime
m of
                   Right UTCTime
t ->
                       Either ErrorMessages ExtendedModSummary
-> Maybe (Either ErrorMessages ExtendedModSummary)
forall a. a -> Maybe a
Just (Either ErrorMessages ExtendedModSummary
 -> Maybe (Either ErrorMessages ExtendedModSummary))
-> IO (Either ErrorMessages ExtendedModSummary)
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtendedModSummary
-> ModLocation
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
check_timestamp ExtendedModSummary
old_summary ModLocation
location FilePath
src_fn UTCTime
t
                   Left IOException
e | IOException -> Bool
isDoesNotExistError IOException
e -> IO (Maybe (Either ErrorMessages ExtendedModSummary))
find_it
                          | Bool
otherwise             -> IOException -> IO (Maybe (Either ErrorMessages ExtendedModSummary))
forall a. IOException -> IO a
ioError IOException
e

  | Bool
otherwise  = IO (Maybe (Either ErrorMessages ExtendedModSummary))
find_it
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env

    check_timestamp :: ExtendedModSummary
-> ModLocation
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
check_timestamp ExtendedModSummary
old_summary ModLocation
location FilePath
src_fn =
        HscEnv
-> DynFlags
-> Bool
-> IsBootInterface
-> (UTCTime -> IO (Either ErrorMessages ExtendedModSummary))
-> ExtendedModSummary
-> ModLocation
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBootInterface
-> (UTCTime -> IO (Either e ExtendedModSummary))
-> ExtendedModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ExtendedModSummary)
checkSummaryTimestamp
          HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBootInterface
is_boot
          (ModLocation
-> Module
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
new_summary ModLocation
location (ModSummary -> Module
ms_mod (ModSummary -> Module) -> ModSummary -> Module
forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
old_summary) FilePath
src_fn)
          ExtendedModSummary
old_summary ModLocation
location

    find_it :: IO (Maybe (Either ErrorMessages ExtendedModSummary))
find_it = do
        FindResult
found <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
wanted_mod Maybe FastString
forall a. Maybe a
Nothing
        case FindResult
found of
             Found ModLocation
location Module
mod
                | Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location) ->
                        -- Home package
                         Either ErrorMessages ExtendedModSummary
-> Maybe (Either ErrorMessages ExtendedModSummary)
forall a. a -> Maybe a
Just (Either ErrorMessages ExtendedModSummary
 -> Maybe (Either ErrorMessages ExtendedModSummary))
-> IO (Either ErrorMessages ExtendedModSummary)
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModLocation
-> Module -> IO (Either ErrorMessages ExtendedModSummary)
just_found ModLocation
location Module
mod

             FindResult
_ -> Maybe (Either ErrorMessages ExtendedModSummary)
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either ErrorMessages ExtendedModSummary)
forall a. Maybe a
Nothing
                        -- Not found
                        -- (If it is TRULY not found at all, we'll
                        -- error when we actually try to compile)

    just_found :: ModLocation
-> Module -> IO (Either ErrorMessages ExtendedModSummary)
just_found 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 location' :: ModLocation
location' = case IsBootInterface
is_boot of
              IsBootInterface
IsBoot -> ModLocation -> ModLocation
addBootSuffixLocn ModLocation
location
              IsBootInterface
NotBoot -> ModLocation
location
            src_fn :: FilePath
src_fn = FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"summarise2" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location')

                -- Check that it exists
                -- It might have been deleted since the Finder last found it
        Maybe UTCTime
maybe_t <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists FilePath
src_fn
        case Maybe UTCTime
maybe_t of
          Maybe UTCTime
Nothing -> Either ErrorMessages ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMessages ExtendedModSummary
 -> IO (Either ErrorMessages ExtendedModSummary))
-> Either ErrorMessages ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> Either ErrorMessages ExtendedModSummary
forall a b. a -> Either a b
Left (ErrorMessages -> Either ErrorMessages ExtendedModSummary)
-> ErrorMessages -> Either ErrorMessages ExtendedModSummary
forall a b. (a -> b) -> a -> b
$ SrcSpan -> FilePath -> ErrorMessages
noHsFileErr SrcSpan
loc FilePath
src_fn
          Just UTCTime
t  -> ModLocation
-> Module
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
new_summary ModLocation
location' Module
mod FilePath
src_fn UTCTime
t

    new_summary :: ModLocation
-> Module
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
new_summary ModLocation
location Module
mod FilePath
src_fn UTCTime
src_timestamp
      = ExceptT ErrorMessages IO ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorMessages IO ExtendedModSummary
 -> IO (Either ErrorMessages ExtendedModSummary))
-> ExceptT ErrorMessages IO ExtendedModSummary
-> IO (Either ErrorMessages ExtendedModSummary)
forall a b. (a -> b) -> a -> b
$ do
        preimps :: PreprocessedImports
preimps@PreprocessedImports {FilePath
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
ModuleName
DynFlags
InputFileBuffer
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_theimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..}
            <- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
forall a. Maybe a
Nothing Maybe (InputFileBuffer, 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 ErrorMessages IO () -> ExceptT ErrorMessages IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
pi_mod_name ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleName
wanted_mod) (ExceptT ErrorMessages IO () -> ExceptT ErrorMessages IO ())
-> ExceptT ErrorMessages IO () -> ExceptT ErrorMessages IO ()
forall a b. (a -> b) -> a -> b
$
                ErrorMessages -> ExceptT ErrorMessages IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrorMessages -> ExceptT ErrorMessages IO ())
-> ErrorMessages -> ExceptT ErrorMessages IO ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a. a -> Bag a
unitBag (MsgEnvelope DecoratedSDoc -> ErrorMessages)
-> MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
pi_mod_name_loc (SDoc -> MsgEnvelope DecoratedSDoc)
-> SDoc -> MsgEnvelope DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
                              FilePath -> SDoc
text FilePath
"File name does not match module name:"
                              SDoc -> SDoc -> SDoc
$$ FilePath -> SDoc
text FilePath
"Saw:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name)
                              SDoc -> SDoc -> SDoc
$$ FilePath -> SDoc
text FilePath
"Expected:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
wanted_mod)

        Bool -> ExceptT ErrorMessages IO () -> ExceptT ErrorMessages 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 -> [(ModuleName, Module)] -> Maybe Module
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
pi_mod_name (HomeUnit -> [(ModuleName, Module)]
forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit))) (ExceptT ErrorMessages IO () -> ExceptT ErrorMessages IO ())
-> ExceptT ErrorMessages IO () -> ExceptT ErrorMessages IO ()
forall a b. (a -> b) -> a -> b
$
            let suggested_instantiated_with :: SDoc
suggested_instantiated_with =
                    [SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
                        [ ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
k SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"=" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
v
                        | (ModuleName
k,Module
v) <- ((ModuleName
pi_mod_name, ModuleName -> Module
forall u. ModuleName -> GenModule (GenUnit u)
mkHoleModule ModuleName
pi_mod_name)
                                (ModuleName, Module)
-> [(ModuleName, Module)] -> [(ModuleName, Module)]
forall a. a -> [a] -> [a]
: HomeUnit -> [(ModuleName, Module)]
forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit)
                        ])
            in ErrorMessages -> ExceptT ErrorMessages IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrorMessages -> ExceptT ErrorMessages IO ())
-> ErrorMessages -> ExceptT ErrorMessages IO ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a. a -> Bag a
unitBag (MsgEnvelope DecoratedSDoc -> ErrorMessages)
-> MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
pi_mod_name_loc (SDoc -> MsgEnvelope DecoratedSDoc)
-> SDoc -> MsgEnvelope DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
                FilePath -> SDoc
text FilePath
"Unexpected signature:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name)
                SDoc -> SDoc -> SDoc
$$ if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildingCabalPackage DynFlags
dflags
                    then SDoc -> SDoc
parens (FilePath -> SDoc
text FilePath
"Try adding" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name)
                            SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"to the"
                            SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FilePath -> SDoc
text FilePath
"signatures")
                            SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"field in your Cabal file.")
                    else SDoc -> SDoc
parens (FilePath -> SDoc
text FilePath
"Try passing -instantiated-with=\"" SDoc -> SDoc -> SDoc
<>
                                 SDoc
suggested_instantiated_with SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"\"" SDoc -> SDoc -> SDoc
$$
                                FilePath -> SDoc
text FilePath
"replacing <" SDoc -> SDoc -> SDoc
<> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"> as necessary.")

        IO ExtendedModSummary
-> ExceptT ErrorMessages IO ExtendedModSummary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExtendedModSummary
 -> ExceptT ErrorMessages IO ExtendedModSummary)
-> IO ExtendedModSummary
-> ExceptT ErrorMessages IO ExtendedModSummary
forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
makeNewModSummary HscEnv
hsc_env (MakeNewModSummary -> IO ExtendedModSummary)
-> MakeNewModSummary -> IO ExtendedModSummary
forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
            { nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
            , nms_src_timestamp :: UTCTime
nms_src_timestamp = UTCTime
src_timestamp
            , nms_is_boot :: IsBootInterface
nms_is_boot = IsBootInterface
is_boot
            , 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_obj_allowed :: Bool
nms_obj_allowed = Bool
obj_allowed
            , 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 -> UTCTime
nms_src_timestamp :: UTCTime
      , MakeNewModSummary -> IsBootInterface
nms_is_boot :: IsBootInterface
      , MakeNewModSummary -> HscSource
nms_hsc_src :: HscSource
      , MakeNewModSummary -> ModLocation
nms_location :: ModLocation
      , MakeNewModSummary -> Module
nms_mod :: Module
      , MakeNewModSummary -> Bool
nms_obj_allowed :: Bool
      , MakeNewModSummary -> PreprocessedImports
nms_preimps :: PreprocessedImports
      }

makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
makeNewModSummary HscEnv
hsc_env MakeNewModSummary{Bool
FilePath
UTCTime
Module
IsBootInterface
ModLocation
HscSource
PreprocessedImports
nms_preimps :: PreprocessedImports
nms_obj_allowed :: Bool
nms_mod :: Module
nms_location :: ModLocation
nms_hsc_src :: HscSource
nms_is_boot :: IsBootInterface
nms_src_timestamp :: UTCTime
nms_src_fn :: FilePath
nms_preimps :: MakeNewModSummary -> PreprocessedImports
nms_obj_allowed :: MakeNewModSummary -> Bool
nms_mod :: MakeNewModSummary -> Module
nms_location :: MakeNewModSummary -> ModLocation
nms_hsc_src :: MakeNewModSummary -> HscSource
nms_is_boot :: MakeNewModSummary -> IsBootInterface
nms_src_timestamp :: MakeNewModSummary -> UTCTime
nms_src_fn :: MakeNewModSummary -> FilePath
..} = do
  let PreprocessedImports{FilePath
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
ModuleName
DynFlags
InputFileBuffer
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_theimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..} = PreprocessedImports
nms_preimps
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

  -- when the user asks to load a source file by name, we only
  -- use an object file if -fobject-code is on.  See #1205.
  Maybe UTCTime
obj_timestamp <- IO (Maybe UTCTime) -> IO (Maybe UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UTCTime) -> IO (Maybe UTCTime))
-> IO (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$
      if Backend -> Bool
backendProducesObject (DynFlags -> Backend
backend DynFlags
dflags)
         Bool -> Bool -> Bool
|| Bool
nms_obj_allowed -- bug #1205
          then ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
nms_location IsBootInterface
nms_is_boot
          else Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing

  Maybe UTCTime
hi_timestamp <- DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate DynFlags
dflags ModLocation
nms_location
  Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
nms_location)

  [(Maybe FastString, GenLocated SrcSpan ModuleName)]
extra_sig_imports <- HscEnv
-> HscSource
-> ModuleName
-> IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
findExtraSigImports HscEnv
hsc_env HscSource
nms_hsc_src ModuleName
pi_mod_name
  ([ModuleName]
implicit_sigs, [InstantiatedUnit]
inst_deps) <- HscEnv
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow HscEnv
hsc_env [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_theimps

  ExtendedModSummary -> IO ExtendedModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return (ExtendedModSummary -> IO ExtendedModSummary)
-> ExtendedModSummary -> IO ExtendedModSummary
forall a b. (a -> b) -> a -> b
$ ExtendedModSummary
    { emsModSummary :: ModSummary
emsModSummary =
        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 InputFileBuffer
ms_hspp_buf  = InputFileBuffer -> Maybe InputFileBuffer
forall a. a -> Maybe a
Just InputFileBuffer
pi_hspp_buf
        , ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = Maybe HsParsedModule
forall a. Maybe a
Nothing
        , ms_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_srcimps = [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps
        , ms_textual_imps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_textual_imps =
            [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_theimps [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++
            [(Maybe FastString, GenLocated SrcSpan ModuleName)]
extra_sig_imports [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++
            ((,) Maybe FastString
forall a. Maybe a
Nothing (GenLocated SrcSpan ModuleName
 -> (Maybe FastString, GenLocated SrcSpan ModuleName))
-> (ModuleName -> GenLocated SrcSpan ModuleName)
-> ModuleName
-> (Maybe FastString, GenLocated SrcSpan ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> GenLocated SrcSpan ModuleName
forall e. e -> Located e
noLoc (ModuleName -> (Maybe FastString, GenLocated SrcSpan ModuleName))
-> [ModuleName]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
implicit_sigs)
        , ms_hs_date :: UTCTime
ms_hs_date = UTCTime
nms_src_timestamp
        , 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
        }
    , emsInstantiatedUnits :: [InstantiatedUnit]
emsInstantiatedUnits = [InstantiatedUnit]
inst_deps
    }

getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
location IsBootInterface
is_boot
  = case IsBootInterface
is_boot of
      IsBootInterface
IsBoot -> Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing
      IsBootInterface
NotBoot -> FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_obj_file ModLocation
location)

data PreprocessedImports
  = PreprocessedImports
      { PreprocessedImports -> DynFlags
pi_local_dflags :: DynFlags
      , PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps  :: [(Maybe FastString, Located ModuleName)]
      , PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_theimps  :: [(Maybe FastString, Located ModuleName)]
      , PreprocessedImports -> FilePath
pi_hspp_fn  :: FilePath
      , PreprocessedImports -> InputFileBuffer
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 ErrorMessages IO PreprocessedImports
getPreprocessedImports :: HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf = do
  (DynFlags
pi_local_dflags, FilePath
pi_hspp_fn)
      <- IO (Either ErrorMessages (DynFlags, FilePath))
-> ExceptT ErrorMessages IO (DynFlags, FilePath)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorMessages (DynFlags, FilePath))
 -> ExceptT ErrorMessages IO (DynFlags, FilePath))
-> IO (Either ErrorMessages (DynFlags, FilePath))
-> ExceptT ErrorMessages IO (DynFlags, FilePath)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, FilePath))
preprocess HscEnv
hsc_env FilePath
src_fn ((InputFileBuffer, UTCTime) -> InputFileBuffer
forall a b. (a, b) -> a
fst ((InputFileBuffer, UTCTime) -> InputFileBuffer)
-> Maybe (InputFileBuffer, UTCTime) -> Maybe InputFileBuffer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (InputFileBuffer, UTCTime)
maybe_buf) Maybe Phase
mb_phase
  InputFileBuffer
pi_hspp_buf <- IO InputFileBuffer -> ExceptT ErrorMessages IO InputFileBuffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InputFileBuffer -> ExceptT ErrorMessages IO InputFileBuffer)
-> IO InputFileBuffer -> ExceptT ErrorMessages IO InputFileBuffer
forall a b. (a -> b) -> a -> b
$ FilePath -> IO InputFileBuffer
hGetStringBuffer FilePath
pi_hspp_fn
  ([(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps, [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_theimps, L SrcSpan
pi_mod_name_loc ModuleName
pi_mod_name)
      <- IO
  (Either
     ErrorMessages
     ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
      [(Maybe FastString, GenLocated SrcSpan ModuleName)],
      GenLocated SrcSpan ModuleName))
-> ExceptT
     ErrorMessages
     IO
     ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
      [(Maybe FastString, GenLocated SrcSpan ModuleName)],
      GenLocated SrcSpan ModuleName)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO
   (Either
      ErrorMessages
      ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
       [(Maybe FastString, GenLocated SrcSpan ModuleName)],
       GenLocated SrcSpan ModuleName))
 -> ExceptT
      ErrorMessages
      IO
      ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
       [(Maybe FastString, GenLocated SrcSpan ModuleName)],
       GenLocated SrcSpan ModuleName))
-> IO
     (Either
        ErrorMessages
        ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
         [(Maybe FastString, GenLocated SrcSpan ModuleName)],
         GenLocated SrcSpan ModuleName))
-> ExceptT
     ErrorMessages
     IO
     ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
      [(Maybe FastString, GenLocated SrcSpan ModuleName)],
      GenLocated SrcSpan 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
  (Bag PsError)
  ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
   [(Maybe FastString, GenLocated SrcSpan ModuleName)],
   GenLocated SrcSpan ModuleName)
mimps <- ParserOpts
-> Bool
-> InputFileBuffer
-> FilePath
-> FilePath
-> IO
     (Either
        (Bag PsError)
        ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
         [(Maybe FastString, GenLocated SrcSpan ModuleName)],
         GenLocated SrcSpan ModuleName))
getImports ParserOpts
popts Bool
imp_prelude InputFileBuffer
pi_hspp_buf FilePath
pi_hspp_fn FilePath
src_fn
          Either
  ErrorMessages
  ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
   [(Maybe FastString, GenLocated SrcSpan ModuleName)],
   GenLocated SrcSpan ModuleName)
-> IO
     (Either
        ErrorMessages
        ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
         [(Maybe FastString, GenLocated SrcSpan ModuleName)],
         GenLocated SrcSpan ModuleName))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bag PsError -> ErrorMessages)
-> Either
     (Bag PsError)
     ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
      [(Maybe FastString, GenLocated SrcSpan ModuleName)],
      GenLocated SrcSpan ModuleName)
-> Either
     ErrorMessages
     ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
      [(Maybe FastString, GenLocated SrcSpan ModuleName)],
      GenLocated SrcSpan ModuleName)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((PsError -> MsgEnvelope DecoratedSDoc)
-> Bag PsError -> ErrorMessages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError) Either
  (Bag PsError)
  ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
   [(Maybe FastString, GenLocated SrcSpan ModuleName)],
   GenLocated SrcSpan ModuleName)
mimps)
  PreprocessedImports -> ExceptT ErrorMessages IO PreprocessedImports
forall (m :: * -> *) a. Monad m => a -> m a
return PreprocessedImports {FilePath
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
ModuleName
DynFlags
InputFileBuffer
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_local_dflags :: DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
..}


-----------------------------------------------------------------------------
--                      Error messages
-----------------------------------------------------------------------------

-- Defer and group warning, error and fatal messages so they will not get lost
-- in the regular output.
withDeferredDiagnostics :: GhcMonad m => m a -> m a
withDeferredDiagnostics :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics m a
f = do
  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DeferDiagnostics DynFlags
dflags
  then m a
f
  else do
    IORef [IO ()]
warnings <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
    IORef [IO ()]
errors <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
    IORef [IO ()]
fatals <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
    Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger

    let deferDiagnostics :: LogAction
deferDiagnostics DynFlags
_dflags !WarnReason
reason !Severity
severity !SrcSpan
srcSpan !SDoc
msg = do
          let action :: IO ()
action = Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
reason Severity
severity SrcSpan
srcSpan SDoc
msg
          case Severity
severity of
            Severity
SevWarning -> IORef [IO ()] -> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
warnings (([IO ()] -> ([IO ()], ())) -> IO ())
-> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionIO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
i, ())
            Severity
SevError -> IORef [IO ()] -> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
errors (([IO ()] -> ([IO ()], ())) -> IO ())
-> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionIO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
i, ())
            Severity
SevFatal -> IORef [IO ()] -> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
fatals (([IO ()] -> ([IO ()], ())) -> IO ())
-> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionIO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
i, ())
            Severity
_ -> IO ()
action

        printDeferredDiagnostics :: m ()
printDeferredDiagnostics = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
          [IORef [IO ()]] -> (IORef [IO ()] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [IORef [IO ()]
warnings, IORef [IO ()]
errors, IORef [IO ()]
fatals] ((IORef [IO ()] -> IO ()) -> IO ())
-> (IORef [IO ()] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IORef [IO ()]
ref -> do
            -- This IORef can leak when the dflags leaks, so let us always
            -- reset the content.
            [IO ()]
actions <- IORef [IO ()] -> ([IO ()] -> ([IO ()], [IO ()])) -> IO [IO ()]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
ref (([IO ()] -> ([IO ()], [IO ()])) -> IO [IO ()])
-> ([IO ()] -> ([IO ()], [IO ()])) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> ([], [IO ()]
i)
            [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ [IO ()] -> [IO ()]
forall a. [a] -> [a]
reverse [IO ()]
actions

    m () -> (() -> m ()) -> (() -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket
      ((LogAction -> LogAction) -> m ()
forall (m :: * -> *).
GhcMonad m =>
(LogAction -> LogAction) -> m ()
pushLogHookM (LogAction -> LogAction -> LogAction
forall a b. a -> b -> a
const LogAction
deferDiagnostics))
      (\()
_ -> m ()
forall (m :: * -> *). GhcMonad m => m ()
popLogHookM m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
printDeferredDiagnostics)
      (\()
_ -> m a
f)

noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc
-- ToDo: we don't have a proper line number for this error
noModError :: HscEnv
-> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc
noModError HscEnv
hsc_env SrcSpan
loc ModuleName
wanted_mod FindResult
err
  = SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc (SDoc -> MsgEnvelope DecoratedSDoc)
-> SDoc -> MsgEnvelope DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
hsc_env ModuleName
wanted_mod FindResult
err

noHsFileErr :: SrcSpan -> String -> ErrorMessages
noHsFileErr :: SrcSpan -> FilePath -> ErrorMessages
noHsFileErr SrcSpan
loc FilePath
path
  = MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a. a -> Bag a
unitBag (MsgEnvelope DecoratedSDoc -> ErrorMessages)
-> MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc (SDoc -> MsgEnvelope DecoratedSDoc)
-> SDoc -> MsgEnvelope DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text FilePath
"Can't find" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
path

moduleNotFoundErr :: ModuleName -> ErrorMessages
moduleNotFoundErr :: ModuleName -> ErrorMessages
moduleNotFoundErr ModuleName
mod
  = MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a. a -> Bag a
unitBag (MsgEnvelope DecoratedSDoc -> ErrorMessages)
-> MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan (SDoc -> MsgEnvelope DecoratedSDoc)
-> SDoc -> MsgEnvelope DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
        FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod) SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"cannot be found locally"

multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = FilePath -> IO ()
forall a. FilePath -> a
panic FilePath
"multiRootsErr"
multiRootsErr summs :: [ModSummary]
summs@(ModSummary
summ1:[ModSummary]
_)
  = MsgEnvelope DecoratedSDoc -> IO ()
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope DecoratedSDoc -> io a
throwOneError (MsgEnvelope DecoratedSDoc -> IO ())
-> MsgEnvelope DecoratedSDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan (SDoc -> MsgEnvelope DecoratedSDoc)
-> SDoc -> MsgEnvelope DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
        FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod) SDoc -> SDoc -> SDoc
<+>
        FilePath -> SDoc
text FilePath
"is defined in multiple files:" SDoc -> SDoc -> SDoc
<+>
        [SDoc] -> SDoc
sep ((FilePath -> SDoc) -> [FilePath] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> SDoc
text [FilePath]
files)
  where
    mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
summ1
    files :: [FilePath]
files = (ModSummary -> FilePath) -> [ModSummary] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"checkDup" (Maybe FilePath -> FilePath)
-> (ModSummary -> Maybe FilePath) -> ModSummary -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModLocation -> Maybe FilePath
ml_hs_file (ModLocation -> Maybe FilePath)
-> (ModSummary -> ModLocation) -> ModSummary -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
ms_location) [ModSummary]
summs

keepGoingPruneErr :: [NodeKey] -> SDoc
keepGoingPruneErr :: [NodeKey] -> SDoc
keepGoingPruneErr [NodeKey]
ms
  = [SDoc] -> SDoc
vcat (( FilePath -> SDoc
text FilePath
"-fkeep-going in use, removing the following" SDoc -> SDoc -> SDoc
<+>
            FilePath -> SDoc
text FilePath
"dependencies and continuing:")SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:
          (NodeKey -> SDoc) -> [NodeKey] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> SDoc -> SDoc
nest Int
6 (SDoc -> SDoc) -> (NodeKey -> SDoc) -> NodeKey -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> SDoc
pprNodeKey) [NodeKey]
ms )

cyclicModuleErr :: [ModuleGraphNode] -> SDoc
-- From a strongly connected component we find
-- a single cycle to report
cyclicModuleErr :: [ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
mss
  = ASSERT( not (null mss) )
    case [Node NodeKey ModuleGraphNode] -> Maybe [ModuleGraphNode]
forall payload key.
Ord key =>
[Node key payload] -> Maybe [payload]
findCycle [Node NodeKey ModuleGraphNode]
graph of
       Maybe [ModuleGraphNode]
Nothing   -> FilePath -> SDoc
text FilePath
"Unexpected non-cycle" SDoc -> SDoc -> SDoc
<+> [ModuleGraphNode] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleGraphNode]
mss
       Just [ModuleGraphNode]
path0 -> [SDoc] -> SDoc
vcat
        [ case [ModuleGraphNode] -> ([InstantiatedUnit], [ExtendedModSummary])
partitionNodes [ModuleGraphNode]
path0 of
            ([],[ExtendedModSummary]
_) -> FilePath -> SDoc
text FilePath
"Module imports form a cycle:"
            ([InstantiatedUnit]
_,[]) -> FilePath -> SDoc
text FilePath
"Module instantiations form a cycle:"
            ([InstantiatedUnit], [ExtendedModSummary])
_ -> FilePath -> SDoc
text FilePath
"Module imports and instantiations form a cycle:"
        , Int -> SDoc -> SDoc
nest Int
2 ([ModuleGraphNode] -> SDoc
show_path [ModuleGraphNode]
path0)]
  where
    graph :: [Node NodeKey ModuleGraphNode]
    graph :: [Node NodeKey ModuleGraphNode]
graph =
      [ DigraphNode
        { node_payload :: ModuleGraphNode
node_payload = ModuleGraphNode
ms
        , node_key :: NodeKey
node_key = ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
ms
        , node_dependencies :: [NodeKey]
node_dependencies = ModuleGraphNode -> [NodeKey]
get_deps ModuleGraphNode
ms
        }
      | ModuleGraphNode
ms <- [ModuleGraphNode]
mss
      ]

    get_deps :: ModuleGraphNode -> [NodeKey]
    get_deps :: ModuleGraphNode -> [NodeKey]
get_deps = \case
      InstantiationNode InstantiatedUnit
iuid ->
        [ ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey) -> ModNodeKey -> NodeKey
forall a b. (a -> b) -> a -> b
$ GWIB { gwib_mod :: ModuleName
gwib_mod = ModuleName
hole, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
        | ModuleName
hole <- UniqDSet ModuleName -> [ModuleName]
forall a. UniqDSet a -> [a]
uniqDSetToList (UniqDSet ModuleName -> [ModuleName])
-> UniqDSet ModuleName -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> UniqDSet ModuleName
forall unit. GenInstantiatedUnit unit -> UniqDSet ModuleName
instUnitHoles InstantiatedUnit
iuid
        ]
      ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bds) ->
        [ ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey) -> ModNodeKey -> NodeKey
forall a b. (a -> b) -> a -> b
$ GWIB { gwib_mod :: ModuleName
gwib_mod = GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
IsBoot }
        | GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
ms ] [NodeKey] -> [NodeKey] -> [NodeKey]
forall a. [a] -> [a] -> [a]
++
        [ ModNodeKey -> NodeKey
NodeKey_Module (ModNodeKey -> NodeKey) -> ModNodeKey -> NodeKey
forall a b. (a -> b) -> a -> b
$ GWIB { gwib_mod :: ModuleName
gwib_mod = GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
        | GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps    ModSummary
ms ] [NodeKey] -> [NodeKey] -> [NodeKey]
forall a. [a] -> [a] -> [a]
++
        [ InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
inst_unit
        | InstantiatedUnit
inst_unit <- [InstantiatedUnit]
bds
        ]

    show_path :: [ModuleGraphNode] -> SDoc
    show_path :: [ModuleGraphNode] -> SDoc
show_path []  = FilePath -> SDoc
forall a. FilePath -> a
panic FilePath
"show_path"
    show_path [ModuleGraphNode
m] = ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"imports itself"
    show_path (ModuleGraphNode
m1:ModuleGraphNode
m2:[ModuleGraphNode]
ms) = [SDoc] -> SDoc
vcat ( Int -> SDoc -> SDoc
nest Int
6 (ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m1)
                                SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: Int -> SDoc -> SDoc
nest Int
6 (FilePath -> SDoc
text FilePath
"imports" SDoc -> SDoc -> SDoc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m2)
                                SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [ModuleGraphNode] -> [SDoc]
go [ModuleGraphNode]
ms )
       where
         go :: [ModuleGraphNode] -> [SDoc]
go []     = [FilePath -> SDoc
text FilePath
"which imports" SDoc -> SDoc -> SDoc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m1]
         go (ModuleGraphNode
m:[ModuleGraphNode]
ms) = (FilePath -> SDoc
text FilePath
"which imports" SDoc -> SDoc -> SDoc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m) SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [ModuleGraphNode] -> [SDoc]
go [ModuleGraphNode]
ms

    ppr_node :: ModuleGraphNode -> SDoc
    ppr_node :: ModuleGraphNode -> SDoc
ppr_node (ModuleNode ExtendedModSummary
m) = FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> ModSummary -> SDoc
ppr_ms (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
m)
    ppr_node (InstantiationNode InstantiatedUnit
u) = FilePath -> SDoc
text FilePath
"instantiated unit" SDoc -> SDoc -> SDoc
<+> InstantiatedUnit -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
u

    ppr_ms :: ModSummary -> SDoc
    ppr_ms :: ModSummary -> SDoc
ppr_ms ModSummary
ms = SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
ms))) SDoc -> SDoc -> SDoc
<+>
                (SDoc -> SDoc
parens (FilePath -> SDoc
text (ModSummary -> FilePath
msHsFilePath ModSummary
ms)))