{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
module GHC.Driver.Make (
depanal, depanalE, depanalPartial, checkHomeUnitsClosed,
load, loadWithCache, load', LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,
instantiationNodes,
downsweep,
topSortModuleGraph,
ms_home_srcimps, ms_home_imps,
summariseModule,
SummariseResult(..),
summariseFile,
hscSourceToIsBoot,
findExtraSigImports,
implicitRequirementsShallow,
noModError, cyclicModuleErr,
SummaryNode,
IsBootInterface(..), mkNodeKey,
ModNodeKey, ModNodeKeyWithUid(..),
ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith
) where
import GHC.Prelude
import GHC.Platform
import GHC.Tc.Utils.Backpack
import GHC.Tc.Utils.Monad ( initIfaceCheck, concatMapM )
import GHC.Runtime.Interpreter
import qualified GHC.Linker.Loader as Linker
import GHC.Linker.Types
import GHC.Platform.Ways
import GHC.Driver.Config.Finder (initFinderOpts)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Diagnostic
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.Errors.Types
import GHC.Driver.Main
import GHC.Parser.Header
import GHC.Iface.Load ( cannotFindModule )
import GHC.IfaceToCore ( typecheckIface )
import GHC.Iface.Recomp ( RecompileRequired(..), CompileReason(..) )
import GHC.Data.Bag ( listToBag )
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 ( throwIO, SomeAsyncException )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Fingerprint
import GHC.Utils.TmpFs
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.Target
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.PkgQual
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.ModDetails
import Data.Either ( rights, partitionEithers, lefts )
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import qualified Control.Monad.Catch as MC
import Data.IORef
import Data.Maybe
import Data.Time
import Data.Bifunctor (first)
import System.Directory
import System.FilePath
import System.IO ( fixIO )
import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import GHC.Driver.Pipeline.LogQueue
import qualified Data.Map.Strict as M
import GHC.Types.TypeEnv
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.Class
import GHC.Driver.Env.KnotVars
import Control.Concurrent.STM
import Control.Monad.Trans.Maybe
import GHC.Runtime.Loader
import GHC.Rename.Names
import GHC.Utils.Constants
import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
import qualified Data.IntSet as I
import GHC.Types.Unique
depanal :: GhcMonad m =>
[ModuleName]
-> Bool
-> m ModuleGraph
depanal :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [ModuleName]
excluded_mods Bool
allow_dup_roots = do
(DriverMessages
errs, ModuleGraph
mod_graph) <- [ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots
if DriverMessages -> Bool
forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
then ModuleGraph -> m ModuleGraph
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleGraph
mod_graph
else Messages GhcMessage -> m ModuleGraph
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors ((DriverMessage -> GhcMessage)
-> DriverMessages -> Messages GhcMessage
forall a b. (a -> b) -> Messages a -> Messages b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage DriverMessages
errs)
depanalE :: GhcMonad m =>
[ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalE :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
(DriverMessages
errs, ModuleGraph
mod_graph) <- [ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots
if DriverMessages -> Bool
forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
then do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let one_unit_messages :: IO DriverMessages -> UnitId -> HomeUnitEnv -> IO DriverMessages
one_unit_messages IO DriverMessages
get_mod_errs UnitId
k HomeUnitEnv
hue = do
DriverMessages
errs <- IO DriverMessages
get_mod_errs
DriverMessages
unknown_module_err <- HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
warnUnknownModules ((() :: Constraint) => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId UnitId
k HscEnv
hsc_env) (HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue) ModuleGraph
mod_graph
let unused_home_mod_err :: DriverMessages
unused_home_mod_err = DynFlags -> [Target] -> ModuleGraph -> DriverMessages
warnMissingHomeModules (HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue) (HscEnv -> [Target]
hsc_targets HscEnv
hsc_env) ModuleGraph
mod_graph
unused_pkg_err :: DriverMessages
unused_pkg_err = UnitState -> DynFlags -> ModuleGraph -> DriverMessages
warnUnusedPackages (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
hue) (HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue) ModuleGraph
mod_graph
return $ DriverMessages
errs DriverMessages -> DriverMessages -> DriverMessages
forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unused_home_mod_err
DriverMessages -> DriverMessages -> DriverMessages
forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unused_pkg_err
DriverMessages -> DriverMessages -> DriverMessages
forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unknown_module_err
DriverMessages
all_errs <- IO DriverMessages -> m DriverMessages
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DriverMessages -> m DriverMessages)
-> IO DriverMessages -> m DriverMessages
forall a b. (a -> b) -> a -> b
$ (IO DriverMessages -> UnitId -> HomeUnitEnv -> IO DriverMessages)
-> IO DriverMessages
-> UnitEnvGraph HomeUnitEnv
-> IO DriverMessages
forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey IO DriverMessages -> UnitId -> HomeUnitEnv -> IO DriverMessages
one_unit_messages (DriverMessages -> IO DriverMessages
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DriverMessages
forall e. Messages e
emptyMessages) (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env)
Messages GhcMessage -> m ()
forall (m :: * -> *). GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics (DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage)
-> DriverMessages -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DriverMessages
all_errs)
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph = mod_graph }
pure (DriverMessages
forall e. Messages e
emptyMessages, ModuleGraph
mod_graph)
else do
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph = emptyMG }
pure (DriverMessages
errs, ModuleGraph
emptyMG)
depanalPartial
:: GhcMonad m
=> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalPartial :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let
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
-> SDoc
-> ((DriverMessages, ModuleGraph) -> ())
-> m (DriverMessages, ModuleGraph)
-> m (DriverMessages, ModuleGraph)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Chasing dependencies") (() -> (DriverMessages, ModuleGraph) -> ()
forall a b. a -> b -> a
const ()) (m (DriverMessages, ModuleGraph)
-> m (DriverMessages, ModuleGraph))
-> m (DriverMessages, ModuleGraph)
-> m (DriverMessages, ModuleGraph)
forall a b. (a -> b) -> a -> b
$ do
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Chasing modules from: ",
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ((Target -> SDoc) -> [Target] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Target -> SDoc
pprTarget [Target]
targets))])
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FinderCache -> UnitEnv -> IO ()
flushFinderCaches (HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env) (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
([DriverMessages]
errs, [ModuleGraphNode]
graph_nodes) <- IO ([DriverMessages], [ModuleGraphNode])
-> m ([DriverMessages], [ModuleGraphNode])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([DriverMessages], [ModuleGraphNode])
-> m ([DriverMessages], [ModuleGraphNode]))
-> IO ([DriverMessages], [ModuleGraphNode])
-> m ([DriverMessages], [ModuleGraphNode])
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep
HscEnv
hsc_env (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
old_graph)
[ModuleName]
excluded_mods Bool
allow_dup_roots
let
mod_graph :: ModuleGraph
mod_graph = [ModuleGraphNode] -> ModuleGraph
mkModuleGraph [ModuleGraphNode]
graph_nodes
return ([DriverMessages] -> DriverMessages
forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages [DriverMessages]
errs, ModuleGraph
mod_graph)
instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]
instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]
instantiationNodes UnitId
uid UnitState
unit_state = UnitId -> InstantiatedUnit -> ModuleGraphNode
InstantiationNode UnitId
uid (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
$ ((GenUnit UnitId, Maybe PackageArg) -> [InstantiatedUnit])
-> [(GenUnit UnitId, Maybe PackageArg)] -> [InstantiatedUnit]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GenUnit UnitId -> [InstantiatedUnit]
forall {unit}. GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId (GenUnit UnitId -> [InstantiatedUnit])
-> ((GenUnit UnitId, Maybe PackageArg) -> GenUnit UnitId)
-> (GenUnit UnitId, Maybe PackageArg)
-> [InstantiatedUnit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenUnit UnitId, Maybe PackageArg) -> GenUnit UnitId
forall a b. (a, b) -> a
fst) (UnitState -> [(GenUnit UnitId, Maybe PackageArg)]
explicitUnits UnitState
unit_state)
where
goUnitId :: GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId GenUnit unit
uid =
[ GenInstantiatedUnit unit
recur
| VirtUnit GenInstantiatedUnit unit
indef <- [GenUnit unit
uid]
, (ModuleName, GenModule (GenUnit unit))
inst <- GenInstantiatedUnit unit -> GenInstantiations unit
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit unit
indef
, GenInstantiatedUnit unit
recur <- (GenInstantiatedUnit unit
indef GenInstantiatedUnit unit
-> [GenInstantiatedUnit unit] -> [GenInstantiatedUnit unit]
forall a. a -> [a] -> [a]
:) ([GenInstantiatedUnit unit] -> [GenInstantiatedUnit unit])
-> [GenInstantiatedUnit unit] -> [GenInstantiatedUnit unit]
forall a b. (a -> b) -> a -> b
$ GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId (GenUnit unit -> [GenInstantiatedUnit unit])
-> GenUnit unit -> [GenInstantiatedUnit unit]
forall a b. (a -> b) -> a -> b
$ GenModule (GenUnit unit) -> GenUnit unit
forall unit. GenModule unit -> unit
moduleUnit (GenModule (GenUnit unit) -> GenUnit unit)
-> GenModule (GenUnit unit) -> GenUnit unit
forall a b. (a -> b) -> a -> b
$ (ModuleName, GenModule (GenUnit unit)) -> GenModule (GenUnit unit)
forall a b. (a, b) -> b
snd (ModuleName, GenModule (GenUnit unit))
inst
]
linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
linkNodes :: [ModuleGraphNode]
-> UnitId
-> HomeUnitEnv
-> Maybe (Either DriverMessages ModuleGraphNode)
linkNodes [ModuleGraphNode]
summaries UnitId
uid HomeUnitEnv
hue =
let dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue
ofile :: Maybe FilePath
ofile = DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags
unit_nodes :: [NodeKey]
unit_nodes :: [NodeKey]
unit_nodes = (ModuleGraphNode -> NodeKey) -> [ModuleGraphNode] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey ((ModuleGraphNode -> Bool) -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
uid) (UnitId -> Bool)
-> (ModuleGraphNode -> UnitId) -> ModuleGraphNode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraphNode -> UnitId
moduleGraphNodeUnitId) [ModuleGraphNode]
summaries)
no_hs_main :: Bool
no_hs_main = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags
main_sum :: Bool
main_sum = (NodeKey -> Bool) -> [NodeKey] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (NodeKey -> NodeKey -> Bool
forall a. Eq a => a -> a -> Bool
== ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (DynFlags -> ModuleName
mainModuleNameIs DynFlags
dflags) IsBootInterface
NotBoot) UnitId
uid)) [NodeKey]
unit_nodes
do_linking :: Bool
do_linking = Bool
main_sum Bool -> Bool -> Bool
|| Bool
no_hs_main Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkDynLib Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkStaticLib
in if | DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkBinary Bool -> Bool -> Bool
&& Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust Maybe FilePath
ofile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
do_linking ->
Either DriverMessages ModuleGraphNode
-> Maybe (Either DriverMessages ModuleGraphNode)
forall a. a -> Maybe a
Just (DriverMessages -> Either DriverMessages ModuleGraphNode
forall a b. a -> Either a b
Left (DriverMessages -> Either DriverMessages ModuleGraphNode)
-> DriverMessages -> Either DriverMessages ModuleGraphNode
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (ModuleName -> DriverMessage
DriverRedirectedNoMain (ModuleName -> DriverMessage) -> ModuleName -> DriverMessage
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName
mainModuleNameIs DynFlags
dflags))
| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
/= GhcLink
NoLink, Bool
do_linking -> Either DriverMessages ModuleGraphNode
-> Maybe (Either DriverMessages ModuleGraphNode)
forall a. a -> Maybe a
Just (ModuleGraphNode -> Either DriverMessages ModuleGraphNode
forall a b. b -> Either a b
Right ([NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
unit_nodes UnitId
uid))
| Bool
otherwise -> Maybe (Either DriverMessages ModuleGraphNode)
forall a. Maybe a
Nothing
warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages
warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages
warnMissingHomeModules DynFlags
dflags [Target]
targets ModuleGraph
mod_graph =
if [ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
missing
then DriverMessages
forall e. Messages e
emptyMessages
else DriverMessages
warn
where
diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
is_known_module :: ModSummary -> Bool
is_known_module ModSummary
mod = (Target -> Bool) -> [Target] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ModSummary -> Target -> Bool
is_my_target ModSummary
mod) [Target]
targets
is_my_target :: ModSummary -> Target -> Bool
is_my_target ModSummary
mod Target
target =
let tuid :: UnitId
tuid = Target -> UnitId
targetUnitId Target
target
in case Target -> TargetId
targetId Target
target of
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
Bool -> Bool -> Bool
&& UnitId
tuid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> UnitId
ms_unitid ModSummary
mod
TargetFile FilePath
target_file Maybe Phase
_
| Just FilePath
mod_file <- ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod)
->
DynFlags -> FilePath -> FilePath
augmentByWorkingDirectory DynFlags
dflags FilePath
target_file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
mod_file Bool -> Bool -> Bool
||
FilePath -> FilePath
addBootSuffix FilePath
target_file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
mod_file Bool -> Bool -> Bool
||
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)
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) ([ModSummary] -> [ModSummary]) -> [ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$
((ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> ModSummary -> UnitId
ms_unitid ModSummary
ms UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
(ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph))
warn :: DriverMessages
warn = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan
(DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ UnitId -> [ModuleName] -> BuildingCabalPackage -> DriverMessage
DriverMissingHomeModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) [ModuleName]
missing (DynFlags -> BuildingCabalPackage
checkBuildingCabalPackage DynFlags
dflags)
warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
warnUnknownModules HscEnv
hsc_env DynFlags
dflags ModuleGraph
mod_graph = do
[ModuleName]
reexported_warns <- (ModuleName -> IO Bool) -> [ModuleName] -> IO [ModuleName]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ModuleName -> IO Bool
check_reexport (Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
reexported_mods)
return $ Set ModuleName -> [ModuleName] -> DriverMessages
final_msgs Set ModuleName
hidden_warns [ModuleName]
reexported_warns
where
diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
unit_mods :: Set ModuleName
unit_mods = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name
((ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> ModSummary -> UnitId
ms_unitid ModSummary
ms UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
(ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)))
reexported_mods :: Set ModuleName
reexported_mods = DynFlags -> Set ModuleName
reexportedModules DynFlags
dflags
hidden_mods :: Set ModuleName
hidden_mods = DynFlags -> Set ModuleName
hiddenModules DynFlags
dflags
hidden_warns :: Set ModuleName
hidden_warns = Set ModuleName
hidden_mods Set ModuleName -> Set ModuleName -> Set ModuleName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ModuleName
unit_mods
lookupModule :: ModuleName -> IO FindResult
lookupModule ModuleName
mn = HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mn PkgQual
NoPkgQual
check_reexport :: ModuleName -> IO Bool
check_reexport ModuleName
mn = do
FindResult
fr <- ModuleName -> IO FindResult
lookupModule ModuleName
mn
case FindResult
fr of
Found ModLocation
_ Module
m -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> UnitId
moduleUnitId Module
m UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
FindResult
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
warn :: DriverMessage -> DriverMessages
warn DriverMessage
diagnostic = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan
(DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage
diagnostic
final_msgs :: Set ModuleName -> [ModuleName] -> DriverMessages
final_msgs Set ModuleName
hidden_warns [ModuleName]
reexported_warns
=
[DriverMessages] -> DriverMessages
forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages ([DriverMessages] -> DriverMessages)
-> [DriverMessages] -> DriverMessages
forall a b. (a -> b) -> a -> b
$
[DriverMessage -> DriverMessages
warn (UnitId -> [ModuleName] -> DriverMessage
DriverUnknownHiddenModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) (Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
hidden_warns)) | Bool -> Bool
not (Set ModuleName -> Bool
forall a. Set a -> Bool
Set.null Set ModuleName
hidden_warns)]
[DriverMessages] -> [DriverMessages] -> [DriverMessages]
forall a. [a] -> [a] -> [a]
++ [DriverMessage -> DriverMessages
warn (UnitId -> [ModuleName] -> DriverMessage
DriverUnknownReexportedModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) [ModuleName]
reexported_warns) | Bool -> Bool
not ([ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
reexported_warns)]
data LoadHowMuch
= LoadAllTargets
| LoadUpTo HomeUnitModule
| LoadDependenciesOf HomeUnitModule
data ModIfaceCache = ModIfaceCache { ModIfaceCache -> IO [CachedIface]
iface_clearCache :: IO [CachedIface]
, ModIfaceCache -> CachedIface -> IO ()
iface_addToCache :: CachedIface -> IO () }
addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()
addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()
addHmiToCache ModIfaceCache
c (HomeModInfo ModIface
i ModDetails
_ HomeModLinkable
l) = ModIfaceCache -> CachedIface -> IO ()
iface_addToCache ModIfaceCache
c (ModIface -> HomeModLinkable -> CachedIface
CachedIface ModIface
i HomeModLinkable
l)
data CachedIface = CachedIface { CachedIface -> ModIface
cached_modiface :: !ModIface
, CachedIface -> HomeModLinkable
cached_linkable :: !HomeModLinkable }
instance Outputable CachedIface where
ppr :: CachedIface -> SDoc
ppr (CachedIface ModIface
mi HomeModLinkable
ln) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"CachedIface", ModNodeKeyWithUid -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModIface -> ModNodeKeyWithUid
miKey ModIface
mi), HomeModLinkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr HomeModLinkable
ln]
noIfaceCache :: Maybe ModIfaceCache
noIfaceCache :: Maybe ModIfaceCache
noIfaceCache = Maybe ModIfaceCache
forall a. Maybe a
Nothing
newIfaceCache :: IO ModIfaceCache
newIfaceCache :: IO ModIfaceCache
newIfaceCache = do
IORef [CachedIface]
ioref <- [CachedIface] -> IO (IORef [CachedIface])
forall a. a -> IO (IORef a)
newIORef []
return $
ModIfaceCache
{ iface_clearCache :: IO [CachedIface]
iface_clearCache = IORef [CachedIface]
-> ([CachedIface] -> ([CachedIface], [CachedIface]))
-> IO [CachedIface]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [CachedIface]
ioref (\[CachedIface]
c -> ([], [CachedIface]
c))
, iface_addToCache :: CachedIface -> IO ()
iface_addToCache = \CachedIface
hmi -> IORef [CachedIface]
-> ([CachedIface] -> ([CachedIface], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [CachedIface]
ioref (\[CachedIface]
c -> (CachedIface
hmiCachedIface -> [CachedIface] -> [CachedIface]
forall a. a -> [a] -> [a]
:[CachedIface]
c, ()))
}
load :: GhcMonad f => LoadHowMuch -> f SuccessFlag
load :: forall (f :: * -> *). GhcMonad f => LoadHowMuch -> f SuccessFlag
load LoadHowMuch
how_much = Maybe ModIfaceCache -> LoadHowMuch -> f SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
loadWithCache Maybe ModIfaceCache
noIfaceCache LoadHowMuch
how_much
mkBatchMsg :: HscEnv -> Messager
mkBatchMsg :: HscEnv -> Messager
mkBatchMsg HscEnv
hsc_env =
if Set UnitId -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
then Messager
batchMultiMsg
else Messager
batchMsg
loadWithCache :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
loadWithCache :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
loadWithCache Maybe ModIfaceCache
cache LoadHowMuch
how_much = do
(DriverMessages
errs, ModuleGraph
mod_graph) <- [ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalE [] Bool
False
Messager
msg <- HscEnv -> Messager
mkBatchMsg (HscEnv -> Messager) -> m HscEnv -> m Messager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
SuccessFlag
success <- Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' Maybe ModIfaceCache
cache LoadHowMuch
how_much (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
msg) ModuleGraph
mod_graph
if DriverMessages -> Bool
forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
then SuccessFlag -> m SuccessFlag
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
success
else Messages GhcMessage -> m SuccessFlag
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors ((DriverMessage -> GhcMessage)
-> DriverMessages -> Messages GhcMessage
forall a b. (a -> b) -> Messages a -> Messages b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage DriverMessages
errs)
warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
warnUnusedPackages UnitState
us DynFlags
dflags ModuleGraph
mod_graph =
let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
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
$
((PkgQual, GenLocated SrcSpan ModuleName) -> Maybe [UnitInfo])
-> [(PkgQual, GenLocated SrcSpan ModuleName)] -> [[UnitInfo]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(PkgQual
fs, GenLocated SrcSpan ModuleName
mn) -> UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
lookupModulePackage UnitState
us (GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
mn) PkgQual
fs)
([(PkgQual, GenLocated SrcSpan ModuleName)] -> [[UnitInfo]])
-> [(PkgQual, GenLocated SrcSpan ModuleName)] -> [[UnitInfo]]
forall a b. (a -> b) -> a -> b
$ (ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)])
-> [ModSummary] -> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_imps (
(ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> DynFlags -> UnitId
homeUnitId_ DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> UnitId
ms_unitid ModSummary
ms) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph))
used_args :: Set UnitId
used_args = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ([UnitId] -> Set UnitId) -> [UnitId] -> Set UnitId
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
loadedPackages
resolve :: (GenUnit UnitId, Maybe PackageArg)
-> Maybe (UnitId, PackageName, Version, PackageArg)
resolve (GenUnit UnitId
u,Maybe PackageArg
mflag) = do
PackageArg
flag <- Maybe PackageArg
mflag
UnitInfo
ui <- UnitState -> GenUnit UnitId -> Maybe UnitInfo
lookupUnit UnitState
us GenUnit UnitId
u
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui) Set UnitId
used_args)
return (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui, UnitInfo -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
ui, UnitInfo -> Version
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Version
unitPackageVersion UnitInfo
ui, PackageArg
flag)
unusedArgs :: [(UnitId, PackageName, Version, PackageArg)]
unusedArgs = ((GenUnit UnitId, Maybe PackageArg)
-> Maybe (UnitId, PackageName, Version, PackageArg))
-> [(GenUnit UnitId, Maybe PackageArg)]
-> [(UnitId, PackageName, Version, PackageArg)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (GenUnit UnitId, Maybe PackageArg)
-> Maybe (UnitId, PackageName, Version, PackageArg)
resolve (UnitState -> [(GenUnit UnitId, Maybe PackageArg)]
explicitUnits UnitState
us)
warn :: DriverMessages
warn = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan ([(UnitId, PackageName, Version, PackageArg)] -> DriverMessage
DriverUnusedPackages [(UnitId, PackageName, Version, PackageArg)]
unusedArgs)
in if [(UnitId, PackageName, Version, PackageArg)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UnitId, PackageName, Version, PackageArg)]
unusedArgs
then DriverMessages
forall e. Messages e
emptyMessages
else DriverMessages
warn
data ModuleGraphNodeWithBootFile
= ModuleGraphNodeWithBootFile
ModuleGraphNode
[NodeKey]
instance Outputable ModuleGraphNodeWithBootFile where
ppr :: ModuleGraphNodeWithBootFile -> SDoc
ppr (ModuleGraphNodeWithBootFile ModuleGraphNode
mgn [NodeKey]
deps) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"ModeGraphNodeWithBootFile: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleGraphNode -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleGraphNode
mgn SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [NodeKey] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [NodeKey]
deps
data BuildPlan
= SingleModule ModuleGraphNode
| ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
| UnresolvedCycle [ModuleGraphNode]
instance Outputable BuildPlan where
ppr :: BuildPlan -> SDoc
ppr (SingleModule ModuleGraphNode
mgn) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"SingleModule" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (ModuleGraphNode -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleGraphNode
mgn)
ppr (ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mgn) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"ResolvedCycle:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mgn
ppr (UnresolvedCycle [ModuleGraphNode]
mgn) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"UnresolvedCycle:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ModuleGraphNode] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleGraphNode]
mgn
countMods :: BuildPlan -> Int
countMods :: BuildPlan -> Int
countMods (SingleModule ModuleGraphNode
_) = Int
1
countMods (ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ns) = [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ns
countMods (UnresolvedCycle [ModuleGraphNode]
ns) = [ModuleGraphNode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleGraphNode]
ns
createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
createBuildPlan ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod =
let
cycle_mod_graph :: [SCC ModuleGraphNode]
cycle_mod_graph = Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
True ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod
build_plan :: [BuildPlan]
build_plan :: [BuildPlan]
build_plan
| ModuleEnv (ModuleGraphNode, [ModuleGraphNode]) -> Bool
forall a. ModuleEnv a -> Bool
isEmptyModuleEnv ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules = [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic ([SCC ModuleGraphNode] -> [BuildPlan])
-> [SCC ModuleGraphNode] -> [BuildPlan]
forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
False ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod
| Bool
otherwise = [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [SCC ModuleGraphNode]
cycle_mod_graph []
toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [] [ModuleGraphNode]
mgn = [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic ([ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
mgn)
toBuildPlan ((AcyclicSCC ModuleGraphNode
node):[SCC ModuleGraphNode]
sccs) [ModuleGraphNode]
mgn = [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [SCC ModuleGraphNode]
sccs (ModuleGraphNode
nodeModuleGraphNode -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. a -> [a] -> [a]
:[ModuleGraphNode]
mgn)
toBuildPlan ((CyclicSCC [ModuleGraphNode]
nodes):[SCC ModuleGraphNode]
sccs) [ModuleGraphNode]
mgn =
let acyclic :: [BuildPlan]
acyclic = [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic ([ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
mgn)
mresolved_cycle :: Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mresolved_cycle = [SCC ModuleGraphNode]
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC ([ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
nodes)
in [BuildPlan]
acyclic [BuildPlan] -> [BuildPlan] -> [BuildPlan]
forall a. [a] -> [a] -> [a]
++ [BuildPlan
-> ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> BuildPlan)
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> BuildPlan
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([ModuleGraphNode] -> BuildPlan
UnresolvedCycle [ModuleGraphNode]
nodes) [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildPlan
ResolvedCycle Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mresolved_cycle] [BuildPlan] -> [BuildPlan] -> [BuildPlan]
forall a. [a] -> [a] -> [a]
++ [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [SCC ModuleGraphNode]
sccs []
(Graph SummaryNode
mg, NodeKey -> Maybe SummaryNode
lookup_node) = Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
False (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph)
trans_deps_map :: Map NodeKey (Set NodeKey)
trans_deps_map = Graph SummaryNode
-> (SummaryNode -> NodeKey) -> Map NodeKey (Set NodeKey)
forall key node.
Ord key =>
Graph node -> (node -> key) -> Map key (Set key)
allReachable Graph SummaryNode
mg (ModuleGraphNode -> NodeKey
mkNodeKey (ModuleGraphNode -> NodeKey)
-> (SummaryNode -> ModuleGraphNode) -> SummaryNode -> NodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SummaryNode -> ModuleGraphNode
forall key payload. Node key payload -> payload
node_payload)
boot_path :: ModuleName -> UnitId -> [ModuleGraphNode]
boot_path ModuleName
mn UnitId
uid =
(NodeKey -> ModuleGraphNode) -> [NodeKey] -> [ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
map (SummaryNode -> ModuleGraphNode
summaryNodeSummary (SummaryNode -> ModuleGraphNode)
-> (NodeKey -> SummaryNode) -> NodeKey -> ModuleGraphNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe SummaryNode -> SummaryNode
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"toNode" (Maybe SummaryNode -> SummaryNode)
-> (NodeKey -> Maybe SummaryNode) -> NodeKey -> SummaryNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> Maybe SummaryNode
lookup_node) ([NodeKey] -> [ModuleGraphNode]) -> [NodeKey] -> [ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
Set.toList (Set NodeKey -> [NodeKey]) -> Set NodeKey -> [NodeKey]
forall a b. (a -> b) -> a -> b
$
NodeKey -> Set NodeKey -> Set NodeKey
forall a. Ord a => a -> Set a -> Set a
Set.delete (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
IsBoot)) (Set NodeKey -> Set NodeKey) -> Set NodeKey -> Set NodeKey
forall a b. (a -> b) -> a -> b
$
(NodeKey -> Bool) -> Set NodeKey -> Set NodeKey
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\NodeKey
nk -> NodeKey -> UnitId
nodeKeyUnitId NodeKey
nk UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
uid
Bool -> Bool -> Bool
&& (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
IsBoot)) NodeKey -> Set NodeKey -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` FilePath -> Maybe (Set NodeKey) -> Set NodeKey
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"dep_on_boot" (NodeKey -> Map NodeKey (Set NodeKey) -> Maybe (Set NodeKey)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeKey
nk Map NodeKey (Set NodeKey)
trans_deps_map)) (Set NodeKey -> Set NodeKey) -> Set NodeKey -> Set NodeKey
forall a b. (a -> b) -> a -> b
$
FilePath -> Maybe (Set NodeKey) -> Set NodeKey
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"not_boot_dep" (NodeKey -> Map NodeKey (Set NodeKey) -> Maybe (Set NodeKey)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
NotBoot)) Map NodeKey (Set NodeKey)
trans_deps_map)
where
key :: IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
ib = ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mn IsBootInterface
ib) UnitId
uid
boot_modules :: ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules = [(Module, (ModuleGraphNode, [ModuleGraphNode]))]
-> ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv
[ (ModSummary -> Module
ms_mod ModSummary
ms, (ModuleGraphNode
m, ModuleName -> UnitId -> [ModuleGraphNode]
boot_path (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) (ModSummary -> UnitId
ms_unitid ModSummary
ms))) | m :: ModuleGraphNode
m@(ModuleNode [NodeKey]
_ ModSummary
ms) <- (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph), ModSummary -> IsBootInterface
isBootSummary ModSummary
ms IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot]
select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules = (ModuleGraphNode -> Maybe ModuleGraphNode)
-> [ModuleGraphNode] -> [ModuleGraphNode]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((ModuleGraphNode, [ModuleGraphNode]) -> ModuleGraphNode)
-> Maybe (ModuleGraphNode, [ModuleGraphNode])
-> Maybe ModuleGraphNode
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModuleGraphNode, [ModuleGraphNode]) -> ModuleGraphNode
forall a b. (a, b) -> a
fst (Maybe (ModuleGraphNode, [ModuleGraphNode])
-> Maybe ModuleGraphNode)
-> (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]))
-> ModuleGraphNode
-> Maybe ModuleGraphNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
get_boot_module)
get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
get_boot_module ModuleGraphNode
m = case ModuleGraphNode
m of ModuleNode [NodeKey]
_ ModSummary
ms | HscSource
HsSrcFile <- ModSummary -> HscSource
ms_hsc_src ModSummary
ms -> ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
-> Module -> Maybe (ModuleGraphNode, [ModuleGraphNode])
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules (ModSummary -> Module
ms_mod ModSummary
ms); ModuleGraphNode
_ -> Maybe (ModuleGraphNode, [ModuleGraphNode])
forall a. Maybe a
Nothing
collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]
collapseSCC :: [SCC ModuleGraphNode]
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC [AcyclicSCC ModuleGraphNode
node1, AcyclicSCC ModuleGraphNode
node2] = [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a. a -> Maybe a
Just [ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node1, ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node2]
collapseSCC (AcyclicSCC ModuleGraphNode
node : [SCC ModuleGraphNode]
nodes) = (ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a. a -> [a] -> [a]
:) ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile])
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SCC ModuleGraphNode]
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC [SCC ModuleGraphNode]
nodes
collapseSCC [SCC ModuleGraphNode]
_ = Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a. Maybe a
Nothing
toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot :: ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
mn =
case ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
get_boot_module ModuleGraphNode
mn of
Maybe (ModuleGraphNode, [ModuleGraphNode])
Nothing -> ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
forall a b. a -> Either a b
Left ModuleGraphNode
mn
Just (ModuleGraphNode, [ModuleGraphNode])
path -> ModuleGraphNodeWithBootFile
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
forall a b. b -> Either a b
Right (ModuleGraphNode -> [NodeKey] -> ModuleGraphNodeWithBootFile
ModuleGraphNodeWithBootFile ModuleGraphNode
mn ((ModuleGraphNode -> NodeKey) -> [ModuleGraphNode] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey ((ModuleGraphNode, [ModuleGraphNode]) -> [ModuleGraphNode]
forall a b. (a, b) -> b
snd (ModuleGraphNode, [ModuleGraphNode])
path)))
collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic (AcyclicSCC ModuleGraphNode
node : [SCC ModuleGraphNode]
nodes) = ModuleGraphNode -> BuildPlan
SingleModule ModuleGraphNode
node BuildPlan -> [BuildPlan] -> [BuildPlan]
forall a. a -> [a] -> [a]
: [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic [SCC ModuleGraphNode]
nodes
collapseAcyclic (CyclicSCC [ModuleGraphNode]
cy_nodes : [SCC ModuleGraphNode]
nodes) = ([ModuleGraphNode] -> BuildPlan
UnresolvedCycle [ModuleGraphNode]
cy_nodes) BuildPlan -> [BuildPlan] -> [BuildPlan]
forall a. a -> [a] -> [a]
: [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic [SCC ModuleGraphNode]
nodes
collapseAcyclic [] = []
topSortWithBoot :: [ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
nodes = Bool
-> [ModuleGraphNode]
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModules Bool
False ([ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules [ModuleGraphNode]
nodes [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
nodes) Maybe HomeUnitModule
forall a. Maybe a
Nothing
in
Bool -> SDoc -> [BuildPlan] -> [BuildPlan]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BuildPlan -> Int) -> [BuildPlan] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
build_plan) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ModuleGraphNode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph))
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Build plan missing nodes:", (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"PLAN:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BuildPlan -> Int) -> [BuildPlan] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
build_plan))), (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"GRAPH:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([ModuleGraphNode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph )))])
[BuildPlan]
build_plan
load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' Maybe ModIfaceCache
mhmi_cache LoadHowMuch
how_much Maybe Messager
mHscMessage ModuleGraph
mod_graph = do
m ()
forall (m :: * -> *). GhcMonad m => m ()
initializeSessionPlugins
(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 = mod_graph }
m ()
forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
let all_home_mods :: Set HomeUnitModule
all_home_mods =
[HomeUnitModule] -> Set HomeUnitModule
forall a. Ord a => [a] -> Set a
Set.fromList [ UnitId -> ModuleName -> HomeUnitModule
forall unit. unit -> ModuleName -> GenModule unit
Module (ModSummary -> UnitId
ms_unitid ModSummary
s) (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]
let checkHowMuch :: LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch (LoadUpTo HomeUnitModule
m) = HomeUnitModule -> m SuccessFlag -> m SuccessFlag
checkMod HomeUnitModule
m
checkHowMuch (LoadDependenciesOf HomeUnitModule
m) = HomeUnitModule -> m SuccessFlag -> m SuccessFlag
checkMod HomeUnitModule
m
checkHowMuch LoadHowMuch
_ = m SuccessFlag -> m SuccessFlag
forall a. a -> a
id
checkMod :: HomeUnitModule -> m SuccessFlag -> m SuccessFlag
checkMod HomeUnitModule
m m SuccessFlag
and_then
| HomeUnitModule
m HomeUnitModule -> Set HomeUnitModule -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set HomeUnitModule
all_home_mods = m SuccessFlag
and_then
| Bool
otherwise = do
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
errorMsg Logger
logger
(FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"no such module:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HomeUnitModule -> UnitId
forall unit. GenModule unit -> unit
moduleUnit HomeUnitModule
m) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HomeUnitModule -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName HomeUnitModule
m)))
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
let mg2_with_srcimps :: [SCC ModuleGraphNode]
mg2_with_srcimps :: [SCC ModuleGraphNode]
mg2_with_srcimps = Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
True ModuleGraph
mod_graph Maybe HomeUnitModule
forall a. Maybe a
Nothing
[SCC ModSummary] -> m ()
forall (m :: * -> *). GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports ([SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules [SCC ModuleGraphNode]
mg2_with_srcimps)
let maybe_top_mod :: Maybe HomeUnitModule
maybe_top_mod = case LoadHowMuch
how_much of
LoadUpTo HomeUnitModule
m -> HomeUnitModule -> Maybe HomeUnitModule
forall a. a -> Maybe a
Just HomeUnitModule
m
LoadDependenciesOf HomeUnitModule
m -> HomeUnitModule -> Maybe HomeUnitModule
forall a. a -> Maybe a
Just HomeUnitModule
m
LoadHowMuch
_ -> Maybe HomeUnitModule
forall a. Maybe a
Nothing
build_plan :: [BuildPlan]
build_plan = ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
createBuildPlan ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod
[CachedIface]
cache <- IO [CachedIface] -> m [CachedIface]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CachedIface] -> m [CachedIface])
-> IO [CachedIface] -> m [CachedIface]
forall a b. (a -> b) -> a -> b
$ IO [CachedIface]
-> (ModIfaceCache -> IO [CachedIface])
-> Maybe ModIfaceCache
-> IO [CachedIface]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([CachedIface] -> IO [CachedIface]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []) ModIfaceCache -> IO [CachedIface]
iface_clearCache Maybe ModIfaceCache
mhmi_cache
let
!pruned_cache :: [HomeModInfo]
pruned_cache = [CachedIface] -> [ModSummary] -> [HomeModInfo]
pruneCache [CachedIface]
cache
([SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
flattenSCCs ([SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules [SCC ModuleGraphNode]
mg2_with_srcimps))
let pruneHomeUnitEnv :: HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv HomeUnitEnv
hme = HomeUnitEnv
hme { homeUnitEnv_hpt = emptyHomePackageTable }
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
$ (UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> HscEnv -> HscEnv
hscUpdateHUG ((HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv) HscEnv
hsc_env
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> IO ()
unload Interp
interp HscEnv
hsc_env
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Ready for upsweep")
Int
2 ([BuildPlan] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [BuildPlan]
build_plan))
Int
n_jobs <- case DynFlags -> Maybe Int
parMakeCount (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) of
Maybe Int
Nothing -> IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
Just Int
n -> Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> m ()) -> HscEnv -> m ()
forall a b. (a -> b) -> a -> b
$ (UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> HscEnv -> HscEnv
hscUpdateHUG ((HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv) HscEnv
hsc_env
(SuccessFlag
upsweep_ok, [HomeModInfo]
new_deps) <- m (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo])
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics (m (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo]))
-> m (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo])
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
IO (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo]))
-> IO (SuccessFlag, [HomeModInfo])
-> m (SuccessFlag, [HomeModInfo])
forall a b. (a -> b) -> a -> b
$ Int
-> HscEnv
-> Maybe ModIfaceCache
-> Maybe Messager
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, [HomeModInfo])
upsweep Int
n_jobs HscEnv
hsc_env Maybe ModIfaceCache
mhmi_cache Maybe Messager
mHscMessage ([HomeModInfo] -> Map ModNodeKeyWithUid HomeModInfo
toCache [HomeModInfo]
pruned_cache) [BuildPlan]
build_plan
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ([HomeModInfo] -> HscEnv -> HscEnv
addDepsToHscEnv [HomeModInfo]
new_deps)
case SuccessFlag
upsweep_ok of
SuccessFlag
Failed -> SuccessFlag -> m SuccessFlag
forall (m :: * -> *). GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
upsweep_ok
SuccessFlag
Succeeded -> do
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Upsweep completely successful.")
SuccessFlag -> m SuccessFlag
forall (m :: * -> *). GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
upsweep_ok
loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish :: forall (m :: * -> *). GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
all_ok
= do (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardIC
return SuccessFlag
all_ok
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 !mod_graph :: ModuleGraph
mod_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
env
new_home_graph :: UnitEnvGraph HomeUnitEnv
new_home_graph =
((HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> (HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
env) ((HomeUnitEnv -> HomeUnitEnv) -> UnitEnvGraph HomeUnitEnv)
-> (HomeUnitEnv -> HomeUnitEnv) -> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b) -> a -> b
$ \HomeUnitEnv
hue ->
let dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
mainModuleSrcPath :: Maybe String
mainModuleSrcPath :: Maybe FilePath
mainModuleSrcPath = do
ModSummary
ms <- ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph
mod_graph (HomeUnitEnv -> Module
mainModIs HomeUnitEnv
hue)
ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
name :: Maybe FilePath
name = (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
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
!FilePath
name' <- case Platform -> ArchOS
platformArchOS Platform
platform of
ArchOS Arch
_ OS
OSMinGW32 -> (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> FilePath
<.> FilePath
"exe") Maybe FilePath
name
ArchOS Arch
ArchWasm32 OS
_ -> (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> FilePath
<.> FilePath
"wasm") Maybe FilePath
name
ArchOS
_ -> Maybe FilePath
name
FilePath
mainModuleSrcPath' <- Maybe FilePath
mainModuleSrcPath
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
_ -> HomeUnitEnv
hue
Maybe FilePath
Nothing -> HomeUnitEnv
hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }
in HscEnv
env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }
pruneCache :: [CachedIface]
-> [ModSummary]
-> [HomeModInfo]
pruneCache :: [CachedIface] -> [ModSummary] -> [HomeModInfo]
pruneCache [CachedIface]
hpt [ModSummary]
summ
= (CachedIface -> HomeModInfo) -> [CachedIface] -> [HomeModInfo]
forall a b. (a -> b) -> [a] -> [b]
strictMap CachedIface -> HomeModInfo
prune [CachedIface]
hpt
where prune :: CachedIface -> HomeModInfo
prune (CachedIface { cached_modiface :: CachedIface -> ModIface
cached_modiface = ModIface
iface
, cached_linkable :: CachedIface -> HomeModLinkable
cached_linkable = HomeModLinkable
linkable
}) = ModIface -> ModDetails -> HomeModLinkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
emptyModDetails HomeModLinkable
linkable'
where
modl :: ModNodeKeyWithUid
modl = ModIface -> ModNodeKeyWithUid
miKey ModIface
iface
linkable' :: HomeModLinkable
linkable'
| Just ModSummary
ms <- ModNodeKeyWithUid
-> Map ModNodeKeyWithUid ModSummary -> Maybe ModSummary
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModNodeKeyWithUid
modl Map ModNodeKeyWithUid ModSummary
ms_map
, ModIface -> Fingerprint
forall (phase :: ModIfacePhase). ModIface_ phase -> Fingerprint
mi_src_hash ModIface
iface Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= ModSummary -> Fingerprint
ms_hs_hash ModSummary
ms
= HomeModLinkable
emptyHomeModInfoLinkable
| Bool
otherwise
= HomeModLinkable
linkable
ms_map :: Map ModNodeKeyWithUid ModSummary
ms_map = (ModSummary -> ModSummary -> ModSummary)
-> [(ModNodeKeyWithUid, ModSummary)]
-> Map ModNodeKeyWithUid ModSummary
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith
(\ModSummary
ms1 ModSummary
ms2 -> Bool -> SDoc -> ModSummary -> ModSummary
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
False (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"prune_cache" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ (ModSummary -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModSummary
ms1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModSummary -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModSummary
ms2))
ModSummary
ms2)
[(ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms, ModSummary
ms) | ModSummary
ms <- [ModSummary]
summ]
unload :: Interp -> HscEnv -> IO ()
unload :: Interp -> HscEnv -> IO ()
unload Interp
interp HscEnv
hsc_env
= 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 []
GhcLink
_other -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))
deriving instance Functor ResultVar
mkResultVar :: MVar (Maybe a) -> ResultVar a
mkResultVar :: forall a. MVar (Maybe a) -> ResultVar a
mkResultVar = (a -> a) -> MVar (Maybe a) -> ResultVar a
forall b a. (a -> b) -> MVar (Maybe a) -> ResultVar b
ResultVar a -> a
forall a. a -> a
id
waitResult :: ResultVar a -> MaybeT IO a
waitResult :: forall a. ResultVar a -> MaybeT IO a
waitResult (ResultVar a -> a
f MVar (Maybe a)
var) = IO (Maybe a) -> MaybeT IO a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ((a -> a) -> Maybe a -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f (Maybe a -> Maybe a) -> IO (Maybe a) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Maybe a) -> IO (Maybe a)
forall a. MVar a -> IO a
readMVar MVar (Maybe a)
var)
data BuildResult = BuildResult { BuildResult -> ResultOrigin
_resultOrigin :: ResultOrigin
, BuildResult -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
resultVar :: ResultVar (Maybe HomeModInfo, ModuleNameSet)
}
data ResultOrigin = NoLoop | Loop ResultLoopOrigin deriving (Int -> ResultOrigin -> FilePath -> FilePath
[ResultOrigin] -> FilePath -> FilePath
ResultOrigin -> FilePath
(Int -> ResultOrigin -> FilePath -> FilePath)
-> (ResultOrigin -> FilePath)
-> ([ResultOrigin] -> FilePath -> FilePath)
-> Show ResultOrigin
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ResultOrigin -> FilePath -> FilePath
showsPrec :: Int -> ResultOrigin -> FilePath -> FilePath
$cshow :: ResultOrigin -> FilePath
show :: ResultOrigin -> FilePath
$cshowList :: [ResultOrigin] -> FilePath -> FilePath
showList :: [ResultOrigin] -> FilePath -> FilePath
Show)
data ResultLoopOrigin = Initialise | Rehydrated | Finalised deriving (Int -> ResultLoopOrigin -> FilePath -> FilePath
[ResultLoopOrigin] -> FilePath -> FilePath
ResultLoopOrigin -> FilePath
(Int -> ResultLoopOrigin -> FilePath -> FilePath)
-> (ResultLoopOrigin -> FilePath)
-> ([ResultLoopOrigin] -> FilePath -> FilePath)
-> Show ResultLoopOrigin
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ResultLoopOrigin -> FilePath -> FilePath
showsPrec :: Int -> ResultLoopOrigin -> FilePath -> FilePath
$cshow :: ResultLoopOrigin -> FilePath
show :: ResultLoopOrigin -> FilePath
$cshowList :: [ResultLoopOrigin] -> FilePath -> FilePath
showList :: [ResultLoopOrigin] -> FilePath -> FilePath
Show)
mkBuildResult :: ResultOrigin -> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult :: ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult = ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
BuildResult
data BuildLoopState = BuildLoopState { BuildLoopState -> Map NodeKey BuildResult
buildDep :: M.Map NodeKey BuildResult
, BuildLoopState -> Int
nNODE :: Int
, BuildLoopState -> MVar (UnitEnvGraph HomeUnitEnv)
hug_var :: MVar HomeUnitGraph
}
nodeId :: BuildM Int
nodeId :: BuildM Int
nodeId = do
Int
n <- (BuildLoopState -> Int) -> BuildM Int
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> Int
nNODE
(BuildLoopState -> BuildLoopState) -> StateT BuildLoopState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\BuildLoopState
m -> BuildLoopState
m { nNODE = n + 1 })
return Int
n
setModulePipeline :: NodeKey -> BuildResult -> BuildM ()
setModulePipeline :: NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline NodeKey
mgn BuildResult
build_result = do
(BuildLoopState -> BuildLoopState) -> StateT BuildLoopState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\BuildLoopState
m -> BuildLoopState
m { buildDep = M.insert mgn build_result (buildDep m) })
type BuildMap = M.Map NodeKey BuildResult
getBuildMap :: BuildM BuildMap
getBuildMap :: BuildM (Map NodeKey BuildResult)
getBuildMap = (BuildLoopState -> Map NodeKey BuildResult)
-> BuildM (Map NodeKey BuildResult)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> Map NodeKey BuildResult
buildDep
getDependencies :: [NodeKey] -> BuildMap -> [BuildResult]
getDependencies :: [NodeKey] -> Map NodeKey BuildResult -> [BuildResult]
getDependencies [NodeKey]
direct_deps Map NodeKey BuildResult
build_map =
(NodeKey -> BuildResult) -> [NodeKey] -> [BuildResult]
forall a b. (a -> b) -> [a] -> [b]
strictMap (FilePath -> Maybe BuildResult -> BuildResult
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"dep_map" (Maybe BuildResult -> BuildResult)
-> (NodeKey -> Maybe BuildResult) -> NodeKey -> BuildResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeKey -> Map NodeKey BuildResult -> Maybe BuildResult)
-> Map NodeKey BuildResult -> NodeKey -> Maybe BuildResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip NodeKey -> Map NodeKey BuildResult -> Maybe BuildResult
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map NodeKey BuildResult
build_map) [NodeKey]
direct_deps
type BuildM a = StateT BuildLoopState IO a
data AbstractSem = AbstractSem { AbstractSem -> IO ()
acquireSem :: IO ()
, AbstractSem -> IO ()
releaseSem :: IO () }
withAbstractSem :: AbstractSem -> IO b -> IO b
withAbstractSem :: forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
sem = IO () -> IO () -> IO b -> IO b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
MC.bracket_ (AbstractSem -> IO ()
acquireSem AbstractSem
sem) (AbstractSem -> IO ()
releaseSem AbstractSem
sem)
data MakeEnv = MakeEnv { MakeEnv -> HscEnv
hsc_env :: !HscEnv
, MakeEnv -> AbstractSem
compile_sem :: !AbstractSem
, MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a
, MakeEnv -> Maybe Messager
env_messager :: !(Maybe Messager)
}
type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a
interpretBuildPlan :: HomeUnitGraph
-> Maybe ModIfaceCache
-> M.Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO ( Maybe [ModuleGraphNode]
, [MakeAction]
, IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan :: UnitEnvGraph HomeUnitEnv
-> Maybe ModIfaceCache
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO
(Maybe [ModuleGraphNode], [MakeAction],
IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan UnitEnvGraph HomeUnitEnv
hug Maybe ModIfaceCache
mhmi_cache Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
plan = do
MVar (UnitEnvGraph HomeUnitEnv)
hug_var <- UnitEnvGraph HomeUnitEnv -> IO (MVar (UnitEnvGraph HomeUnitEnv))
forall a. a -> IO (MVar a)
newMVar UnitEnvGraph HomeUnitEnv
hug
((Maybe [ModuleGraphNode]
mcycle, [MakeAction]
plans), BuildLoopState
build_map) <- StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
-> BuildLoopState
-> IO ((Maybe [ModuleGraphNode], [MakeAction]), BuildLoopState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ([BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plan) (Map NodeKey BuildResult
-> Int -> MVar (UnitEnvGraph HomeUnitEnv) -> BuildLoopState
BuildLoopState Map NodeKey BuildResult
forall k a. Map k a
M.empty Int
1 MVar (UnitEnvGraph HomeUnitEnv)
hug_var)
let wait :: IO [Maybe (Maybe HomeModInfo)]
wait = Map NodeKey BuildResult -> IO [Maybe (Maybe HomeModInfo)]
forall {k}. Map k BuildResult -> IO [Maybe (Maybe HomeModInfo)]
collect_results (BuildLoopState -> Map NodeKey BuildResult
buildDep BuildLoopState
build_map)
(Maybe [ModuleGraphNode], [MakeAction],
IO [Maybe (Maybe HomeModInfo)])
-> IO
(Maybe [ModuleGraphNode], [MakeAction],
IO [Maybe (Maybe HomeModInfo)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Maybe [ModuleGraphNode]
mcycle, [MakeAction]
plans, IO [Maybe (Maybe HomeModInfo)]
wait)
where
collect_results :: Map k BuildResult -> IO [Maybe (Maybe HomeModInfo)]
collect_results Map k BuildResult
build_map =
[IO (Maybe (Maybe HomeModInfo))] -> IO [Maybe (Maybe HomeModInfo)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((BuildResult -> IO (Maybe (Maybe HomeModInfo)))
-> [BuildResult] -> [IO (Maybe (Maybe HomeModInfo))]
forall a b. (a -> b) -> [a] -> [b]
map (\BuildResult
br -> ResultVar (Maybe HomeModInfo) -> IO (Maybe (Maybe HomeModInfo))
forall {a}. ResultVar a -> IO (Maybe a)
collect_result ((Maybe HomeModInfo, ModuleNameSet) -> Maybe HomeModInfo
forall a b. (a, b) -> a
fst ((Maybe HomeModInfo, ModuleNameSet) -> Maybe HomeModInfo)
-> ResultVar (Maybe HomeModInfo, ModuleNameSet)
-> ResultVar (Maybe HomeModInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuildResult -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
resultVar BuildResult
br)) (Map k BuildResult -> [BuildResult]
forall k a. Map k a -> [a]
M.elems Map k BuildResult
build_map))
where
collect_result :: ResultVar a -> IO (Maybe a)
collect_result ResultVar a
res_var = MaybeT IO a -> IO (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (ResultVar a -> MaybeT IO a
forall a. ResultVar a -> MaybeT IO a
waitResult ResultVar a
res_var)
n_mods :: Int
n_mods = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BuildPlan -> Int) -> [BuildPlan] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
plan)
buildLoop :: [BuildPlan]
-> BuildM (Maybe [ModuleGraphNode], [MakeAction])
buildLoop :: [BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [] = (Maybe [ModuleGraphNode], [MakeAction])
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
forall a. a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [ModuleGraphNode]
forall a. Maybe a
Nothing, [])
buildLoop (BuildPlan
plan:[BuildPlan]
plans) =
case BuildPlan
plan of
SingleModule ModuleGraphNode
m -> do
MakeAction
one_plan <- Maybe [NodeKey]
-> ResultOrigin -> ModuleGraphNode -> BuildM MakeAction
buildSingleModule Maybe [NodeKey]
forall a. Maybe a
Nothing ResultOrigin
NoLoop ModuleGraphNode
m
(Maybe [ModuleGraphNode]
cycle, [MakeAction]
all_plans) <- [BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plans
return (Maybe [ModuleGraphNode]
cycle, MakeAction
one_plan MakeAction -> [MakeAction] -> [MakeAction]
forall a. a -> [a] -> [a]
: [MakeAction]
all_plans)
ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms -> do
[MakeAction]
pipes <- [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> BuildM [MakeAction]
buildModuleLoop [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
(Maybe [ModuleGraphNode]
cycle, [MakeAction]
graph) <- [BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plans
return (Maybe [ModuleGraphNode]
cycle, [MakeAction]
pipes [MakeAction] -> [MakeAction] -> [MakeAction]
forall a. [a] -> [a] -> [a]
++ [MakeAction]
graph)
UnresolvedCycle [ModuleGraphNode]
ns -> (Maybe [ModuleGraphNode], [MakeAction])
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
forall a. a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ModuleGraphNode] -> Maybe [ModuleGraphNode]
forall a. a -> Maybe a
Just [ModuleGraphNode]
ns, [])
buildSingleModule :: Maybe [NodeKey]
-> ResultOrigin
-> ModuleGraphNode
-> BuildM MakeAction
buildSingleModule :: Maybe [NodeKey]
-> ResultOrigin -> ModuleGraphNode -> BuildM MakeAction
buildSingleModule Maybe [NodeKey]
rehydrate_nodes ResultOrigin
origin ModuleGraphNode
mod = do
Int
mod_idx <- BuildM Int
nodeId
!Map NodeKey BuildResult
build_map <- BuildM (Map NodeKey BuildResult)
getBuildMap
MVar (UnitEnvGraph HomeUnitEnv)
hug_var <- (BuildLoopState -> MVar (UnitEnvGraph HomeUnitEnv))
-> StateT BuildLoopState IO (MVar (UnitEnvGraph HomeUnitEnv))
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> MVar (UnitEnvGraph HomeUnitEnv)
hug_var
let direct_deps :: [NodeKey]
direct_deps = Bool -> ModuleGraphNode -> [NodeKey]
nodeDependencies Bool
False ModuleGraphNode
mod
!build_deps :: [BuildResult]
build_deps = [NodeKey] -> Map NodeKey BuildResult -> [BuildResult]
getDependencies [NodeKey]
direct_deps Map NodeKey BuildResult
build_map
let build_action :: RunMakeM (Maybe HomeModInfo, ModuleNameSet)
build_action =
UnitId
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
mod) (RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet))
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall a b. (a -> b) -> a -> b
$ do
(UnitEnvGraph HomeUnitEnv
hug, ModuleNameSet
deps) <- MVar (UnitEnvGraph HomeUnitEnv)
-> [BuildResult]
-> ReaderT
MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv, ModuleNameSet)
wait_deps_hug MVar (UnitEnvGraph HomeUnitEnv)
hug_var [BuildResult]
build_deps
case ModuleGraphNode
mod of
InstantiationNode UnitId
uid InstantiatedUnit
iu -> do
Int
-> Int
-> UnitEnvGraph HomeUnitEnv
-> UnitId
-> InstantiatedUnit
-> RunMakeM ()
executeInstantiationNode Int
mod_idx Int
n_mods UnitEnvGraph HomeUnitEnv
hug UnitId
uid InstantiatedUnit
iu
return (Maybe HomeModInfo
forall a. Maybe a
Nothing, ModuleNameSet
deps)
ModuleNode [NodeKey]
_build_deps ModSummary
ms -> do
let !old_hmi :: Maybe HomeModInfo
old_hmi = ModNodeKeyWithUid
-> Map ModNodeKeyWithUid HomeModInfo -> Maybe HomeModInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms) Map ModNodeKeyWithUid HomeModInfo
old_hpt
rehydrate_mods :: Maybe [ModuleName]
rehydrate_mods = (NodeKey -> Maybe ModuleName) -> [NodeKey] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe ModuleName
nodeKeyModName ([NodeKey] -> [ModuleName])
-> Maybe [NodeKey] -> Maybe [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [NodeKey]
rehydrate_nodes
HomeModInfo
hmi <- Int
-> Int
-> Maybe HomeModInfo
-> UnitEnvGraph HomeUnitEnv
-> Maybe [ModuleName]
-> ModSummary
-> RunMakeM HomeModInfo
executeCompileNode Int
mod_idx Int
n_mods Maybe HomeModInfo
old_hmi UnitEnvGraph HomeUnitEnv
hug Maybe [ModuleName]
rehydrate_mods ModSummary
ms
IO (Maybe ()) -> ReaderT MakeEnv (MaybeT IO) (Maybe ())
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ()) -> ReaderT MakeEnv (MaybeT IO) (Maybe ()))
-> IO (Maybe ()) -> ReaderT MakeEnv (MaybeT IO) (Maybe ())
forall a b. (a -> b) -> a -> b
$ Maybe ModIfaceCache -> (ModIfaceCache -> IO ()) -> IO (Maybe ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe ModIfaceCache
mhmi_cache ((ModIfaceCache -> IO ()) -> IO (Maybe ()))
-> (ModIfaceCache -> IO ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ \ModIfaceCache
hmi_cache -> ModIfaceCache -> HomeModInfo -> IO ()
addHmiToCache ModIfaceCache
hmi_cache HomeModInfo
hmi
IO () -> RunMakeM ()
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RunMakeM ()) -> IO () -> RunMakeM ()
forall a b. (a -> b) -> a -> b
$ MVar (UnitEnvGraph HomeUnitEnv)
-> (UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (UnitEnvGraph HomeUnitEnv)
hug_var (UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv))
-> (UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> IO (UnitEnvGraph HomeUnitEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
addHomeModInfoToHug HomeModInfo
hmi)
return (HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just HomeModInfo
hmi, UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet
addToModuleNameSet (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
mod) (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) ModuleNameSet
deps )
LinkNode [NodeKey]
_nks UnitId
uid -> do
UnitEnvGraph HomeUnitEnv
-> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
executeLinkNode UnitEnvGraph HomeUnitEnv
hug (Int
mod_idx, Int
n_mods) UnitId
uid [NodeKey]
direct_deps
return (Maybe HomeModInfo
forall a. Maybe a
Nothing, ModuleNameSet
deps)
MVar (Maybe (Maybe HomeModInfo, ModuleNameSet))
res_var <- IO (MVar (Maybe (Maybe HomeModInfo, ModuleNameSet)))
-> StateT
BuildLoopState IO (MVar (Maybe (Maybe HomeModInfo, ModuleNameSet)))
forall a. IO a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar (Maybe (Maybe HomeModInfo, ModuleNameSet)))
forall a. IO (MVar a)
newEmptyMVar
let result_var :: ResultVar (Maybe HomeModInfo, ModuleNameSet)
result_var = MVar (Maybe (Maybe HomeModInfo, ModuleNameSet))
-> ResultVar (Maybe HomeModInfo, ModuleNameSet)
forall a. MVar (Maybe a) -> ResultVar a
mkResultVar MVar (Maybe (Maybe HomeModInfo, ModuleNameSet))
res_var
NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mod) (ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult ResultOrigin
origin ResultVar (Maybe HomeModInfo, ModuleNameSet)
result_var)
return $ (RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> MVar (Maybe (Maybe HomeModInfo, ModuleNameSet)) -> MakeAction
forall a. RunMakeM a -> MVar (Maybe a) -> MakeAction
MakeAction RunMakeM (Maybe HomeModInfo, ModuleNameSet)
build_action MVar (Maybe (Maybe HomeModInfo, ModuleNameSet))
res_var)
buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]
buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]
buildOneLoopyModule (ModuleGraphNodeWithBootFile ModuleGraphNode
mn [NodeKey]
deps) = do
MakeAction
ma <- Maybe [NodeKey]
-> ResultOrigin -> ModuleGraphNode -> BuildM MakeAction
buildSingleModule ([NodeKey] -> Maybe [NodeKey]
forall a. a -> Maybe a
Just [NodeKey]
deps) (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
Initialise) ModuleGraphNode
mn
MakeAction
rehydrate_action <- ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction
rehydrateAction ResultLoopOrigin
Rehydrated ((NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
IsBoot) GenWithIsBoot NodeKey
-> [GenWithIsBoot NodeKey] -> [GenWithIsBoot NodeKey]
forall a. a -> [a] -> [a]
: ((NodeKey -> GenWithIsBoot NodeKey)
-> [NodeKey] -> [GenWithIsBoot NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map (\NodeKey
d -> NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB NodeKey
d IsBootInterface
NotBoot) [NodeKey]
deps))
return $ [MakeAction
ma, MakeAction
rehydrate_action]
buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction]
buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> BuildM [MakeAction]
buildModuleLoop [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms = do
[MakeAction]
build_modules <- (Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> BuildM [MakeAction])
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> BuildM [MakeAction]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM ((ModuleGraphNode -> BuildM [MakeAction])
-> (ModuleGraphNodeWithBootFile -> BuildM [MakeAction])
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> BuildM [MakeAction]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((MakeAction -> [MakeAction])
-> BuildM MakeAction -> BuildM [MakeAction]
forall a b.
(a -> b)
-> StateT BuildLoopState IO a -> StateT BuildLoopState IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MakeAction -> [MakeAction] -> [MakeAction]
forall a. a -> [a] -> [a]
:[]) (BuildM MakeAction -> BuildM [MakeAction])
-> (ModuleGraphNode -> BuildM MakeAction)
-> ModuleGraphNode
-> BuildM [MakeAction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [NodeKey]
-> ResultOrigin -> ModuleGraphNode -> BuildM MakeAction
buildSingleModule Maybe [NodeKey]
forall a. Maybe a
Nothing (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
Initialise)) ModuleGraphNodeWithBootFile -> BuildM [MakeAction]
buildOneLoopyModule) [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
let extract :: Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> GenWithIsBoot NodeKey
extract (Left ModuleGraphNode
mn) = NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
NotBoot
extract (Right (ModuleGraphNodeWithBootFile ModuleGraphNode
mn [NodeKey]
_)) = NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
IsBoot
let loop_mods :: [GenWithIsBoot NodeKey]
loop_mods = (Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> GenWithIsBoot NodeKey)
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> [GenWithIsBoot NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> GenWithIsBoot NodeKey
extract [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
MakeAction
rehydrate_action <- ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction
rehydrateAction ResultLoopOrigin
Finalised [GenWithIsBoot NodeKey]
loop_mods
return $ [MakeAction]
build_modules [MakeAction] -> [MakeAction] -> [MakeAction]
forall a. [a] -> [a] -> [a]
++ [MakeAction
rehydrate_action]
rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction
rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction
rehydrateAction ResultLoopOrigin
origin [GenWithIsBoot NodeKey]
deps = do
MVar (UnitEnvGraph HomeUnitEnv)
hug_var <- (BuildLoopState -> MVar (UnitEnvGraph HomeUnitEnv))
-> StateT BuildLoopState IO (MVar (UnitEnvGraph HomeUnitEnv))
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> MVar (UnitEnvGraph HomeUnitEnv)
hug_var
!Map NodeKey BuildResult
build_map <- BuildM (Map NodeKey BuildResult)
getBuildMap
MVar (Maybe ([HomeModInfo], ModuleNameSet))
res_var <- IO (MVar (Maybe ([HomeModInfo], ModuleNameSet)))
-> StateT
BuildLoopState IO (MVar (Maybe ([HomeModInfo], ModuleNameSet)))
forall a. IO a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar (Maybe ([HomeModInfo], ModuleNameSet)))
forall a. IO (MVar a)
newEmptyMVar
let loop_unit :: UnitId
!loop_unit :: UnitId
loop_unit = NodeKey -> UnitId
nodeKeyUnitId (GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod ([GenWithIsBoot NodeKey] -> GenWithIsBoot NodeKey
forall a. HasCallStack => [a] -> a
head [GenWithIsBoot NodeKey]
deps))
!build_deps :: [BuildResult]
build_deps = [NodeKey] -> Map NodeKey BuildResult -> [BuildResult]
getDependencies ((GenWithIsBoot NodeKey -> NodeKey)
-> [GenWithIsBoot NodeKey] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod [GenWithIsBoot NodeKey]
deps) Map NodeKey BuildResult
build_map
let loop_action :: RunMakeM ([HomeModInfo], ModuleNameSet)
loop_action = UnitId
-> RunMakeM ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet)
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
loop_unit (RunMakeM ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet))
-> RunMakeM ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet)
forall a b. (a -> b) -> a -> b
$ do
(UnitEnvGraph HomeUnitEnv
hug, ModuleNameSet
tdeps) <- MVar (UnitEnvGraph HomeUnitEnv)
-> [BuildResult]
-> ReaderT
MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv, ModuleNameSet)
wait_deps_hug MVar (UnitEnvGraph HomeUnitEnv)
hug_var [BuildResult]
build_deps
HscEnv
hsc_env <- (MakeEnv -> HscEnv) -> ReaderT MakeEnv (MaybeT IO) HscEnv
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> HscEnv
hsc_env
let new_hsc :: HscEnv
new_hsc = UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
hug HscEnv
hsc_env
mns :: [ModuleName]
mns :: [ModuleName]
mns = (GenWithIsBoot NodeKey -> Maybe ModuleName)
-> [GenWithIsBoot NodeKey] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey -> Maybe ModuleName)
-> (GenWithIsBoot NodeKey -> NodeKey)
-> GenWithIsBoot NodeKey
-> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod) [GenWithIsBoot NodeKey]
deps
[HomeModInfo]
hmis' <- IO [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo])
-> IO [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
forall a b. (a -> b) -> a -> b
$ HscEnv -> [ModuleName] -> IO [HomeModInfo]
rehydrateAfter HscEnv
new_hsc [ModuleName]
mns
[HomeModInfo] -> [GenWithIsBoot NodeKey] -> RunMakeM ()
forall {m :: * -> *}.
Applicative m =>
[HomeModInfo] -> [GenWithIsBoot NodeKey] -> m ()
checkRehydrationInvariant [HomeModInfo]
hmis' [GenWithIsBoot NodeKey]
deps
IO () -> RunMakeM ()
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RunMakeM ()) -> IO () -> RunMakeM ()
forall a b. (a -> b) -> a -> b
$ MVar (UnitEnvGraph HomeUnitEnv)
-> (UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (UnitEnvGraph HomeUnitEnv)
hug_var (\UnitEnvGraph HomeUnitEnv
hug -> UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv))
-> UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv)
forall a b. (a -> b) -> a -> b
$ (HomeModInfo
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> [HomeModInfo]
-> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HomeModInfo -> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
addHomeModInfoToHug UnitEnvGraph HomeUnitEnv
hug [HomeModInfo]
hmis')
return ([HomeModInfo]
hmis', ModuleNameSet
tdeps)
let fanout :: Int -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
fanout Int
i = ([HomeModInfo] -> Maybe HomeModInfo)
-> ([HomeModInfo], ModuleNameSet)
-> (Maybe HomeModInfo, ModuleNameSet)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just (HomeModInfo -> Maybe HomeModInfo)
-> ([HomeModInfo] -> HomeModInfo)
-> [HomeModInfo]
-> Maybe HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([HomeModInfo] -> Int -> HomeModInfo
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)) (([HomeModInfo], ModuleNameSet)
-> (Maybe HomeModInfo, ModuleNameSet))
-> ResultVar ([HomeModInfo], ModuleNameSet)
-> ResultVar (Maybe HomeModInfo, ModuleNameSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Maybe ([HomeModInfo], ModuleNameSet))
-> ResultVar ([HomeModInfo], ModuleNameSet)
forall a. MVar (Maybe a) -> ResultVar a
mkResultVar MVar (Maybe ([HomeModInfo], ModuleNameSet))
res_var
boot_key :: NodeKey -> NodeKey
boot_key :: NodeKey -> NodeKey
boot_key (NodeKey_Module ModNodeKeyWithUid
m) = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModNodeKeyWithUid
m { mnkModuleName = (mnkModuleName m) { gwib_isBoot = IsBoot } } )
boot_key NodeKey
k = FilePath -> SDoc -> NodeKey
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"boot_key" (NodeKey -> SDoc
forall a. Outputable a => a -> SDoc
ppr NodeKey
k)
update_module_pipeline :: (GenWithIsBoot NodeKey, Int) -> StateT BuildLoopState IO ()
update_module_pipeline (GenWithIsBoot NodeKey
m, Int
i) =
case GenWithIsBoot NodeKey -> IsBootInterface
forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot GenWithIsBoot NodeKey
m of
IsBootInterface
NotBoot -> NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline (GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod GenWithIsBoot NodeKey
m) (ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
origin) (Int -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
fanout Int
i))
IsBootInterface
IsBoot -> do
NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline (GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod GenWithIsBoot NodeKey
m) (ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
origin) (Int -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
fanout Int
i))
NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline (NodeKey -> NodeKey
boot_key (GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod GenWithIsBoot NodeKey
m)) (ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
origin) (Int -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
fanout Int
i))
let deps_i :: [(GenWithIsBoot NodeKey, Int)]
deps_i = [GenWithIsBoot NodeKey] -> [Int] -> [(GenWithIsBoot NodeKey, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [GenWithIsBoot NodeKey]
deps [Int
0..]
((GenWithIsBoot NodeKey, Int) -> StateT BuildLoopState IO ())
-> [(GenWithIsBoot NodeKey, Int)] -> StateT BuildLoopState IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (GenWithIsBoot NodeKey, Int) -> StateT BuildLoopState IO ()
update_module_pipeline [(GenWithIsBoot NodeKey, Int)]
deps_i
return $ RunMakeM ([HomeModInfo], ModuleNameSet)
-> MVar (Maybe ([HomeModInfo], ModuleNameSet)) -> MakeAction
forall a. RunMakeM a -> MVar (Maybe a) -> MakeAction
MakeAction RunMakeM ([HomeModInfo], ModuleNameSet)
loop_action MVar (Maybe ([HomeModInfo], ModuleNameSet))
res_var
checkRehydrationInvariant :: [HomeModInfo] -> [GenWithIsBoot NodeKey] -> m ()
checkRehydrationInvariant [HomeModInfo]
hmis [GenWithIsBoot NodeKey]
deps =
let hmi_names :: [ModuleName]
hmi_names = (HomeModInfo -> ModuleName) -> [HomeModInfo] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (HomeModInfo -> Module) -> HomeModInfo -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface -> Module)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis
start :: [ModuleName]
start = (GenWithIsBoot NodeKey -> Maybe ModuleName)
-> [GenWithIsBoot NodeKey] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey -> Maybe ModuleName)
-> (GenWithIsBoot NodeKey -> NodeKey)
-> GenWithIsBoot NodeKey
-> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod) [GenWithIsBoot NodeKey]
deps
in Bool -> SDoc -> m ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr ([ModuleName]
hmi_names [ModuleName] -> [ModuleName] -> Bool
forall a. Eq a => a -> a -> Bool
== [ModuleName]
start) (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ ([ModuleName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
hmi_names SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [ModuleName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
start)
withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit :: forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
uid = do
(MakeEnv -> MakeEnv) -> RunMakeM a -> RunMakeM a
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (\MakeEnv
env -> MakeEnv
env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})
upsweep
:: Int
-> HscEnv
-> Maybe ModIfaceCache
-> Maybe Messager
-> M.Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, [HomeModInfo])
upsweep :: Int
-> HscEnv
-> Maybe ModIfaceCache
-> Maybe Messager
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, [HomeModInfo])
upsweep Int
n_jobs HscEnv
hsc_env Maybe ModIfaceCache
hmi_cache Maybe Messager
mHscMessage Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
build_plan = do
(Maybe [ModuleGraphNode]
cycle, [MakeAction]
pipelines, IO [Maybe (Maybe HomeModInfo)]
collect_result) <- UnitEnvGraph HomeUnitEnv
-> Maybe ModIfaceCache
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO
(Maybe [ModuleGraphNode], [MakeAction],
IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env) Maybe ModIfaceCache
hmi_cache Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
build_plan
Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runPipelines Int
n_jobs HscEnv
hsc_env Maybe Messager
mHscMessage [MakeAction]
pipelines
[Maybe (Maybe HomeModInfo)]
res <- IO [Maybe (Maybe HomeModInfo)]
collect_result
let completed :: [HomeModInfo]
completed = [HomeModInfo
m | Just (Just HomeModInfo
m) <- [Maybe (Maybe HomeModInfo)]
res]
case Maybe [ModuleGraphNode]
cycle of
Just [ModuleGraphNode]
mss -> do
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
fatalErrorMsg Logger
logger ([ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
mss)
return (SuccessFlag
Failed, [])
Maybe [ModuleGraphNode]
Nothing -> do
let success_flag :: SuccessFlag
success_flag = Bool -> SuccessFlag
successIf ((Maybe (Maybe HomeModInfo) -> Bool)
-> [Maybe (Maybe HomeModInfo)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe (Maybe HomeModInfo) -> Bool
forall a. Maybe a -> Bool
isJust [Maybe (Maybe HomeModInfo)]
res)
(SuccessFlag, [HomeModInfo]) -> IO (SuccessFlag, [HomeModInfo])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (SuccessFlag
success_flag, [HomeModInfo]
completed)
toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo
toCache :: [HomeModInfo] -> Map ModNodeKeyWithUid HomeModInfo
toCache [HomeModInfo]
hmis = [(ModNodeKeyWithUid, HomeModInfo)]
-> Map ModNodeKeyWithUid HomeModInfo
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ModIface -> ModNodeKeyWithUid
miKey (ModIface -> ModNodeKeyWithUid) -> ModIface -> ModNodeKeyWithUid
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi, HomeModInfo
hmi) | HomeModInfo
hmi <- [HomeModInfo]
hmis])
miKey :: ModIface -> ModNodeKeyWithUid
miKey :: ModIface -> ModNodeKeyWithUid
miKey ModIface
hmi = ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModIface -> ModuleNameWithIsBoot
mi_mnwib ModIface
hmi) ((GenUnit UnitId -> UnitId
toUnitId (GenUnit UnitId -> UnitId) -> GenUnit UnitId -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
hmi)))
upsweep_inst :: HscEnv
-> Maybe Messager
-> Int
-> Int
-> UnitId
-> InstantiatedUnit
-> IO ()
upsweep_inst :: HscEnv
-> Maybe Messager
-> Int
-> Int
-> UnitId
-> InstantiatedUnit
-> IO ()
upsweep_inst HscEnv
hsc_env Maybe Messager
mHscMessage Int
mod_index Int
nmods UnitId
uid InstantiatedUnit
iuid = do
case Maybe Messager
mHscMessage of
Just Messager
hscMessage -> Messager
hscMessage HscEnv
hsc_env (Int
mod_index, Int
nmods) (CompileReason -> RecompileRequired
NeedsRecompile CompileReason
MustCompile) (UnitId -> InstantiatedUnit -> ModuleGraphNode
InstantiationNode UnitId
uid InstantiatedUnit
iuid)
Maybe Messager
Nothing -> () -> IO ()
forall a. a -> IO a
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 GhcMessage, Maybe ()) -> Hsc ()
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe ()) -> Hsc ())
-> IO (Messages GhcMessage, Maybe ()) -> Hsc ()
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe ())
-> IO (Messages GhcMessage, Maybe ())
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe ())
-> IO (Messages GhcMessage, Maybe ()))
-> IO (Messages TcRnMessage, Maybe ())
-> IO (Messages GhcMessage, Maybe ())
forall a b. (a -> b) -> a -> b
$ HscEnv -> GenUnit UnitId -> IO (Messages TcRnMessage, Maybe ())
tcRnCheckUnit HscEnv
hsc_env (GenUnit UnitId -> IO (Messages TcRnMessage, Maybe ()))
-> GenUnit UnitId -> IO (Messages TcRnMessage, Maybe ())
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> GenUnit UnitId
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid
pure ()
upsweep_mod :: HscEnv
-> Maybe Messager
-> Maybe HomeModInfo
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod :: HscEnv
-> Maybe Messager
-> Maybe HomeModInfo
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
hsc_env Maybe Messager
mHscMessage Maybe HomeModInfo
old_hmi ModSummary
summary Int
mod_index Int
nmods = do
HomeModInfo
hmi <- Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> HomeModLinkable
-> IO HomeModInfo
compileOne' Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary
Int
mod_index Int
nmods (HomeModInfo -> ModIface
hm_iface (HomeModInfo -> ModIface) -> Maybe HomeModInfo -> Maybe ModIface
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HomeModInfo
old_hmi) (HomeModLinkable
-> (HomeModInfo -> HomeModLinkable)
-> Maybe HomeModInfo
-> HomeModLinkable
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HomeModLinkable
emptyHomeModInfoLinkable HomeModInfo -> HomeModLinkable
hm_linkable Maybe HomeModInfo
old_hmi)
HscEnv -> Maybe Linkable -> IO ()
addSptEntries ((HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT (\HomePackageTable
hpt -> HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
summary) HomeModInfo
hmi) HscEnv
hsc_env)
(HomeModInfo -> Maybe Linkable
homeModInfoByteCode HomeModInfo
hmi)
return HomeModInfo
hmi
addSptEntries :: HscEnv -> Maybe Linkable -> IO ()
addSptEntries :: HscEnv -> Maybe Linkable -> IO ()
addSptEntries HscEnv
hsc_env Maybe Linkable
mlinkable =
HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env
[ SptEntry
spt
| Just Linkable
linkable <- [Maybe Linkable
mlinkable]
, Unlinked
unlinked <- Linkable -> [Unlinked]
linkableUnlinked Linkable
linkable
, BCOs CompiledByteCode
_ [SptEntry]
spts <- Unlinked -> [Unlinked]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Unlinked
unlinked
, SptEntry
spt <- [SptEntry]
spts
]
topSortModuleGraph
:: Bool
-> ModuleGraph
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModuleGraph :: Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
drop_hs_boot_nodes ModuleGraph
module_graph Maybe HomeUnitModule
mb_root_mod =
Bool
-> [ModuleGraphNode]
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModules Bool
drop_hs_boot_nodes ([ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a]
reverse ([ModuleGraphNode] -> [ModuleGraphNode])
-> [ModuleGraphNode] -> [ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
module_graph) Maybe HomeUnitModule
mb_root_mod
topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModules :: Bool
-> [ModuleGraphNode]
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModules Bool
drop_hs_boot_nodes [ModuleGraphNode]
summaries Maybe HomeUnitModule
mb_root_mod
= (SCC SummaryNode -> SCC ModuleGraphNode)
-> [SCC SummaryNode] -> [SCC ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
map ((SummaryNode -> ModuleGraphNode)
-> SCC SummaryNode -> SCC ModuleGraphNode
forall a b. (a -> b) -> SCC a -> SCC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SummaryNode -> ModuleGraphNode
summaryNodeSummary) ([SCC SummaryNode] -> [SCC ModuleGraphNode])
-> [SCC SummaryNode] -> [SCC ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ Graph SummaryNode -> [SCC SummaryNode]
forall node. Graph node -> [SCC node]
stronglyConnCompG Graph SummaryNode
initial_graph
where
(Graph SummaryNode
graph, NodeKey -> Maybe SummaryNode
lookup_node) =
Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
drop_hs_boot_nodes [ModuleGraphNode]
summaries
initial_graph :: Graph SummaryNode
initial_graph = case Maybe HomeUnitModule
mb_root_mod of
Maybe HomeUnitModule
Nothing -> Graph SummaryNode
graph
Just (Module UnitId
uid ModuleName
root_mod) ->
let root :: SummaryNode
root | Just SummaryNode
node <- NodeKey -> Maybe SummaryNode
lookup_node (NodeKey -> Maybe SummaryNode) -> NodeKey -> Maybe SummaryNode
forall a b. (a -> b) -> a -> b
$ ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModNodeKeyWithUid -> NodeKey) -> ModNodeKeyWithUid -> NodeKey
forall a b. (a -> b) -> a -> b
$ ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
root_mod IsBootInterface
NotBoot) UnitId
uid
, Graph SummaryNode
graph Graph SummaryNode -> SummaryNode -> Bool
forall node. Graph node -> node -> Bool
`hasVertexG` SummaryNode
node
= SummaryNode
node
| Bool
otherwise
= GhcException -> SummaryNode
forall a. GhcException -> a
throwGhcException (FilePath -> GhcException
ProgramError FilePath
"module does not exist")
in [SummaryNode] -> Graph SummaryNode
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq (SummaryNode -> [SummaryNode] -> [SummaryNode]
forall a b. a -> b -> b
seq SummaryNode
root (Graph SummaryNode -> SummaryNode -> [SummaryNode]
forall node. Graph node -> node -> [node]
reachableG Graph SummaryNode
graph SummaryNode
root))
newtype ModNodeMap a = ModNodeMap { forall a. ModNodeMap a -> Map ModuleNameWithIsBoot 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
$cfmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
fmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
$c<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
sequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
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
$cfold :: forall m. Monoid m => ModNodeMap m -> m
fold :: forall m. Monoid m => ModNodeMap m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$ctoList :: forall a. ModNodeMap a -> [a]
toList :: forall a. ModNodeMap a -> [a]
$cnull :: forall a. ModNodeMap a -> Bool
null :: forall a. ModNodeMap a -> Bool
$clength :: forall a. ModNodeMap a -> Int
length :: forall a. ModNodeMap a -> Int
$celem :: forall a. Eq a => a -> ModNodeMap a -> Bool
elem :: forall a. Eq a => a -> ModNodeMap a -> Bool
$cmaximum :: forall a. Ord a => ModNodeMap a -> a
maximum :: forall a. Ord a => ModNodeMap a -> a
$cminimum :: forall a. Ord a => ModNodeMap a -> a
minimum :: forall a. Ord a => ModNodeMap a -> a
$csum :: forall a. Num a => ModNodeMap a -> a
sum :: forall a. Num a => ModNodeMap a -> a
$cproduct :: forall a. Num a => ModNodeMap a -> a
product :: forall a. Num a => ModNodeMap a -> a
Foldable)
emptyModNodeMap :: ModNodeMap a
emptyModNodeMap :: forall a. ModNodeMap a
emptyModNodeMap = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap Map ModuleNameWithIsBoot a
forall k a. Map k a
Map.empty
modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert :: forall a. ModuleNameWithIsBoot -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert ModuleNameWithIsBoot
k a
v (ModNodeMap Map ModuleNameWithIsBoot a
m) = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (ModuleNameWithIsBoot
-> a -> Map ModuleNameWithIsBoot a -> Map ModuleNameWithIsBoot a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ModuleNameWithIsBoot
k a
v Map ModuleNameWithIsBoot a
m)
modNodeMapElems :: ModNodeMap a -> [a]
modNodeMapElems :: forall a. ModNodeMap a -> [a]
modNodeMapElems (ModNodeMap Map ModuleNameWithIsBoot a
m) = Map ModuleNameWithIsBoot a -> [a]
forall k a. Map k a -> [a]
Map.elems Map ModuleNameWithIsBoot a
m
modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup :: forall a. ModuleNameWithIsBoot -> ModNodeMap a -> Maybe a
modNodeMapLookup ModuleNameWithIsBoot
k (ModNodeMap Map ModuleNameWithIsBoot a
m) = ModuleNameWithIsBoot -> Map ModuleNameWithIsBoot a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleNameWithIsBoot
k Map ModuleNameWithIsBoot a
m
modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a
modNodeMapSingleton :: forall a. ModuleNameWithIsBoot -> a -> ModNodeMap a
modNodeMapSingleton ModuleNameWithIsBoot
k a
v = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (ModuleNameWithIsBoot -> a -> Map ModuleNameWithIsBoot a
forall k a. k -> a -> Map k a
M.singleton ModuleNameWithIsBoot
k a
v)
modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a
modNodeMapUnionWith :: forall a.
(a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a
modNodeMapUnionWith a -> a -> a
f (ModNodeMap Map ModuleNameWithIsBoot a
m) (ModNodeMap Map ModuleNameWithIsBoot a
n) = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap ((a -> a -> a)
-> Map ModuleNameWithIsBoot a
-> Map ModuleNameWithIsBoot a
-> Map ModuleNameWithIsBoot a
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith a -> a -> a
f Map ModuleNameWithIsBoot a
m Map ModuleNameWithIsBoot a
n)
warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports :: forall (m :: * -> *). GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports [SCC ModSummary]
sccs = do
DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts (DynFlags -> DiagOpts) -> m DynFlags -> m DiagOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DiagOpts -> Bool
diag_wopt WarningFlag
Opt_WarnUnusedImports DiagOpts
diag_opts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let check :: [ModSummary] -> [MsgEnvelope GhcMessage]
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 GhcMessage
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 -> MsgEnvelope GhcMessage
warn :: GenLocated SrcSpan ModuleName -> MsgEnvelope GhcMessage
warn (L SrcSpan
loc ModuleName
mod) = DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage)
-> MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts
SrcSpan
loc (ModuleName -> DriverMessage
DriverUnnecessarySourceImports ModuleName
mod)
Messages GhcMessage -> m ()
forall (m :: * -> *). GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics (Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage)
-> Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope GhcMessage] -> Bag (MsgEnvelope GhcMessage)
forall a. [a] -> Bag a
listToBag ((SCC ModSummary -> [MsgEnvelope GhcMessage])
-> [SCC ModSummary] -> [MsgEnvelope GhcMessage]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([ModSummary] -> [MsgEnvelope GhcMessage]
check ([ModSummary] -> [MsgEnvelope GhcMessage])
-> (SCC ModSummary -> [ModSummary])
-> SCC ModSummary
-> [MsgEnvelope GhcMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC ModSummary -> [ModSummary]
forall vertex. SCC vertex -> [vertex]
flattenSCC) [SCC ModSummary]
sccs))
type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]
downsweep :: HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep :: HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep HscEnv
hsc_env [ModSummary]
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots
= do
[Either (UnitId, DriverMessages) ModSummary]
rootSummaries <- (Target -> IO (Either (UnitId, DriverMessages) ModSummary))
-> [Target] -> IO [Either (UnitId, DriverMessages) ModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Target -> IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary [Target]
roots
let ([(UnitId, DriverMessages)]
root_errs, [ModSummary]
rootSummariesOk) = [Either (UnitId, DriverMessages) ModSummary]
-> ([(UnitId, DriverMessages)], [ModSummary])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (UnitId, DriverMessages) ModSummary]
rootSummaries
root_map :: DownsweepCache
root_map = [ModSummary] -> DownsweepCache
mkRootMap [ModSummary]
rootSummariesOk
DownsweepCache -> IO ()
checkDuplicates DownsweepCache
root_map
(Map NodeKey ModuleGraphNode
deps, Set (UnitId, UnitId)
pkg_deps, DownsweepCache
map0) <- [ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
DownsweepCache)
-> IO
(Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary]
rootSummariesOk (Map NodeKey ModuleGraphNode
forall k a. Map k a
M.empty, Set (UnitId, UnitId)
forall a. Set a
Set.empty, DownsweepCache
root_map)
let closure_errs :: [DriverMessages]
closure_errs = UnitEnv -> Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
checkHomeUnitsClosed (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env) (Set (UnitId, UnitId) -> [(UnitId, UnitId)]
forall a. Set a -> [a]
Set.toList Set (UnitId, UnitId)
pkg_deps)
let unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
let downsweep_errs :: [DriverMessages]
downsweep_errs = [Either DriverMessages ModSummary] -> [DriverMessages]
forall a b. [Either a b] -> [a]
lefts ([Either DriverMessages ModSummary] -> [DriverMessages])
-> [Either DriverMessages ModSummary] -> [DriverMessages]
forall a b. (a -> b) -> a -> b
$ [[Either DriverMessages ModSummary]]
-> [Either DriverMessages ModSummary]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either DriverMessages ModSummary]]
-> [Either DriverMessages ModSummary])
-> [[Either DriverMessages ModSummary]]
-> [Either DriverMessages ModSummary]
forall a b. (a -> b) -> a -> b
$ DownsweepCache -> [[Either DriverMessages ModSummary]]
forall k a. Map k a -> [a]
M.elems DownsweepCache
map0
downsweep_nodes :: [ModuleGraphNode]
downsweep_nodes = Map NodeKey ModuleGraphNode -> [ModuleGraphNode]
forall k a. Map k a -> [a]
M.elems Map NodeKey ModuleGraphNode
deps
([DriverMessages]
other_errs, [ModuleGraphNode]
unit_nodes) = [Either DriverMessages ModuleGraphNode]
-> ([DriverMessages], [ModuleGraphNode])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either DriverMessages ModuleGraphNode]
-> ([DriverMessages], [ModuleGraphNode]))
-> [Either DriverMessages ModuleGraphNode]
-> ([DriverMessages], [ModuleGraphNode])
forall a b. (a -> b) -> a -> b
$ ([Either DriverMessages ModuleGraphNode]
-> UnitId
-> HomeUnitEnv
-> [Either DriverMessages ModuleGraphNode])
-> [Either DriverMessages ModuleGraphNode]
-> UnitEnvGraph HomeUnitEnv
-> [Either DriverMessages ModuleGraphNode]
forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey (\[Either DriverMessages ModuleGraphNode]
nodes UnitId
uid HomeUnitEnv
hue -> [Either DriverMessages ModuleGraphNode]
nodes [Either DriverMessages ModuleGraphNode]
-> [Either DriverMessages ModuleGraphNode]
-> [Either DriverMessages ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
-> UnitId -> HomeUnitEnv -> [Either DriverMessages ModuleGraphNode]
unitModuleNodes [ModuleGraphNode]
downsweep_nodes UnitId
uid HomeUnitEnv
hue) [] (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env)
all_nodes :: [ModuleGraphNode]
all_nodes = [ModuleGraphNode]
downsweep_nodes [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
unit_nodes
all_errs :: [DriverMessages]
all_errs = [DriverMessages]
all_root_errs [DriverMessages] -> [DriverMessages] -> [DriverMessages]
forall a. [a] -> [a] -> [a]
++ [DriverMessages]
downsweep_errs [DriverMessages] -> [DriverMessages] -> [DriverMessages]
forall a. [a] -> [a] -> [a]
++ [DriverMessages]
other_errs
all_root_errs :: [DriverMessages]
all_root_errs = [DriverMessages]
closure_errs [DriverMessages] -> [DriverMessages] -> [DriverMessages]
forall a. [a] -> [a] -> [a]
++ ((UnitId, DriverMessages) -> DriverMessages)
-> [(UnitId, DriverMessages)] -> [DriverMessages]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, DriverMessages) -> DriverMessages
forall a b. (a, b) -> b
snd [(UnitId, DriverMessages)]
root_errs
[ModuleGraphNode]
th_enabled_nodes <- Logger
-> TmpFs -> UnitEnv -> [ModuleGraphNode] -> IO [ModuleGraphNode]
enableCodeGenForTH Logger
logger TmpFs
tmpfs UnitEnv
unit_env [ModuleGraphNode]
all_nodes
if [DriverMessages] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DriverMessages]
all_root_errs
then ([DriverMessages], [ModuleGraphNode])
-> IO ([DriverMessages], [ModuleGraphNode])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DriverMessages]
all_errs, [ModuleGraphNode]
th_enabled_nodes)
else ([DriverMessages], [ModuleGraphNode])
-> IO ([DriverMessages], [ModuleGraphNode])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([DriverMessages], [ModuleGraphNode])
-> IO ([DriverMessages], [ModuleGraphNode]))
-> ([DriverMessages], [ModuleGraphNode])
-> IO ([DriverMessages], [ModuleGraphNode])
forall a b. (a -> b) -> a -> b
$ ([DriverMessages]
all_root_errs, [])
where
unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]
unitModuleNodes :: [ModuleGraphNode]
-> UnitId -> HomeUnitEnv -> [Either DriverMessages ModuleGraphNode]
unitModuleNodes [ModuleGraphNode]
summaries UnitId
uid HomeUnitEnv
hue =
let instantiation_nodes :: [ModuleGraphNode]
instantiation_nodes = UnitId -> UnitState -> [ModuleGraphNode]
instantiationNodes UnitId
uid (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
hue)
in (ModuleGraphNode -> Either DriverMessages ModuleGraphNode)
-> [ModuleGraphNode] -> [Either DriverMessages ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> Either DriverMessages ModuleGraphNode
forall a b. b -> Either a b
Right [ModuleGraphNode]
instantiation_nodes
[Either DriverMessages ModuleGraphNode]
-> [Either DriverMessages ModuleGraphNode]
-> [Either DriverMessages ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ Maybe (Either DriverMessages ModuleGraphNode)
-> [Either DriverMessages ModuleGraphNode]
forall a. Maybe a -> [a]
maybeToList ([ModuleGraphNode]
-> UnitId
-> HomeUnitEnv
-> Maybe (Either DriverMessages ModuleGraphNode)
linkNodes ([ModuleGraphNode]
instantiation_nodes [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
summaries) UnitId
uid HomeUnitEnv
hue)
calcDeps :: ModSummary
-> [(UnitId, PkgQual,
GenWithIsBoot (GenLocated SrcSpan ModuleName))]
calcDeps ModSummary
ms =
[(ModSummary -> UnitId
ms_unitid ModSummary
ms, PkgQual
NoPkgQual, GenLocated SrcSpan ModuleName
-> IsBootInterface -> GenWithIsBoot (GenLocated SrcSpan ModuleName)
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleName -> GenLocated SrcSpan ModuleName
forall e. e -> Located e
noLoc (ModuleName -> GenLocated SrcSpan ModuleName)
-> ModuleName -> GenLocated SrcSpan ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
IsBoot) | IsBootInterface
NotBoot <- [ModSummary -> IsBootInterface
isBootSummary ModSummary
ms] ] [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> [(UnitId, PkgQual,
GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> [(UnitId, PkgQual,
GenWithIsBoot (GenLocated SrcSpan ModuleName))]
forall a. [a] -> [a] -> [a]
++
[(ModSummary -> UnitId
ms_unitid ModSummary
ms, PkgQual
b, GenWithIsBoot (GenLocated SrcSpan ModuleName)
c) | (PkgQual
b, GenWithIsBoot (GenLocated SrcSpan ModuleName)
c) <- ModSummary
-> [(PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
msDeps ModSummary
ms ]
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
roots :: [Target]
roots = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
old_summary_map :: M.Map (UnitId, FilePath) ModSummary
old_summary_map :: Map (UnitId, FilePath) ModSummary
old_summary_map = [((UnitId, FilePath), ModSummary)]
-> Map (UnitId, FilePath) ModSummary
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((ModSummary -> UnitId
ms_unitid ModSummary
ms, ModSummary -> FilePath
msHsFilePath ModSummary
ms), ModSummary
ms) | ModSummary
ms <- [ModSummary]
old_summaries]
getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary Target { targetId :: Target -> TargetId
targetId = TargetFile FilePath
file Maybe Phase
mb_phase
, targetContents :: Target -> Maybe (InputFileBuffer, UTCTime)
targetContents = Maybe (InputFileBuffer, UTCTime)
maybe_buf
, targetUnitId :: Target -> UnitId
targetUnitId = UnitId
uid
}
= do let offset_file :: FilePath
offset_file = DynFlags -> FilePath -> FilePath
augmentByWorkingDirectory DynFlags
dflags FilePath
file
Bool
exists <- IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
offset_file
if Bool
exists Bool -> Bool -> Bool
|| Maybe (InputFileBuffer, UTCTime) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (InputFileBuffer, UTCTime)
maybe_buf
then (DriverMessages -> (UnitId, DriverMessages))
-> Either DriverMessages ModSummary
-> Either (UnitId, DriverMessages) ModSummary
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (UnitId
uid,) (Either DriverMessages ModSummary
-> Either (UnitId, DriverMessages) ModSummary)
-> IO (Either DriverMessages ModSummary)
-> IO (Either (UnitId, DriverMessages) ModSummary)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either DriverMessages ModSummary)
summariseFile HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map FilePath
offset_file Maybe Phase
mb_phase
Maybe (InputFileBuffer, UTCTime)
maybe_buf
else Either (UnitId, DriverMessages) ModSummary
-> IO (Either (UnitId, DriverMessages) ModSummary)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (UnitId, DriverMessages) ModSummary
-> IO (Either (UnitId, DriverMessages) ModSummary))
-> Either (UnitId, DriverMessages) ModSummary
-> IO (Either (UnitId, DriverMessages) ModSummary)
forall a b. (a -> b) -> a -> b
$ (UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary
forall a b. a -> Either a b
Left ((UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary)
-> (UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary
forall a b. (a -> b) -> a -> b
$ (UnitId
uid,) (DriverMessages -> (UnitId, DriverMessages))
-> DriverMessages -> (UnitId, DriverMessages)
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage
(MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (FilePath -> DriverMessage
DriverFileNotFound FilePath
offset_file)
where
dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags ((() :: Constraint) => UnitId -> UnitEnv -> HomeUnitEnv
UnitId -> UnitEnv -> HomeUnitEnv
ue_findHomeUnitEnv UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env))
home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
getRootSummary Target { targetId :: Target -> TargetId
targetId = TargetModule ModuleName
modl
, targetContents :: Target -> Maybe (InputFileBuffer, UTCTime)
targetContents = Maybe (InputFileBuffer, UTCTime)
maybe_buf
, targetUnitId :: Target -> UnitId
targetUnitId = UnitId
uid
}
= do SummariseResult
maybe_summary <- HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> PkgQual
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map IsBootInterface
NotBoot
(SrcSpan -> ModuleName -> GenLocated SrcSpan ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
rootLoc ModuleName
modl) (UnitId -> PkgQual
ThisPkg (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit))
Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
case SummariseResult
maybe_summary of
FoundHome ModSummary
s -> Either (UnitId, DriverMessages) ModSummary
-> IO (Either (UnitId, DriverMessages) ModSummary)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> Either (UnitId, DriverMessages) ModSummary
forall a b. b -> Either a b
Right ModSummary
s)
FoundHomeWithError (UnitId, DriverMessages)
err -> Either (UnitId, DriverMessages) ModSummary
-> IO (Either (UnitId, DriverMessages) ModSummary)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary
forall a b. a -> Either a b
Left (UnitId, DriverMessages)
err)
SummariseResult
_ -> Either (UnitId, DriverMessages) ModSummary
-> IO (Either (UnitId, DriverMessages) ModSummary)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (UnitId, DriverMessages) ModSummary
-> IO (Either (UnitId, DriverMessages) ModSummary))
-> Either (UnitId, DriverMessages) ModSummary
-> IO (Either (UnitId, DriverMessages) ModSummary)
forall a b. (a -> b) -> a -> b
$ (UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary
forall a b. a -> Either a b
Left ((UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary)
-> (UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary
forall a b. (a -> b) -> a -> b
$ (UnitId
uid, ModuleName -> DriverMessages
moduleNotFoundErr ModuleName
modl)
where
home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"<command line>")
checkDuplicates
:: DownsweepCache
-> IO ()
checkDuplicates :: DownsweepCache -> IO ()
checkDuplicates DownsweepCache
root_map
| Bool
allow_dup_roots = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| [[ModSummary]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ModSummary]]
dup_roots = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [ModSummary] -> IO ()
multiRootsErr ([[ModSummary]] -> [ModSummary]
forall a. HasCallStack => [a] -> a
head [[ModSummary]]
dup_roots)
where
dup_roots :: [[ModSummary]]
dup_roots :: [[ModSummary]]
dup_roots = ([ModSummary] -> Bool) -> [[ModSummary]] -> [[ModSummary]]
forall a. (a -> Bool) -> [a] -> [a]
filterOut [ModSummary] -> Bool
forall a. [a] -> Bool
isSingleton ([[ModSummary]] -> [[ModSummary]])
-> [[ModSummary]] -> [[ModSummary]]
forall a b. (a -> b) -> a -> b
$ ([Either DriverMessages ModSummary] -> [ModSummary])
-> [[Either DriverMessages ModSummary]] -> [[ModSummary]]
forall a b. (a -> b) -> [a] -> [b]
map [Either DriverMessages ModSummary] -> [ModSummary]
forall a b. [Either a b] -> [b]
rights (DownsweepCache -> [[Either DriverMessages ModSummary]]
forall k a. Map k a -> [a]
M.elems DownsweepCache
root_map)
loopSummaries :: [ModSummary]
-> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),
DownsweepCache)
-> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)
loopSummaries :: [ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
DownsweepCache)
-> IO
(Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [] (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
done = (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
-> IO
(Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
done
loopSummaries (ModSummary
ms:[ModSummary]
next) (Map NodeKey ModuleGraphNode
done, Set (UnitId, UnitId)
pkgs, DownsweepCache
summarised)
| Just {} <- NodeKey -> Map NodeKey ModuleGraphNode -> Maybe ModuleGraphNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeKey
k Map NodeKey ModuleGraphNode
done
= [ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
DownsweepCache)
-> IO
(Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary]
next (Map NodeKey ModuleGraphNode
done, Set (UnitId, UnitId)
pkgs, DownsweepCache
summarised)
| Bool
otherwise = do
([NodeKey]
final_deps, Set (UnitId, UnitId)
pkgs1, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports (ModSummary
-> [(UnitId, PkgQual,
GenWithIsBoot (GenLocated SrcSpan ModuleName))]
calcDeps ModSummary
ms) Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
([NodeKey]
_, Set (UnitId, UnitId)
_, Map NodeKey ModuleGraphNode
done'', DownsweepCache
summarised'') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports (Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
-> [(UnitId, PkgQual,
GenWithIsBoot (GenLocated SrcSpan ModuleName))]
forall a. Maybe a -> [a]
maybeToList Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
hs_file_for_boot) Map NodeKey ModuleGraphNode
done' DownsweepCache
summarised'
[ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
DownsweepCache)
-> IO
(Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary]
next (NodeKey
-> ModuleGraphNode
-> Map NodeKey ModuleGraphNode
-> Map NodeKey ModuleGraphNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert NodeKey
k ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
final_deps ModSummary
ms) Map NodeKey ModuleGraphNode
done'', Set (UnitId, UnitId)
pkgs1 Set (UnitId, UnitId)
-> Set (UnitId, UnitId) -> Set (UnitId, UnitId)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (UnitId, UnitId)
pkgs, DownsweepCache
summarised'')
where
k :: NodeKey
k = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms)
hs_file_for_boot :: Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
hs_file_for_boot
| HscSource
HsBootFile <- ModSummary -> HscSource
ms_hsc_src ModSummary
ms = (UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
-> Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
forall a. a -> Maybe a
Just ((UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
-> Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName)))
-> (UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
-> Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
forall a b. (a -> b) -> a -> b
$ ((ModSummary -> UnitId
ms_unitid ModSummary
ms), PkgQual
NoPkgQual, (GenLocated SrcSpan ModuleName
-> IsBootInterface -> GenWithIsBoot (GenLocated SrcSpan ModuleName)
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleName -> GenLocated SrcSpan ModuleName
forall e. e -> Located e
noLoc (ModuleName -> GenLocated SrcSpan ModuleName)
-> ModuleName -> GenLocated SrcSpan ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
NotBoot))
| Bool
otherwise = Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
forall a. Maybe a
Nothing
loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> M.Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Set.Set (UnitId, UnitId),
M.Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports :: [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [] Map NodeKey ModuleGraphNode
done DownsweepCache
summarised = ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Set (UnitId, UnitId)
forall a. Set a
Set.empty, Map NodeKey ModuleGraphNode
done, DownsweepCache
summarised)
loopImports ((UnitId
home_uid,PkgQual
mb_pkg, GenWithIsBoot (GenLocated SrcSpan ModuleName)
gwib) : [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss) Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
| Just [Either DriverMessages ModSummary]
summs <- (UnitId, PkgQual, ModuleNameWithIsBoot)
-> DownsweepCache -> Maybe [Either DriverMessages ModSummary]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key DownsweepCache
summarised
= case [Either DriverMessages ModSummary]
summs of
[Right ModSummary
ms] -> do
let nk :: NodeKey
nk = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms)
([NodeKey]
rest, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
summarised', DownsweepCache
done') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeKey
nkNodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
: [NodeKey]
rest, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
summarised', DownsweepCache
done')
[Left DriverMessages
_err] ->
[(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
[Either DriverMessages ModSummary]
_errs -> do
[(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
| Bool
otherwise
= do
SummariseResult
mb_s <- HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> PkgQual
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map
IsBootInterface
is_boot GenLocated SrcSpan ModuleName
wanted_mod PkgQual
mb_pkg
Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing [ModuleName]
excl_mods
case SummariseResult
mb_s of
SummariseResult
NotThere -> [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
External UnitId
uid -> do
([NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NodeKey]
other_deps, (UnitId, UnitId) -> Set (UnitId, UnitId) -> Set (UnitId, UnitId)
forall a. Ord a => a -> Set a -> Set a
Set.insert (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit, UnitId
uid) Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised')
FoundInstantiation InstantiatedUnit
iud -> do
([NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
iud NodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
: [NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised')
FoundHomeWithError (UnitId
_uid, DriverMessages
e) -> [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done ((UnitId, PkgQual, ModuleNameWithIsBoot)
-> [Either DriverMessages ModSummary]
-> DownsweepCache
-> DownsweepCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key [(DriverMessages -> Either DriverMessages ModSummary
forall a b. a -> Either a b
Left DriverMessages
e)] DownsweepCache
summarised)
FoundHome ModSummary
s -> do
(Map NodeKey ModuleGraphNode
done', Set (UnitId, UnitId)
pkgs1, DownsweepCache
summarised') <-
[ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
DownsweepCache)
-> IO
(Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary
s] (Map NodeKey ModuleGraphNode
done, Set (UnitId, UnitId)
forall a. Set a
Set.empty, (UnitId, PkgQual, ModuleNameWithIsBoot)
-> [Either DriverMessages ModSummary]
-> DownsweepCache
-> DownsweepCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key [ModSummary -> Either DriverMessages ModSummary
forall a b. b -> Either a b
Right ModSummary
s] DownsweepCache
summarised)
([NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs2, Map NodeKey ModuleGraphNode
final_done, DownsweepCache
final_summarised) <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done' DownsweepCache
summarised'
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
s) NodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
: [NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs1 Set (UnitId, UnitId)
-> Set (UnitId, UnitId) -> Set (UnitId, UnitId)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (UnitId, UnitId)
pkgs2, Map NodeKey ModuleGraphNode
final_done, DownsweepCache
final_summarised)
where
cache_key :: (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key = (UnitId
home_uid, PkgQual
mb_pkg, GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan ModuleName -> ModuleName)
-> GenWithIsBoot (GenLocated SrcSpan ModuleName)
-> ModuleNameWithIsBoot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenWithIsBoot (GenLocated SrcSpan ModuleName)
gwib)
home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
home_uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
GWIB { gwib_mod :: forall mod. GenWithIsBoot mod -> mod
gwib_mod = L SrcSpan
loc ModuleName
mod, gwib_isBoot :: forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot = IsBootInterface
is_boot } = GenWithIsBoot (GenLocated SrcSpan ModuleName)
gwib
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
checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
checkHomeUnitsClosed :: UnitEnv -> Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
checkHomeUnitsClosed UnitEnv
ue Set UnitId
home_id_set [(UnitId, UnitId)]
home_imp_ids
| Set UnitId -> Int
forall a. Set a -> Int
Set.size Set UnitId
home_id_set Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = []
| Bool
otherwise =
let res :: Set UnitId
res = ((UnitId, UnitId) -> Set UnitId)
-> [(UnitId, UnitId)] -> Set UnitId
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (UnitId, UnitId) -> Set UnitId
loop [(UnitId, UnitId)]
home_imp_ids
bad_unit_ids :: Set UnitId
bad_unit_ids = Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set UnitId
res Set UnitId
home_id_set
in if Set UnitId -> Bool
forall a. Set a -> Bool
Set.null Set UnitId
bad_unit_ids
then []
else [MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
rootLoc (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ [UnitId] -> DriverMessage
DriverHomePackagesNotClosed (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
bad_unit_ids)]
where
rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"<command line>")
loop :: (UnitId, UnitId) -> Set.Set UnitId
loop :: (UnitId, UnitId) -> Set UnitId
loop (UnitId
from_uid, UnitId
uid) =
let us :: HomeUnitEnv
us = (() :: Constraint) => UnitId -> UnitEnv -> HomeUnitEnv
UnitId -> UnitEnv -> HomeUnitEnv
ue_findHomeUnitEnv UnitId
from_uid UnitEnv
ue in
let um :: UnitInfoMap
um = UnitState -> UnitInfoMap
unitInfoMap (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
us) in
case UnitId -> UnitInfoMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid UnitInfoMap
um of
Maybe UnitInfo
Nothing -> FilePath -> SDoc -> Set UnitId
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"uid not found" (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid)
Just UnitInfo
ui ->
let depends :: [UnitId]
depends = UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
ui
home_depends :: Set UnitId
home_depends = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
depends Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set UnitId
home_id_set
other_depends :: Set UnitId
other_depends = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
depends Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set UnitId
home_id_set
in
if Bool -> Bool
not (Set UnitId -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set UnitId
home_depends)
then
let res :: Set UnitId
res = (UnitId -> Set UnitId) -> Set UnitId -> Set UnitId
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((UnitId, UnitId) -> Set UnitId
loop ((UnitId, UnitId) -> Set UnitId)
-> (UnitId -> (UnitId, UnitId)) -> UnitId -> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId
from_uid,)) Set UnitId
other_depends
in UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.insert UnitId
uid Set UnitId
res
else
let res :: Set UnitId
res = (UnitId -> Set UnitId) -> Set UnitId -> Set UnitId
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((UnitId, UnitId) -> Set UnitId
loop ((UnitId, UnitId) -> Set UnitId)
-> (UnitId -> (UnitId, UnitId)) -> UnitId -> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId
from_uid,)) Set UnitId
other_depends
in
if Bool -> Bool
not (Set UnitId -> Bool
forall a. Set a -> Bool
Set.null Set UnitId
res)
then UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.insert UnitId
uid Set UnitId
res
else Set UnitId
res
enableCodeGenForTH
:: Logger
-> TmpFs
-> UnitEnv
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
enableCodeGenForTH :: Logger
-> TmpFs -> UnitEnv -> [ModuleGraphNode] -> IO [ModuleGraphNode]
enableCodeGenForTH Logger
logger TmpFs
tmpfs UnitEnv
unit_env =
Logger
-> TmpFs
-> TempFileLifetime
-> TempFileLifetime
-> UnitEnv
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
enableCodeGenWhen Logger
logger TmpFs
tmpfs TempFileLifetime
TFL_CurrentModule TempFileLifetime
TFL_GhcSession UnitEnv
unit_env
data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (CodeGenEnable -> CodeGenEnable -> Bool
(CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool) -> Eq CodeGenEnable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CodeGenEnable -> CodeGenEnable -> Bool
== :: CodeGenEnable -> CodeGenEnable -> Bool
$c/= :: CodeGenEnable -> CodeGenEnable -> Bool
/= :: CodeGenEnable -> CodeGenEnable -> Bool
Eq, Int -> CodeGenEnable -> FilePath -> FilePath
[CodeGenEnable] -> FilePath -> FilePath
CodeGenEnable -> FilePath
(Int -> CodeGenEnable -> FilePath -> FilePath)
-> (CodeGenEnable -> FilePath)
-> ([CodeGenEnable] -> FilePath -> FilePath)
-> Show CodeGenEnable
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> CodeGenEnable -> FilePath -> FilePath
showsPrec :: Int -> CodeGenEnable -> FilePath -> FilePath
$cshow :: CodeGenEnable -> FilePath
show :: CodeGenEnable -> FilePath
$cshowList :: [CodeGenEnable] -> FilePath -> FilePath
showList :: [CodeGenEnable] -> FilePath -> FilePath
Show, Eq CodeGenEnable
Eq CodeGenEnable =>
(CodeGenEnable -> CodeGenEnable -> Ordering)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> CodeGenEnable)
-> (CodeGenEnable -> CodeGenEnable -> CodeGenEnable)
-> Ord CodeGenEnable
CodeGenEnable -> CodeGenEnable -> Bool
CodeGenEnable -> CodeGenEnable -> Ordering
CodeGenEnable -> CodeGenEnable -> CodeGenEnable
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CodeGenEnable -> CodeGenEnable -> Ordering
compare :: CodeGenEnable -> CodeGenEnable -> Ordering
$c< :: CodeGenEnable -> CodeGenEnable -> Bool
< :: CodeGenEnable -> CodeGenEnable -> Bool
$c<= :: CodeGenEnable -> CodeGenEnable -> Bool
<= :: CodeGenEnable -> CodeGenEnable -> Bool
$c> :: CodeGenEnable -> CodeGenEnable -> Bool
> :: CodeGenEnable -> CodeGenEnable -> Bool
$c>= :: CodeGenEnable -> CodeGenEnable -> Bool
>= :: CodeGenEnable -> CodeGenEnable -> Bool
$cmax :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
max :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
$cmin :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
min :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
Ord)
instance Outputable CodeGenEnable where
ppr :: CodeGenEnable -> SDoc
ppr = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath -> SDoc)
-> (CodeGenEnable -> FilePath) -> CodeGenEnable -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenEnable -> FilePath
forall a. Show a => a -> FilePath
show
enableCodeGenWhen
:: Logger
-> TmpFs
-> TempFileLifetime
-> TempFileLifetime
-> UnitEnv
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
enableCodeGenWhen :: Logger
-> TmpFs
-> TempFileLifetime
-> TempFileLifetime
-> UnitEnv
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
enableCodeGenWhen Logger
logger TmpFs
tmpfs TempFileLifetime
staticLife TempFileLifetime
dynLife UnitEnv
unit_env [ModuleGraphNode]
mod_graph =
(ModuleGraphNode -> IO ModuleGraphNode)
-> [ModuleGraphNode] -> IO [ModuleGraphNode]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen [ModuleGraphNode]
mod_graph
where
defaultBackendOf :: ModSummary -> Backend
defaultBackendOf ModSummary
ms = Platform -> Backend
platformDefaultBackend (DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> DynFlags -> Platform
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => UnitId -> UnitEnv -> DynFlags
UnitId -> UnitEnv -> DynFlags
ue_unitFlags (ModSummary -> UnitId
ms_unitid ModSummary
ms) UnitEnv
unit_env)
enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen n :: ModuleGraphNode
n@(ModuleNode [NodeKey]
deps ModSummary
ms)
| ModSummary
{ ms_location :: ModSummary -> ModLocation
ms_location = ModLocation
ms_location
, ms_hsc_src :: ModSummary -> HscSource
ms_hsc_src = HscSource
HsSrcFile
, ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags
} <- ModSummary
ms
, Just CodeGenEnable
enable_spec <- ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
n NodeKey -> Map NodeKey CodeGenEnable -> Maybe CodeGenEnable
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map NodeKey CodeGenEnable
needs_codegen_map =
if | ModSummary -> Bool
nocode_enable ModSummary
ms -> do
let new_temp_file :: FilePath -> FilePath -> IO (FilePath, FilePath)
new_temp_file FilePath
suf FilePath
dynsuf = do
FilePath
tn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
staticLife FilePath
suf
let dyn_tn :: FilePath
dyn_tn = FilePath
tn FilePath -> FilePath -> FilePath
-<.> FilePath
dynsuf
TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
dynLife [FilePath
dyn_tn]
return (FilePath
tn, FilePath
dyn_tn)
((FilePath
hi_file, FilePath
dyn_hi_file), (FilePath
o_file, FilePath
dyn_o_file)) <-
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
then ((FilePath, FilePath), (FilePath, FilePath))
-> IO ((FilePath, FilePath), (FilePath, FilePath))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ModLocation -> FilePath
ml_hi_file ModLocation
ms_location, ModLocation -> FilePath
ml_dyn_hi_file ModLocation
ms_location)
, (ModLocation -> FilePath
ml_obj_file ModLocation
ms_location, ModLocation -> FilePath
ml_dyn_obj_file ModLocation
ms_location))
else (,) ((FilePath, FilePath)
-> (FilePath, FilePath)
-> ((FilePath, FilePath), (FilePath, FilePath)))
-> IO (FilePath, FilePath)
-> IO
((FilePath, FilePath)
-> ((FilePath, FilePath), (FilePath, FilePath)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> IO (FilePath, FilePath)
new_temp_file (DynFlags -> FilePath
hiSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynHiSuf_ DynFlags
dflags))
IO
((FilePath, FilePath)
-> ((FilePath, FilePath), (FilePath, FilePath)))
-> IO (FilePath, FilePath)
-> IO ((FilePath, FilePath), (FilePath, FilePath))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> FilePath -> IO (FilePath, FilePath)
new_temp_file (DynFlags -> FilePath
objectSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynObjectSuf_ DynFlags
dflags))
let new_dflags :: DynFlags
new_dflags = case CodeGenEnable
enable_spec of
CodeGenEnable
EnableByteCode -> DynFlags
dflags { backend = interpreterBackend }
CodeGenEnable
EnableObject -> DynFlags
dflags { backend = defaultBackendOf ms }
CodeGenEnable
EnableByteCodeAndObject -> (DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags GeneralFlag
Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}
let ms' :: ModSummary
ms' = ModSummary
ms
{ ms_location =
ms_location { ml_hi_file = hi_file
, ml_obj_file = o_file
, ml_dyn_hi_file = dyn_hi_file
, ml_dyn_obj_file = dyn_o_file }
, ms_hspp_opts = updOptLevel 0 $ new_dflags
}
ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')
| CodeGenEnable -> ModSummary -> Bool
bytecode_and_enable CodeGenEnable
enable_spec ModSummary
ms -> do
let ms' :: ModSummary
ms' = ModSummary
ms
{ ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode
}
ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')
| CodeGenEnable -> ModSummary -> Bool
dynamic_too_enable CodeGenEnable
enable_spec ModSummary
ms -> do
let ms' :: ModSummary
ms' = ModSummary
ms
{ ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo
}
ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')
| ModSummary -> Bool
ext_interp_enable ModSummary
ms -> do
let ms' :: ModSummary
ms' = ModSummary
ms
{ ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter
}
ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')
| Bool
otherwise -> ModuleGraphNode -> IO ModuleGraphNode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleGraphNode
n
enable_code_gen ModuleGraphNode
ms = ModuleGraphNode -> IO ModuleGraphNode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleGraphNode
ms
nocode_enable :: ModSummary -> Bool
nocode_enable ms :: ModSummary
ms@(ModSummary { ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags }) =
Bool -> Bool
not (Backend -> Bool
backendGeneratesCode (DynFlags -> Backend
backend DynFlags
dflags)) Bool -> Bool -> Bool
&&
HomeUnit -> Bool
forall u. GenHomeUnit u -> Bool
isHomeUnitDefinite (UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit (ModSummary -> UnitId
ms_unitid ModSummary
ms) UnitEnv
unit_env)
bytecode_and_enable :: CodeGenEnable -> ModSummary -> Bool
bytecode_and_enable CodeGenEnable
enable_spec ModSummary
ms =
CodeGenEnable -> ModSummary -> Bool
dynamic_too_enable CodeGenEnable
EnableObject ModSummary
ms
Bool -> Bool -> Bool
&& Bool
prefer_bytecode
Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
generate_both
where
lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
prefer_bytecode :: Bool
prefer_bytecode = case CodeGenEnable
enable_spec of
CodeGenEnable
EnableByteCodeAndObject -> Bool
True
CodeGenEnable
EnableByteCode -> Bool
True
CodeGenEnable
EnableObject -> Bool
False
generate_both :: Bool
generate_both = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ByteCodeAndObjectCode DynFlags
lcl_dflags
dynamic_too_enable :: CodeGenEnable -> ModSummary -> Bool
dynamic_too_enable CodeGenEnable
enable_spec ModSummary
ms
= Bool
hostIsDynamic Bool -> Bool -> Bool
&& Bool
internalInterpreter Bool -> Bool -> Bool
&&
Bool -> Bool
not Bool
isDynWay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isProfWay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
dyn_too_enabled
Bool -> Bool -> Bool
&& Bool
enable_object
where
lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
internalInterpreter :: Bool
internalInterpreter = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
lcl_dflags)
dyn_too_enabled :: Bool
dyn_too_enabled = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildDynamicToo DynFlags
lcl_dflags
isDynWay :: Bool
isDynWay = Ways -> Way -> Bool
hasWay (DynFlags -> Ways
ways DynFlags
lcl_dflags) Way
WayDyn
isProfWay :: Bool
isProfWay = Ways -> Way -> Bool
hasWay (DynFlags -> Ways
ways DynFlags
lcl_dflags) Way
WayProf
enable_object :: Bool
enable_object = case CodeGenEnable
enable_spec of
CodeGenEnable
EnableByteCode -> Bool
False
CodeGenEnable
EnableByteCodeAndObject -> Bool
True
CodeGenEnable
EnableObject -> Bool
True
ext_interp_enable :: ModSummary -> Bool
ext_interp_enable ModSummary
ms = Bool -> Bool
not Bool
ghciSupported Bool -> Bool -> Bool
&& Bool
internalInterpreter
where
lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
internalInterpreter :: Bool
internalInterpreter = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
lcl_dflags)
(Graph SummaryNode
mg, NodeKey -> Maybe SummaryNode
lookup_node) = Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
False [ModuleGraphNode]
mod_graph
mk_needed_set :: [NodeKey] -> Set NodeKey
mk_needed_set [NodeKey]
roots = [NodeKey] -> Set NodeKey
forall a. Ord a => [a] -> Set a
Set.fromList ([NodeKey] -> Set NodeKey) -> [NodeKey] -> Set NodeKey
forall a b. (a -> b) -> a -> b
$ (SummaryNode -> NodeKey) -> [SummaryNode] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleGraphNode -> NodeKey
mkNodeKey (ModuleGraphNode -> NodeKey)
-> (SummaryNode -> ModuleGraphNode) -> SummaryNode -> NodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SummaryNode -> ModuleGraphNode
forall key payload. Node key payload -> payload
node_payload) ([SummaryNode] -> [NodeKey]) -> [SummaryNode] -> [NodeKey]
forall a b. (a -> b) -> a -> b
$ Graph SummaryNode -> [SummaryNode] -> [SummaryNode]
forall node. Graph node -> [node] -> [node]
reachablesG Graph SummaryNode
mg ((NodeKey -> SummaryNode) -> [NodeKey] -> [SummaryNode]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe SummaryNode -> SummaryNode
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"needs_th" (Maybe SummaryNode -> SummaryNode)
-> (NodeKey -> Maybe SummaryNode) -> NodeKey -> SummaryNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> Maybe SummaryNode
lookup_node) [NodeKey]
roots)
needs_obj_set, needs_bc_set :: Set.Set NodeKey
needs_obj_set :: Set NodeKey
needs_obj_set = [NodeKey] -> Set NodeKey
mk_needed_set [NodeKey]
need_obj_set
needs_bc_set :: Set NodeKey
needs_bc_set = [NodeKey] -> Set NodeKey
mk_needed_set [NodeKey]
need_bc_set
needs_codegen_map :: Map.Map NodeKey CodeGenEnable
needs_codegen_map :: Map NodeKey CodeGenEnable
needs_codegen_map =
(CodeGenEnable -> CodeGenEnable -> CodeGenEnable)
-> Map NodeKey CodeGenEnable
-> Map NodeKey CodeGenEnable
-> Map NodeKey CodeGenEnable
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\CodeGenEnable
_ CodeGenEnable
_ -> CodeGenEnable
EnableByteCodeAndObject)
([(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable)
-> [(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable
forall a b. (a -> b) -> a -> b
$ [(NodeKey
m, CodeGenEnable
EnableObject) | NodeKey
m <- Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
Set.toList Set NodeKey
needs_obj_set])
([(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable)
-> [(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable
forall a b. (a -> b) -> a -> b
$ [(NodeKey
m, CodeGenEnable
EnableByteCode) | NodeKey
m <- Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
Set.toList Set NodeKey
needs_bc_set])
need_obj_set :: [NodeKey]
need_obj_set =
[[NodeKey]] -> [NodeKey]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [NodeKey]
deps
| (ModuleNode [NodeKey]
deps ModSummary
ms) <- [ModuleGraphNode]
mod_graph
, ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms
, Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_UseBytecodeRatherThanObjects (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms))
]
need_bc_set :: [NodeKey]
need_bc_set =
[[NodeKey]] -> [NodeKey]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [NodeKey]
deps
| (ModuleNode [NodeKey]
deps ModSummary
ms) <- [ModuleGraphNode]
mod_graph
, ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms
, GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_UseBytecodeRatherThanObjects (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms)
]
mkRootMap
:: [ModSummary]
-> DownsweepCache
mkRootMap :: [ModSummary] -> DownsweepCache
mkRootMap [ModSummary]
summaries = ([Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary])
-> [((UnitId, PkgQual, ModuleNameWithIsBoot),
[Either DriverMessages ModSummary])]
-> DownsweepCache
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (([Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary])
-> [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
forall a. [a] -> [a] -> [a]
(++))
[ ((ModSummary -> UnitId
ms_unitid ModSummary
s, PkgQual
NoPkgQual, ModSummary -> ModuleNameWithIsBoot
ms_mnwib ModSummary
s), [ModSummary -> Either DriverMessages ModSummary
forall a b. b -> Either a b
Right ModSummary
s]) | ModSummary
s <- [ModSummary]
summaries ]
summariseFile
:: HscEnv
-> HomeUnit
-> M.Map (UnitId, FilePath) ModSummary
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer,UTCTime)
-> IO (Either DriverMessages ModSummary)
summariseFile :: HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either DriverMessages ModSummary)
summariseFile HscEnv
hsc_env' HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summaries FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf
| Just ModSummary
old_summary <- (UnitId, FilePath)
-> Map (UnitId, FilePath) ModSummary -> Maybe ModSummary
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit, FilePath
src_fn) Map (UnitId, FilePath) ModSummary
old_summaries
= do
let location :: ModLocation
location = ModSummary -> ModLocation
ms_location (ModSummary -> ModLocation) -> ModSummary -> ModLocation
forall a b. (a -> b) -> a -> b
$ ModSummary
old_summary
Fingerprint
src_hash <- IO Fingerprint
get_src_hash
HscEnv
-> (Fingerprint -> IO (Either DriverMessages ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash
HscEnv
hsc_env (FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn)
ModSummary
old_summary ModLocation
location Fingerprint
src_hash
| Bool
otherwise
= do Fingerprint
src_hash <- IO Fingerprint
get_src_hash
FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn Fingerprint
src_hash
where
hsc_env :: HscEnv
hsc_env = (() :: Constraint) => HomeUnit -> HscEnv -> HscEnv
HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit HscEnv
hsc_env'
get_src_hash :: IO Fingerprint
get_src_hash = case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
Just (InputFileBuffer
buf,UTCTime
_) -> Fingerprint -> IO Fingerprint
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint -> IO Fingerprint) -> Fingerprint -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ InputFileBuffer -> Fingerprint
fingerprintStringBuffer InputFileBuffer
buf
Maybe (InputFileBuffer, UTCTime)
Nothing -> IO Fingerprint -> IO Fingerprint
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> IO Fingerprint)
-> IO Fingerprint -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Fingerprint
getFileHash FilePath
src_fn
new_summary :: FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn Fingerprint
src_hash = ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary))
-> ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ do
preimps :: PreprocessedImports
preimps@PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
ModuleName
InputFileBuffer
SrcSpan
DynFlags
pi_local_dflags :: DynFlags
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_ghc_prim_import :: Bool
pi_hspp_fn :: FilePath
pi_hspp_buf :: InputFileBuffer
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
pi_local_dflags :: PreprocessedImports -> DynFlags
pi_srcimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_ghc_prim_import :: PreprocessedImports -> Bool
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_mod_name :: PreprocessedImports -> ModuleName
..}
<- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf
let fopts :: FinderOpts
fopts = DynFlags -> FinderOpts
initFinderOpts (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
let location :: ModLocation
location = FinderOpts -> ModuleName -> FilePath -> ModLocation
mkHomeModLocation FinderOpts
fopts ModuleName
pi_mod_name FilePath
src_fn
Module
mod <- IO Module -> ExceptT DriverMessages IO Module
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> ExceptT DriverMessages IO Module)
-> IO Module -> ExceptT DriverMessages IO Module
forall a b. (a -> b) -> a -> b
$ do
let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
let fc :: FinderCache
fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder FinderCache
fc HomeUnit
home_unit ModuleName
pi_mod_name ModLocation
location
IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> ExceptT DriverMessages IO ModSummary)
-> IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env (MakeNewModSummary -> IO ModSummary)
-> MakeNewModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
{ nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
, nms_src_hash :: Fingerprint
nms_src_hash = Fingerprint
src_hash
, nms_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_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
}
checkSummaryHash
:: HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary -> ModLocation -> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash :: forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash
HscEnv
hsc_env Fingerprint -> IO (Either e ModSummary)
new_summary
ModSummary
old_summary
ModLocation
location Fingerprint
src_hash
| ModSummary -> Fingerprint
ms_hs_hash ModSummary
old_summary Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
src_hash Bool -> Bool -> Bool
&&
Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) = do
Maybe UTCTime
obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_obj_file ModLocation
location)
()
_ <- do
let fc :: FinderCache
fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
case ModSummary -> HscSource
ms_hsc_src ModSummary
old_summary of
HscSource
HsSrcFile -> FinderCache -> Module -> ModLocation -> IO ()
addModuleToFinder FinderCache
fc (ModSummary -> Module
ms_mod ModSummary
old_summary) ModLocation
location
HscSource
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe UTCTime
hi_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
location)
Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
location)
return $ ModSummary -> Either e ModSummary
forall a b. b -> Either a b
Right
( ModSummary
old_summary
{ ms_obj_date = obj_timestamp
, ms_iface_date = hi_timestamp
, ms_hie_date = hie_timestamp
}
)
| Bool
otherwise =
Fingerprint -> IO (Either e ModSummary)
new_summary Fingerprint
src_hash
data SummariseResult =
FoundInstantiation InstantiatedUnit
| FoundHomeWithError (UnitId, DriverMessages)
| FoundHome ModSummary
| External UnitId
| NotThere
summariseModule
:: HscEnv
-> HomeUnit
-> M.Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule :: HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> PkgQual
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env' HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map IsBootInterface
is_boot (L SrcSpan
_ ModuleName
wanted_mod) PkgQual
mb_pkg
Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
| ModuleName
wanted_mod ModuleName -> [ModuleName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
excl_mods
= SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
| Bool
otherwise = IO SummariseResult
find_it
where
hsc_env :: HscEnv
hsc_env = (() :: Constraint) => HomeUnit -> HscEnv -> HscEnv
HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit HscEnv
hsc_env'
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
find_it :: IO SummariseResult
find_it :: IO SummariseResult
find_it = do
FindResult
found <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
wanted_mod PkgQual
mb_pkg
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) ->
ModLocation -> Module -> IO SummariseResult
just_found ModLocation
location Module
mod
| VirtUnit InstantiatedUnit
iud <- Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit Module
mod
, Bool -> Bool
not (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
mod)
-> SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SummariseResult -> IO SummariseResult)
-> SummariseResult -> IO SummariseResult
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> SummariseResult
FoundInstantiation InstantiatedUnit
iud
| Bool
otherwise -> SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SummariseResult -> IO SummariseResult)
-> SummariseResult -> IO SummariseResult
forall a b. (a -> b) -> a -> b
$ UnitId -> SummariseResult
External (Module -> UnitId
moduleUnitId Module
mod)
FindResult
_ -> SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
just_found :: ModLocation -> Module -> IO SummariseResult
just_found ModLocation
location Module
mod = do
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')
Maybe Fingerprint
maybe_h <- FilePath -> IO (Maybe Fingerprint)
fileHashIfExists FilePath
src_fn
case Maybe Fingerprint
maybe_h of
Maybe Fingerprint
Nothing -> SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
Just Fingerprint
h -> do
Either DriverMessages ModSummary
fresult <- ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary_cache_check ModLocation
location' Module
mod FilePath
src_fn Fingerprint
h
return $ case Either DriverMessages ModSummary
fresult of
Left DriverMessages
err -> (UnitId, DriverMessages) -> SummariseResult
FoundHomeWithError (Module -> UnitId
moduleUnitId Module
mod, DriverMessages
err)
Right ModSummary
ms -> ModSummary -> SummariseResult
FoundHome ModSummary
ms
new_summary_cache_check :: ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary_cache_check ModLocation
loc Module
mod FilePath
src_fn Fingerprint
h
| Just ModSummary
old_summary <- (UnitId, FilePath)
-> Map (UnitId, FilePath) ModSummary -> Maybe ModSummary
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((GenUnit UnitId -> UnitId
toUnitId (Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit Module
mod), FilePath
src_fn)) Map (UnitId, FilePath) ModSummary
old_summary_map =
case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
Just (InputFileBuffer
buf,UTCTime
_) ->
HscEnv
-> (Fingerprint -> IO (Either DriverMessages ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash HscEnv
hsc_env (ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn) ModSummary
old_summary ModLocation
loc (InputFileBuffer -> Fingerprint
fingerprintStringBuffer InputFileBuffer
buf)
Maybe (InputFileBuffer, UTCTime)
Nothing ->
HscEnv
-> (Fingerprint -> IO (Either DriverMessages ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash HscEnv
hsc_env (ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn) ModSummary
old_summary ModLocation
loc Fingerprint
h
| Bool
otherwise = ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn Fingerprint
h
new_summary :: ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary :: ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
location Module
mod FilePath
src_fn Fingerprint
src_hash
= ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary))
-> ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ do
preimps :: PreprocessedImports
preimps@PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
ModuleName
InputFileBuffer
SrcSpan
DynFlags
pi_local_dflags :: PreprocessedImports -> DynFlags
pi_srcimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_ghc_prim_import :: PreprocessedImports -> Bool
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_mod_name :: PreprocessedImports -> ModuleName
pi_local_dflags :: DynFlags
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_ghc_prim_import :: Bool
pi_hspp_fn :: FilePath
pi_hspp_buf :: InputFileBuffer
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
..}
<- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports ((() :: Constraint) => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (Module -> UnitId
moduleUnitId Module
mod) HscEnv
hsc_env) FilePath
src_fn Maybe Phase
forall a. Maybe a
Nothing Maybe (InputFileBuffer, UTCTime)
maybe_buf
let hsc_src :: HscSource
hsc_src
| IsBootInterface
is_boot IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot = HscSource
HsBootFile
| FilePath -> Bool
isHaskellSigFilename FilePath
src_fn = HscSource
HsigFile
| Bool
otherwise = HscSource
HsSrcFile
Bool
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
pi_mod_name ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleName
wanted_mod) (ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ())
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$
DriverMessages -> ExceptT DriverMessages IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DriverMessages -> ExceptT DriverMessages IO ())
-> DriverMessages -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
pi_mod_name_loc
(DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleName -> DriverMessage
DriverFileModuleNameMismatch ModuleName
pi_mod_name ModuleName
wanted_mod
let instantiations :: GenInstantiations UnitId
instantiations = HomeUnit -> GenInstantiations UnitId
forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit
Bool
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& Maybe Module -> Bool
forall a. Maybe a -> Bool
isNothing (ModuleName -> GenInstantiations UnitId -> Maybe Module
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
pi_mod_name GenInstantiations UnitId
instantiations)) (ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ())
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$
DriverMessages -> ExceptT DriverMessages IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DriverMessages -> ExceptT DriverMessages IO ())
-> DriverMessages -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
pi_mod_name_loc
(DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ ModuleName
-> BuildingCabalPackage
-> GenInstantiations UnitId
-> DriverMessage
DriverUnexpectedSignature ModuleName
pi_mod_name (DynFlags -> BuildingCabalPackage
checkBuildingCabalPackage DynFlags
dflags) GenInstantiations UnitId
instantiations
IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> ExceptT DriverMessages IO ModSummary)
-> IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env (MakeNewModSummary -> IO ModSummary)
-> MakeNewModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
{ nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
, nms_src_hash :: Fingerprint
nms_src_hash = Fingerprint
src_hash
, nms_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_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
}
data MakeNewModSummary
= MakeNewModSummary
{ MakeNewModSummary -> FilePath
nms_src_fn :: FilePath
, MakeNewModSummary -> Fingerprint
nms_src_hash :: Fingerprint
, MakeNewModSummary -> IsBootInterface
nms_is_boot :: IsBootInterface
, MakeNewModSummary -> HscSource
nms_hsc_src :: HscSource
, MakeNewModSummary -> ModLocation
nms_location :: ModLocation
, MakeNewModSummary -> Module
nms_mod :: Module
, MakeNewModSummary -> PreprocessedImports
nms_preimps :: PreprocessedImports
}
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env MakeNewModSummary{FilePath
Fingerprint
IsBootInterface
Module
ModLocation
HscSource
PreprocessedImports
nms_src_fn :: MakeNewModSummary -> FilePath
nms_src_hash :: MakeNewModSummary -> Fingerprint
nms_is_boot :: MakeNewModSummary -> IsBootInterface
nms_hsc_src :: MakeNewModSummary -> HscSource
nms_location :: MakeNewModSummary -> ModLocation
nms_mod :: MakeNewModSummary -> Module
nms_preimps :: MakeNewModSummary -> PreprocessedImports
nms_src_fn :: FilePath
nms_src_hash :: Fingerprint
nms_is_boot :: IsBootInterface
nms_hsc_src :: HscSource
nms_location :: ModLocation
nms_mod :: Module
nms_preimps :: PreprocessedImports
..} = do
let PreprocessedImports{Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
ModuleName
InputFileBuffer
SrcSpan
DynFlags
pi_local_dflags :: PreprocessedImports -> DynFlags
pi_srcimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_ghc_prim_import :: PreprocessedImports -> Bool
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_mod_name :: PreprocessedImports -> ModuleName
pi_local_dflags :: DynFlags
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_ghc_prim_import :: Bool
pi_hspp_fn :: FilePath
pi_hspp_buf :: InputFileBuffer
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
..} = PreprocessedImports
nms_preimps
Maybe UTCTime
obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_obj_file ModLocation
nms_location)
Maybe UTCTime
dyn_obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_dyn_obj_file ModLocation
nms_location)
Maybe UTCTime
hi_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
nms_location)
Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
nms_location)
[ModuleName]
extra_sig_imports <- HscEnv -> HscSource -> ModuleName -> IO [ModuleName]
findExtraSigImports HscEnv
hsc_env HscSource
nms_hsc_src ModuleName
pi_mod_name
([ModuleName]
implicit_sigs, [InstantiatedUnit]
_inst_deps) <- HscEnv
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow ((() :: Constraint) => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (Module -> UnitId
moduleUnitId Module
nms_mod) HscEnv
hsc_env) [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps
return $
ModSummary
{ ms_mod :: Module
ms_mod = Module
nms_mod
, ms_hsc_src :: HscSource
ms_hsc_src = HscSource
nms_hsc_src
, ms_location :: ModLocation
ms_location = ModLocation
nms_location
, ms_hspp_file :: FilePath
ms_hspp_file = FilePath
pi_hspp_fn
, ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
pi_local_dflags
, ms_hspp_buf :: Maybe 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 :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_srcimps = [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps
, ms_ghc_prim_import :: Bool
ms_ghc_prim_import = Bool
pi_ghc_prim_import
, ms_textual_imps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_textual_imps =
((,) PkgQual
NoPkgQual (GenLocated SrcSpan ModuleName
-> (PkgQual, GenLocated SrcSpan ModuleName))
-> (ModuleName -> GenLocated SrcSpan ModuleName)
-> ModuleName
-> (PkgQual, GenLocated SrcSpan ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> GenLocated SrcSpan ModuleName
forall e. e -> Located e
noLoc (ModuleName -> (PkgQual, GenLocated SrcSpan ModuleName))
-> [ModuleName] -> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
extra_sig_imports) [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++
((,) PkgQual
NoPkgQual (GenLocated SrcSpan ModuleName
-> (PkgQual, GenLocated SrcSpan ModuleName))
-> (ModuleName -> GenLocated SrcSpan ModuleName)
-> ModuleName
-> (PkgQual, GenLocated SrcSpan ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> GenLocated SrcSpan ModuleName
forall e. e -> Located e
noLoc (ModuleName -> (PkgQual, GenLocated SrcSpan ModuleName))
-> [ModuleName] -> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
implicit_sigs) [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++
[(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps
, ms_hs_hash :: Fingerprint
ms_hs_hash = Fingerprint
nms_src_hash
, ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
, ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
, ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
, ms_dyn_obj_date :: Maybe UTCTime
ms_dyn_obj_date = Maybe UTCTime
dyn_obj_timestamp
}
data PreprocessedImports
= PreprocessedImports
{ PreprocessedImports -> DynFlags
pi_local_dflags :: DynFlags
, PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, Located ModuleName)]
, PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(PkgQual, Located ModuleName)]
, PreprocessedImports -> Bool
pi_ghc_prim_import :: Bool
, 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
}
getPreprocessedImports
:: HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports :: HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT DriverMessages 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 DriverMessages (DynFlags, FilePath))
-> ExceptT DriverMessages IO (DynFlags, FilePath)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either DriverMessages (DynFlags, FilePath))
-> ExceptT DriverMessages IO (DynFlags, FilePath))
-> IO (Either DriverMessages (DynFlags, FilePath))
-> ExceptT DriverMessages IO (DynFlags, FilePath)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either DriverMessages (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 DriverMessages IO InputFileBuffer
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InputFileBuffer -> ExceptT DriverMessages IO InputFileBuffer)
-> IO InputFileBuffer -> ExceptT DriverMessages IO InputFileBuffer
forall a b. (a -> b) -> a -> b
$ FilePath -> IO InputFileBuffer
hGetStringBuffer FilePath
pi_hspp_fn
([(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps', [(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps', Bool
pi_ghc_prim_import, L SrcSpan
pi_mod_name_loc ModuleName
pi_mod_name)
<- IO
(Either
DriverMessages
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName))
-> ExceptT
DriverMessages
IO
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO
(Either
DriverMessages
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName))
-> ExceptT
DriverMessages
IO
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName))
-> IO
(Either
DriverMessages
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName))
-> ExceptT
DriverMessages
IO
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
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
(Messages PsMessage)
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName)
mimps <- ParserOpts
-> Bool
-> InputFileBuffer
-> FilePath
-> FilePath
-> IO
(Either
(Messages PsMessage)
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName))
getImports ParserOpts
popts Bool
imp_prelude InputFileBuffer
pi_hspp_buf FilePath
pi_hspp_fn FilePath
src_fn
return ((Messages PsMessage -> DriverMessages)
-> Either
(Messages PsMessage)
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName)
-> Either
DriverMessages
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Bag (MsgEnvelope DriverMessage) -> DriverMessages
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope DriverMessage) -> DriverMessages)
-> (Messages PsMessage -> Bag (MsgEnvelope DriverMessage))
-> Messages PsMessage
-> DriverMessages
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgEnvelope PsMessage -> MsgEnvelope DriverMessage)
-> Bag (MsgEnvelope PsMessage) -> Bag (MsgEnvelope DriverMessage)
forall a b. (a -> b) -> Bag a -> Bag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
mkDriverPsHeaderMessage (Bag (MsgEnvelope PsMessage) -> Bag (MsgEnvelope DriverMessage))
-> (Messages PsMessage -> Bag (MsgEnvelope PsMessage))
-> Messages PsMessage
-> Bag (MsgEnvelope DriverMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages PsMessage -> Bag (MsgEnvelope PsMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages) Either
(Messages PsMessage)
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName)
mimps)
let rn_pkg_qual :: ModuleName -> RawPkgQual -> PkgQual
rn_pkg_qual = UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
renameRawPkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
let rn_imps :: [(RawPkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
rn_imps = ((RawPkgQual, GenLocated SrcSpan ModuleName)
-> (PkgQual, GenLocated SrcSpan ModuleName))
-> [(RawPkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(RawPkgQual
pk, lmn :: GenLocated SrcSpan ModuleName
lmn@(L SrcSpan
_ ModuleName
mn)) -> (ModuleName -> RawPkgQual -> PkgQual
rn_pkg_qual ModuleName
mn RawPkgQual
pk, GenLocated SrcSpan ModuleName
lmn))
let pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps = [(RawPkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
rn_imps [(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps'
let pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps = [(RawPkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
rn_imps [(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps'
PreprocessedImports
-> ExceptT DriverMessages IO PreprocessedImports
forall a. a -> ExceptT DriverMessages IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
ModuleName
InputFileBuffer
SrcSpan
DynFlags
pi_local_dflags :: DynFlags
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_ghc_prim_import :: Bool
pi_hspp_fn :: FilePath
pi_hspp_buf :: InputFileBuffer
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
pi_local_dflags :: DynFlags
pi_hspp_fn :: FilePath
pi_hspp_buf :: InputFileBuffer
pi_ghc_prim_import :: Bool
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
..}
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 a. IO a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
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 :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
deferDiagnostics LogFlags
_dflags !MessageClass
msgClass !SrcSpan
srcSpan !SDoc
msg = do
let action :: IO ()
action = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
msgClass SrcSpan
srcSpan SDoc
msg
case MessageClass
msgClass of
MCDiagnostic Severity
SevWarning DiagnosticReason
_reason Maybe DiagnosticCode
_code
-> 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, ())
MCDiagnostic Severity
SevError DiagnosticReason
_reason Maybe DiagnosticCode
_code
-> 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, ())
MessageClass
MCFatal
-> 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, ())
MessageClass
_ -> IO ()
action
printDeferredDiagnostics :: m ()
printDeferredDiagnostics = IO () -> m ()
forall a. IO a -> m a
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
let landmine :: [a]
landmine = if Bool
debugIsOn then FilePath -> [a]
forall a. HasCallStack => FilePath -> a
panic FilePath
"withDeferredDiagnostics: use after free" else []
[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 ()]
forall a. [a]
landmine, [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.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket
(((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> m ()
forall (m :: * -> *).
GhcMonad m =>
((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> m ()
pushLogHookM ((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> (LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags
-> MessageClass
-> SrcSpan
-> SDoc
-> IO ()
forall a b. a -> b -> a
const LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
deferDiagnostics))
(\()
_ -> m ()
forall (m :: * -> *). GhcMonad m => m ()
popLogHookM m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
printDeferredDiagnostics)
(\()
_ -> m a
f)
noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
noModError :: HscEnv
-> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
noModError HscEnv
hsc_env SrcSpan
loc ModuleName
wanted_mod FindResult
err
= SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$
UnknownDiagnostic -> DriverMessage
DriverUnknownMessage (UnknownDiagnostic -> DriverMessage)
-> UnknownDiagnostic -> DriverMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> UnknownDiagnostic
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic (DiagnosticMessage -> UnknownDiagnostic)
-> DiagnosticMessage -> UnknownDiagnostic
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
hsc_env ModuleName
wanted_mod FindResult
err
moduleNotFoundErr :: ModuleName -> DriverMessages
moduleNotFoundErr :: ModuleName -> DriverMessages
moduleNotFoundErr ModuleName
mod = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (ModuleName -> DriverMessage
DriverModuleNotFound ModuleName
mod)
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
panic FilePath
"multiRootsErr"
multiRootsErr summs :: [ModSummary]
summs@(ModSummary
summ1:[ModSummary]
_)
= MsgEnvelope GhcMessage -> IO ()
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO ())
-> MsgEnvelope GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ (DriverMessage -> GhcMessage)
-> MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage (MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage)
-> MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ Module -> [FilePath] -> DriverMessage
DriverDuplicatedModuleDeclaration Module
mod [FilePath]
files
where
mod :: Module
mod = 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
cyclicModuleErr :: [ModuleGraphNode] -> SDoc
cyclicModuleErr :: [ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
mss
= Bool -> SDoc -> SDoc
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([ModuleGraphNode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleGraphNode]
mss)) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
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
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Unexpected non-cycle" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ModuleGraphNode] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleGraphNode]
mss
Just [ModuleGraphNode]
path0 -> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Module graph contains 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 = Bool -> ModuleGraphNode -> [NodeKey]
nodeDependencies Bool
False ModuleGraphNode
ms
}
| ModuleGraphNode
ms <- [ModuleGraphNode]
mss
]
show_path :: [ModuleGraphNode] -> SDoc
show_path :: [ModuleGraphNode] -> SDoc
show_path [] = FilePath -> SDoc
forall a. HasCallStack => FilePath -> a
panic FilePath
"show_path"
show_path [ModuleGraphNode
m] = ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"imports itself"
show_path (ModuleGraphNode
m1:ModuleGraphNode
m2:[ModuleGraphNode]
ms) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsLine doc => FilePath -> doc
text FilePath
"imports" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsLine doc => FilePath -> doc
text FilePath
"which imports" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m1]
go (ModuleGraphNode
m:[ModuleGraphNode]
ms) = (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"which imports" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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 [NodeKey]
_deps ModSummary
m) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModSummary -> SDoc
ppr_ms ModSummary
m
ppr_node (InstantiationNode UnitId
_uid InstantiatedUnit
u) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"instantiated unit" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InstantiatedUnit -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
u
ppr_node (LinkNode [NodeKey]
uid UnitId
_) = FilePath -> SDoc -> SDoc
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"LinkNode should not be in a cycle" ([NodeKey] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [NodeKey]
uid)
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
forall doc. IsLine doc => doc -> doc -> doc
<+>
(SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (ModSummary -> FilePath
msHsFilePath ModSummary
ms)))
cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe :: forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe Logger
logger TmpFs
tmpfs DynFlags
dflags =
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepTmpFiles DynFlags
dflags
then IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Logger -> TmpFs -> IO ()
Logger -> TmpFs -> IO ()
keepCurrentModuleTempFiles Logger
logger TmpFs
tmpfs
else IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> IO ()
cleanCurrentModuleTempFiles Logger
logger TmpFs
tmpfs
addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv
addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv
addDepsToHscEnv [HomeModInfo]
deps HscEnv
hsc_env =
(UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> HscEnv -> HscEnv
hscUpdateHUG (\UnitEnvGraph HomeUnitEnv
hug -> (HomeModInfo
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> [HomeModInfo]
-> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HomeModInfo -> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
addHomeModInfoToHug UnitEnvGraph HomeUnitEnv
hug [HomeModInfo]
deps) HscEnv
hsc_env
setHPT :: HomePackageTable -> HscEnv -> HscEnv
setHPT :: HomePackageTable -> HscEnv -> HscEnv
setHPT HomePackageTable
deps HscEnv
hsc_env =
(HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT (HomePackageTable -> HomePackageTable -> HomePackageTable
forall a b. a -> b -> a
const (HomePackageTable -> HomePackageTable -> HomePackageTable)
-> HomePackageTable -> HomePackageTable -> HomePackageTable
forall a b. (a -> b) -> a -> b
$ HomePackageTable
deps) HscEnv
hsc_env
setHUG :: HomeUnitGraph -> HscEnv -> HscEnv
setHUG :: UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
deps HscEnv
hsc_env =
(UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> HscEnv -> HscEnv
hscUpdateHUG (UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
forall a b. a -> b -> a
const (UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b) -> a -> b
$ UnitEnvGraph HomeUnitEnv
deps) HscEnv
hsc_env
wrapAction :: HscEnv -> IO a -> IO (Maybe a)
wrapAction :: forall a. HscEnv -> IO a -> IO (Maybe a)
wrapAction HscEnv
hsc_env IO a
k = do
let lcl_logger :: Logger
lcl_logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
lcl_dynflags :: DynFlags
lcl_dynflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
lcl_dynflags
let logg :: SourceError -> IO ()
logg SourceError
err = Logger
-> DiagnosticOpts GhcMessage
-> DiagOpts
-> Messages GhcMessage
-> IO ()
forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
lcl_logger DiagnosticOpts GhcMessage
print_config (DynFlags -> DiagOpts
initDiagOpts DynFlags
lcl_dynflags) (SourceError -> Messages GhcMessage
srcErrorMessages SourceError
err)
Either SomeException a
mres <- IO a -> IO (Either SomeException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try (IO a -> IO (Either SomeException a))
-> IO a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Logger -> IO a -> IO a
forall (m :: * -> *) a. ExceptionMonad m => Logger -> m a -> m a
prettyPrintGhcErrors Logger
lcl_logger (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a
k
case Either SomeException a
mres of
Right a
res -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
res
Left SomeException
exc -> do
case SomeException -> Maybe SourceError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
Just (SourceError
err :: SourceError)
-> SourceError -> IO ()
logg SourceError
err
Maybe SourceError
Nothing -> case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
Just (SomeAsyncException
err :: SomeAsyncException) -> SomeAsyncException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeAsyncException
err
Maybe SomeAsyncException
_ -> Logger -> SDoc -> IO ()
errorMsg Logger
lcl_logger (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
exc))
return Maybe a
forall a. Maybe a
Nothing
withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
withParLog :: forall b.
TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
withParLog TVar LogQueueQueue
lqq_var Int
k (Logger -> Logger) -> IO b
cont = do
let init_log :: IO LogQueue
init_log = do
LogQueue
lq <- Int -> IO LogQueue
newLogQueue Int
k
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar LogQueueQueue -> LogQueue -> STM ()
initLogQueue TVar LogQueueQueue
lqq_var LogQueue
lq
return LogQueue
lq
finish_log :: LogQueue -> m ()
finish_log LogQueue
lq = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LogQueue -> IO ()
finishLogQueue LogQueue
lq)
IO LogQueue -> (LogQueue -> IO ()) -> (LogQueue -> IO b) -> IO b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO LogQueue
init_log LogQueue -> IO ()
forall {m :: * -> *}. MonadIO m => LogQueue -> m ()
finish_log ((LogQueue -> IO b) -> IO b) -> (LogQueue -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \LogQueue
lq -> (Logger -> Logger) -> IO b
cont (((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> Logger -> Logger
pushLogHook ((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> (LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags
-> MessageClass
-> SrcSpan
-> SDoc
-> IO ()
forall a b. a -> b -> a
const (LogQueue -> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
parLogAction LogQueue
lq)))
withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc :: forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv{forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger, HscEnv
hsc_env :: MakeEnv -> HscEnv
hsc_env :: HscEnv
hsc_env} HscEnv -> IO a
cont = do
Int -> ((Logger -> Logger) -> IO a) -> IO a
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger Int
k (((Logger -> Logger) -> IO a) -> IO a)
-> ((Logger -> Logger) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Logger -> Logger
modifyLogger -> do
let lcl_logger :: Logger
lcl_logger = Logger -> Logger
modifyLogger (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env { hsc_logger = lcl_logger }
HscEnv -> IO a
cont HscEnv
hsc_env'
executeInstantiationNode :: Int
-> Int
-> HomeUnitGraph
-> UnitId
-> InstantiatedUnit
-> RunMakeM ()
executeInstantiationNode :: Int
-> Int
-> UnitEnvGraph HomeUnitEnv
-> UnitId
-> InstantiatedUnit
-> RunMakeM ()
executeInstantiationNode Int
k Int
n UnitEnvGraph HomeUnitEnv
deps UnitId
uid InstantiatedUnit
iu = do
MakeEnv
env <- ReaderT MakeEnv (MaybeT IO) MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
Maybe Messager
msg <- (MakeEnv -> Maybe Messager)
-> ReaderT MakeEnv (MaybeT IO) (Maybe Messager)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> Maybe Messager
env_messager
MaybeT IO () -> RunMakeM ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT MakeEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT IO () -> RunMakeM ()) -> MaybeT IO () -> RunMakeM ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe ()) -> MaybeT IO ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe ()) -> MaybeT IO ()) -> IO (Maybe ()) -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ Int -> MakeEnv -> (HscEnv -> IO (Maybe ())) -> IO (Maybe ())
forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv
env ((HscEnv -> IO (Maybe ())) -> IO (Maybe ()))
-> (HscEnv -> IO (Maybe ())) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
let lcl_hsc_env :: HscEnv
lcl_hsc_env = UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
deps HscEnv
hsc_env
in HscEnv -> IO () -> IO (Maybe ())
forall a. HscEnv -> IO a -> IO (Maybe a)
wrapAction HscEnv
lcl_hsc_env (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
()
res <- HscEnv
-> Maybe Messager
-> Int
-> Int
-> UnitId
-> InstantiatedUnit
-> IO ()
upsweep_inst HscEnv
lcl_hsc_env Maybe Messager
msg Int
k Int
n UnitId
uid InstantiatedUnit
iu
Logger -> TmpFs -> DynFlags -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
return ()
res
executeCompileNode :: Int
-> Int
-> Maybe HomeModInfo
-> HomeUnitGraph
-> Maybe [ModuleName]
-> ModSummary
-> RunMakeM HomeModInfo
executeCompileNode :: Int
-> Int
-> Maybe HomeModInfo
-> UnitEnvGraph HomeUnitEnv
-> Maybe [ModuleName]
-> ModSummary
-> RunMakeM HomeModInfo
executeCompileNode Int
k Int
n !Maybe HomeModInfo
old_hmi UnitEnvGraph HomeUnitEnv
hug Maybe [ModuleName]
mrehydrate_mods ModSummary
mod = do
me :: MakeEnv
me@MakeEnv{Maybe Messager
HscEnv
AbstractSem
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
hsc_env :: MakeEnv -> HscEnv
compile_sem :: MakeEnv -> AbstractSem
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: MakeEnv -> Maybe Messager
hsc_env :: HscEnv
compile_sem :: AbstractSem
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
..} <- ReaderT MakeEnv (MaybeT IO) MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
MaybeT IO HomeModInfo -> RunMakeM HomeModInfo
forall (m :: * -> *) a. Monad m => m a -> ReaderT MakeEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT IO HomeModInfo -> RunMakeM HomeModInfo)
-> MaybeT IO HomeModInfo -> RunMakeM HomeModInfo
forall a b. (a -> b) -> a -> b
$ IO (Maybe HomeModInfo) -> MaybeT IO HomeModInfo
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (AbstractSem -> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem (IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ Int
-> MakeEnv
-> (HscEnv -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo)
forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv
me ((HscEnv -> IO (Maybe HomeModInfo)) -> IO (Maybe HomeModInfo))
-> (HscEnv -> IO (Maybe HomeModInfo)) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
HscEnv
hydrated_hsc_env <- IO HscEnv -> IO HscEnv
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> IO HscEnv) -> IO HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore (UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
hug HscEnv
hsc_env) ModSummary
mod Maybe [ModuleName]
fixed_mrehydrate_mods
let
lcl_dynflags :: DynFlags
lcl_dynflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
mod
let lcl_hsc_env :: HscEnv
lcl_hsc_env =
(() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
lcl_dynflags (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$
HscEnv
hydrated_hsc_env
HscEnv -> IO HomeModInfo -> IO (Maybe HomeModInfo)
forall a. HscEnv -> IO a -> IO (Maybe a)
wrapAction HscEnv
lcl_hsc_env (IO HomeModInfo -> IO (Maybe HomeModInfo))
-> IO HomeModInfo -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
HomeModInfo
res <- HscEnv
-> Maybe Messager
-> Maybe HomeModInfo
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
lcl_hsc_env Maybe Messager
env_messager Maybe HomeModInfo
old_hmi ModSummary
mod Int
k Int
n
Logger -> TmpFs -> DynFlags -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env) DynFlags
lcl_dynflags
return HomeModInfo
res)
where
fixed_mrehydrate_mods :: Maybe [ModuleName]
fixed_mrehydrate_mods =
case ModSummary -> HscSource
ms_hsc_src ModSummary
mod of
HscSource
HsigFile -> [ModuleName] -> Maybe [ModuleName]
forall a. a -> Maybe a
Just []
HscSource
_ -> Maybe [ModuleName]
mrehydrate_mods
rehydrate :: HscEnv
-> [HomeModInfo]
-> IO HscEnv
rehydrate :: HscEnv -> [HomeModInfo] -> IO HscEnv
rehydrate HscEnv
hsc_env [HomeModInfo]
hmis = do
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ (
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Re-hydrating loop: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([Module] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((HomeModInfo -> Module) -> [HomeModInfo] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface -> Module)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis)))
[(ModuleName, HomeModInfo)]
new_mods <- ([(ModuleName, HomeModInfo)] -> IO [(ModuleName, HomeModInfo)])
-> IO [(ModuleName, HomeModInfo)]
forall a. (a -> IO a) -> IO a
fixIO (([(ModuleName, HomeModInfo)] -> IO [(ModuleName, HomeModInfo)])
-> IO [(ModuleName, HomeModInfo)])
-> ([(ModuleName, HomeModInfo)] -> IO [(ModuleName, HomeModInfo)])
-> IO [(ModuleName, HomeModInfo)]
forall a b. (a -> b) -> a -> b
$ \[(ModuleName, HomeModInfo)]
new_mods -> do
let new_hpt :: HomePackageTable
new_hpt = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt HomePackageTable
old_hpt [(ModuleName, HomeModInfo)]
new_mods
let new_hsc_env :: HscEnv
new_hsc_env = (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT_lazy (HomePackageTable -> HomePackageTable -> HomePackageTable
forall a b. a -> b -> a
const HomePackageTable
new_hpt) HscEnv
hsc_env
[ModDetails]
mds <- SDoc -> HscEnv -> IfG [ModDetails] -> IO [ModDetails]
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"rehydrate") 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ModIface -> IOEnv (Env IfGblEnv ()) ModDetails
typecheckIface (ModIface -> IOEnv (Env IfGblEnv ()) ModDetails)
-> (HomeModInfo -> ModIface)
-> HomeModInfo
-> IOEnv (Env IfGblEnv ()) ModDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis
let new_mods :: [(ModuleName, HomeModInfo)]
new_mods = [ (ModuleName
mn,HomeModInfo
hmi{ hm_details = details })
| (HomeModInfo
hmi,ModDetails
details) <- [HomeModInfo] -> [ModDetails] -> [(HomeModInfo, ModDetails)]
forall a b. [a] -> [b] -> [(a, b)]
zip [HomeModInfo]
hmis [ModDetails]
mds
, let mn :: ModuleName
mn = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)) ]
[(ModuleName, HomeModInfo)] -> IO [(ModuleName, HomeModInfo)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return [(ModuleName, HomeModInfo)]
new_mods
return $ HomePackageTable -> HscEnv -> HscEnv
setHPT ((HomePackageTable -> (ModuleName, HomeModInfo) -> HomePackageTable)
-> HomePackageTable
-> [(ModuleName, HomeModInfo)]
-> HomePackageTable
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\HomePackageTable
old (ModuleName
mn, HomeModInfo
hmi) -> HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
old ModuleName
mn HomeModInfo
hmi) HomePackageTable
old_hpt [(ModuleName, HomeModInfo)]
new_mods) HscEnv
hsc_env
where
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
to_delete :: [ModuleName]
to_delete = ((HomeModInfo -> ModuleName) -> [HomeModInfo] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (HomeModInfo -> Module) -> HomeModInfo -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface -> Module)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis)
!old_hpt :: HomePackageTable
old_hpt = (HomePackageTable -> ModuleName -> HomePackageTable)
-> HomePackageTable -> [ModuleName] -> HomePackageTable
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) [ModuleName]
to_delete
maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore HscEnv
hsc_env ModSummary
_ Maybe [ModuleName]
Nothing = HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
maybeRehydrateBefore HscEnv
hsc_env ModSummary
mod (Just [ModuleName]
mns) = do
ModuleEnv (IORef TypeEnv)
knot_var <- HscEnv -> IO (ModuleEnv (IORef TypeEnv))
initialise_knot_var HscEnv
hsc_env
let 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
"mr" (Maybe HomeModInfo -> HomeModInfo)
-> (ModuleName -> Maybe HomeModInfo) -> ModuleName -> HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)) [ModuleName]
mns
HscEnv -> [HomeModInfo] -> IO HscEnv
rehydrate (HscEnv
hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }) [HomeModInfo]
hmis
where
initialise_knot_var :: HscEnv -> IO (ModuleEnv (IORef TypeEnv))
initialise_knot_var HscEnv
hsc_env = IO (ModuleEnv (IORef TypeEnv)) -> IO (ModuleEnv (IORef TypeEnv))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModuleEnv (IORef TypeEnv)) -> IO (ModuleEnv (IORef TypeEnv)))
-> IO (ModuleEnv (IORef TypeEnv)) -> IO (ModuleEnv (IORef TypeEnv))
forall a b. (a -> b) -> a -> b
$
let mod_name :: Module
mod_name = Maybe HomeUnit -> Module -> Module
homeModuleInstantiation (HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env) (ModSummary -> Module
ms_mod ModSummary
mod)
in [(Module, IORef TypeEnv)] -> ModuleEnv (IORef TypeEnv)
forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv ([(Module, IORef TypeEnv)] -> ModuleEnv (IORef TypeEnv))
-> (IORef TypeEnv -> [(Module, IORef TypeEnv)])
-> IORef TypeEnv
-> ModuleEnv (IORef TypeEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Module, IORef TypeEnv)
-> [(Module, IORef TypeEnv)] -> [(Module, IORef TypeEnv)]
forall a. a -> [a] -> [a]
:[]) ((Module, IORef TypeEnv) -> [(Module, IORef TypeEnv)])
-> (IORef TypeEnv -> (Module, IORef TypeEnv))
-> IORef TypeEnv
-> [(Module, IORef TypeEnv)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module
mod_name,) (IORef TypeEnv -> ModuleEnv (IORef TypeEnv))
-> IO (IORef TypeEnv) -> IO (ModuleEnv (IORef TypeEnv))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeEnv -> IO (IORef TypeEnv)
forall a. a -> IO (IORef a)
newIORef TypeEnv
emptyTypeEnv
rehydrateAfter :: HscEnv
-> [ModuleName]
-> IO [HomeModInfo]
rehydrateAfter :: HscEnv -> [ModuleName] -> IO [HomeModInfo]
rehydrateAfter HscEnv
new_hsc [ModuleName]
mns = do
let new_hpt :: HomePackageTable
new_hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
new_hsc
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
"mrAfter" (Maybe HomeModInfo -> HomeModInfo)
-> (ModuleName -> Maybe HomeModInfo) -> ModuleName -> HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
new_hpt) [ModuleName]
mns
HscEnv
hsc_env <- HscEnv -> [HomeModInfo] -> IO HscEnv
rehydrate (HscEnv
new_hsc { hsc_type_env_vars = emptyKnotVars }) [HomeModInfo]
hmis
return $ (ModuleName -> HomeModInfo) -> [ModuleName] -> [HomeModInfo]
forall a b. (a -> b) -> [a] -> [b]
map (\ModuleName
mn -> FilePath -> Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"rehydrate" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) ModuleName
mn) [ModuleName]
mns
executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
executeLinkNode :: UnitEnvGraph HomeUnitEnv
-> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
executeLinkNode UnitEnvGraph HomeUnitEnv
hug (Int, Int)
kn UnitId
uid [NodeKey]
deps = do
UnitId -> RunMakeM () -> RunMakeM ()
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
uid (RunMakeM () -> RunMakeM ()) -> RunMakeM () -> RunMakeM ()
forall a b. (a -> b) -> a -> b
$ do
MakeEnv{Maybe Messager
HscEnv
AbstractSem
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
hsc_env :: MakeEnv -> HscEnv
compile_sem :: MakeEnv -> AbstractSem
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: MakeEnv -> Maybe Messager
hsc_env :: HscEnv
compile_sem :: AbstractSem
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
..} <- ReaderT MakeEnv (MaybeT IO) MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let hsc_env' :: HscEnv
hsc_env' = UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
hug HscEnv
hsc_env
msg' :: Maybe (RecompileRequired -> IO ())
msg' = (\Messager
messager -> \RecompileRequired
recomp -> Messager
messager HscEnv
hsc_env (Int, Int)
kn RecompileRequired
recomp ([NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
deps UnitId
uid)) (Messager -> RecompileRequired -> IO ())
-> Maybe Messager -> Maybe (RecompileRequired -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Messager
env_messager
SuccessFlag
linkresult <- IO SuccessFlag -> ReaderT MakeEnv (MaybeT IO) SuccessFlag
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SuccessFlag -> ReaderT MakeEnv (MaybeT IO) SuccessFlag)
-> IO SuccessFlag -> ReaderT MakeEnv (MaybeT IO) SuccessFlag
forall a b. (a -> b) -> a -> b
$ AbstractSem -> IO SuccessFlag -> IO SuccessFlag
forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem (IO SuccessFlag -> IO SuccessFlag)
-> IO SuccessFlag -> IO SuccessFlag
forall a b. (a -> b) -> a -> b
$ do
GhcLink
-> Logger
-> TmpFs
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
(HscEnv -> Logger
hsc_logger HscEnv
hsc_env')
(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
True
Maybe (RecompileRequired -> IO ())
msg'
(HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env')
case SuccessFlag
linkresult of
SuccessFlag
Failed -> FilePath -> RunMakeM ()
forall a. FilePath -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Link Failed"
SuccessFlag
Succeeded -> () -> RunMakeM ()
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
type ModuleNameSet = M.Map UnitId I.IntSet
addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet
addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet
addToModuleNameSet UnitId
uid ModuleName
mn ModuleNameSet
s =
let k :: Int
k = (Unique -> Int
getKey (Unique -> Int) -> Unique -> Int
forall a b. (a -> b) -> a -> b
$ ModuleName -> Unique
forall a. Uniquable a => a -> Unique
getUnique (ModuleName -> Unique) -> ModuleName -> Unique
forall a b. (a -> b) -> a -> b
$ ModuleName
mn)
in (IntSet -> IntSet -> IntSet)
-> UnitId -> IntSet -> ModuleNameSet -> ModuleNameSet
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (IntSet -> IntSet -> IntSet
I.union) UnitId
uid (Int -> IntSet
I.singleton Int
k) ModuleNameSet
s
wait_deps_hug :: MVar HomeUnitGraph -> [BuildResult] -> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet)
wait_deps_hug :: MVar (UnitEnvGraph HomeUnitEnv)
-> [BuildResult]
-> ReaderT
MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv, ModuleNameSet)
wait_deps_hug MVar (UnitEnvGraph HomeUnitEnv)
hug_var [BuildResult]
deps = do
([HomeModInfo]
_, ModuleNameSet
module_deps) <- [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
wait_deps [BuildResult]
deps
UnitEnvGraph HomeUnitEnv
hug <- IO (UnitEnvGraph HomeUnitEnv)
-> ReaderT MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv)
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UnitEnvGraph HomeUnitEnv)
-> ReaderT MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv))
-> IO (UnitEnvGraph HomeUnitEnv)
-> ReaderT MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv)
forall a b. (a -> b) -> a -> b
$ MVar (UnitEnvGraph HomeUnitEnv) -> IO (UnitEnvGraph HomeUnitEnv)
forall a. MVar a -> IO a
readMVar MVar (UnitEnvGraph HomeUnitEnv)
hug_var
let pruneHomeUnitEnv :: UnitId -> HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv UnitId
uid HomeUnitEnv
hme =
let
!new :: HomePackageTable
new = HomePackageTable -> IntSet -> HomePackageTable
forall key elt. UniqDFM key elt -> IntSet -> UniqDFM key elt
udfmRestrictKeysSet (HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
hme) (IntSet -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
fromMaybe IntSet
I.empty (Maybe IntSet -> IntSet) -> Maybe IntSet -> IntSet
forall a b. (a -> b) -> a -> b
$ UnitId -> ModuleNameSet -> Maybe IntSet
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup UnitId
uid ModuleNameSet
module_deps)
in HomeUnitEnv
hme { homeUnitEnv_hpt = new }
return ((UnitId -> HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
forall v b. (UnitId -> v -> b) -> UnitEnvGraph v -> UnitEnvGraph b
unitEnv_mapWithKey UnitId -> HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv UnitEnvGraph HomeUnitEnv
hug, ModuleNameSet
module_deps)
wait_deps :: [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
wait_deps :: [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
wait_deps [] = ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet)
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], ModuleNameSet
forall k a. Map k a
M.empty)
wait_deps (BuildResult
x:[BuildResult]
xs) = do
(Maybe HomeModInfo
res, ModuleNameSet
deps) <- MaybeT IO (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall (m :: * -> *) a. Monad m => m a -> ReaderT MakeEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT IO (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet))
-> MaybeT IO (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall a b. (a -> b) -> a -> b
$ ResultVar (Maybe HomeModInfo, ModuleNameSet)
-> MaybeT IO (Maybe HomeModInfo, ModuleNameSet)
forall a. ResultVar a -> MaybeT IO a
waitResult (BuildResult -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
resultVar BuildResult
x)
([HomeModInfo]
hmis, ModuleNameSet
all_deps) <- [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
wait_deps [BuildResult]
xs
let !new_deps :: ModuleNameSet
new_deps = ModuleNameSet
deps ModuleNameSet -> ModuleNameSet -> ModuleNameSet
`unionModuleNameSet` ModuleNameSet
all_deps
case Maybe HomeModInfo
res of
Maybe HomeModInfo
Nothing -> ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet)
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([HomeModInfo]
hmis, ModuleNameSet
new_deps)
Just HomeModInfo
hmi -> ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet)
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo
hmiHomeModInfo -> [HomeModInfo] -> [HomeModInfo]
forall a. a -> [a] -> [a]
:[HomeModInfo]
hmis, ModuleNameSet
new_deps)
where
unionModuleNameSet :: ModuleNameSet -> ModuleNameSet -> ModuleNameSet
unionModuleNameSet = (IntSet -> IntSet -> IntSet)
-> ModuleNameSet -> ModuleNameSet -> ModuleNameSet
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith IntSet -> IntSet -> IntSet
I.union
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
runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runPipelines Int
_ HscEnv
_ Maybe Messager
_ [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runPipelines Int
n_job HscEnv
hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines = do
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self FilePath
"main --make thread"
case Int
n_job of
Int
1 -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runSeqPipelines HscEnv
hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines
Int
_n -> Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runParPipelines Int
n_job HscEnv
hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines
runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runSeqPipelines HscEnv
plugin_hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines =
let env :: MakeEnv
env = MakeEnv { hsc_env :: HscEnv
hsc_env = HscEnv
plugin_hsc_env
, withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger = \Int
_ (Logger -> Logger) -> IO a
k -> (Logger -> Logger) -> IO a
k Logger -> Logger
forall a. a -> a
id
, compile_sem :: AbstractSem
compile_sem = IO () -> IO () -> AbstractSem
AbstractSem (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, env_messager :: Maybe Messager
env_messager = Maybe Messager
mHscMessager
}
in Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines Int
1 MakeEnv
env [MakeAction]
all_pipelines
runParPipelines :: Int
-> HscEnv
-> Maybe Messager
-> [MakeAction]
-> IO ()
runParPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runParPipelines Int
n_jobs HscEnv
plugin_hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines = do
TVar Bool
stopped_var <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
TVar LogQueueQueue
log_queue_queue_var <- LogQueueQueue -> IO (TVar LogQueueQueue)
forall a. a -> IO (TVar a)
newTVarIO LogQueueQueue
newLogQueueQueue
IO ()
wait_log_thread <- Int
-> Int -> Logger -> TVar Bool -> TVar LogQueueQueue -> IO (IO ())
logThread Int
n_jobs ([MakeAction] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MakeAction]
all_pipelines) (HscEnv -> Logger
hsc_logger HscEnv
plugin_hsc_env) TVar Bool
stopped_var TVar LogQueueQueue
log_queue_queue_var
Logger
thread_safe_logger <- IO Logger -> IO Logger
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Logger -> IO Logger) -> IO Logger -> IO Logger
forall a b. (a -> b) -> a -> b
$ Logger -> IO Logger
makeThreadSafe (HscEnv -> Logger
hsc_logger HscEnv
plugin_hsc_env)
let thread_safe_hsc_env :: HscEnv
thread_safe_hsc_env = HscEnv
plugin_hsc_env { hsc_logger = thread_safe_logger }
let updNumCapabilities :: IO Int
updNumCapabilities = IO Int -> IO Int
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ do
Int
n_capabilities <- IO Int
getNumCapabilities
Int
n_cpus <- IO Int
getNumProcessors
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
return Int
n_capabilities
let resetNumCapabilities :: Int -> IO ()
resetNumCapabilities Int
orig_n = do
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
orig_n
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
stopped_var Bool
True
IO ()
wait_log_thread
QSem
compile_sem <- Int -> IO QSem
newQSem Int
n_jobs
let abstract_sem :: AbstractSem
abstract_sem = IO () -> IO () -> AbstractSem
AbstractSem (QSem -> IO ()
waitQSem QSem
compile_sem) (QSem -> IO ()
signalQSem QSem
compile_sem)
let env :: MakeEnv
env = MakeEnv { hsc_env :: HscEnv
hsc_env = HscEnv
thread_safe_hsc_env
, withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger = TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO a) -> IO a
forall b.
TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
withParLog TVar LogQueueQueue
log_queue_queue_var
, compile_sem :: AbstractSem
compile_sem = AbstractSem
abstract_sem
, env_messager :: Maybe Messager
env_messager = Maybe Messager
mHscMessager
}
IO Int -> (Int -> IO ()) -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO Int
updNumCapabilities Int -> IO ()
resetNumCapabilities ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
_ ->
Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines Int
n_jobs MakeEnv
env [MakeAction]
all_pipelines
withLocalTmpFS :: RunMakeM a -> RunMakeM a
withLocalTmpFS :: forall a. RunMakeM a -> RunMakeM a
withLocalTmpFS RunMakeM a
act = do
let initialiser :: ReaderT MakeEnv (MaybeT IO) HscEnv
initialiser = do
MakeEnv{Maybe Messager
HscEnv
AbstractSem
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
hsc_env :: MakeEnv -> HscEnv
compile_sem :: MakeEnv -> AbstractSem
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: MakeEnv -> Maybe Messager
hsc_env :: HscEnv
compile_sem :: AbstractSem
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
..} <- ReaderT MakeEnv (MaybeT IO) MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
TmpFs
lcl_tmpfs <- IO TmpFs -> ReaderT MakeEnv (MaybeT IO) TmpFs
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TmpFs -> ReaderT MakeEnv (MaybeT IO) TmpFs)
-> IO TmpFs -> ReaderT MakeEnv (MaybeT IO) TmpFs
forall a b. (a -> b) -> a -> b
$ TmpFs -> IO TmpFs
forkTmpFsFrom (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env)
return $ HscEnv
hsc_env { hsc_tmpfs = lcl_tmpfs }
finaliser :: HscEnv -> ReaderT MakeEnv m ()
finaliser HscEnv
lcl_env = do
MakeEnv
gbl_env <- ReaderT MakeEnv m MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
IO () -> ReaderT MakeEnv m ()
forall a. IO a -> ReaderT MakeEnv m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT MakeEnv m ()) -> IO () -> ReaderT MakeEnv m ()
forall a b. (a -> b) -> a -> b
$ TmpFs -> TmpFs -> IO ()
mergeTmpFsInto (HscEnv -> TmpFs
hsc_tmpfs HscEnv
lcl_env) (HscEnv -> TmpFs
hsc_tmpfs (MakeEnv -> HscEnv
hsc_env MakeEnv
gbl_env))
ReaderT MakeEnv (MaybeT IO) HscEnv
-> (HscEnv -> RunMakeM ()) -> (HscEnv -> RunMakeM a) -> RunMakeM a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket ReaderT MakeEnv (MaybeT IO) HscEnv
initialiser HscEnv -> RunMakeM ()
forall {m :: * -> *}. MonadIO m => HscEnv -> ReaderT MakeEnv m ()
finaliser ((HscEnv -> RunMakeM a) -> RunMakeM a)
-> (HscEnv -> RunMakeM a) -> RunMakeM a
forall a b. (a -> b) -> a -> b
$ \HscEnv
lcl_hsc_env -> (MakeEnv -> MakeEnv) -> RunMakeM a -> RunMakeM a
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (\MakeEnv
env -> MakeEnv
env { hsc_env = lcl_hsc_env}) RunMakeM a
act
runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines Int
n_jobs MakeEnv
env [MakeAction]
acts = do
let spawn_actions :: IO [ThreadId]
spawn_actions :: IO [ThreadId]
spawn_actions = if Int
n_jobs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
then (ThreadId -> [ThreadId] -> [ThreadId]
forall a. a -> [a] -> [a]
:[]) (ThreadId -> [ThreadId]) -> IO ThreadId -> IO [ThreadId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((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 -> IO [()] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [()] -> IO ()) -> IO [()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> MakeEnv -> [MakeAction] -> IO [()]
forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop (\(forall a. IO a -> IO a) -> IO ()
io -> (forall a. IO a -> IO a) -> IO ()
io IO a -> IO a
forall a. IO a -> IO a
unmask) MakeEnv
env [MakeAction]
acts)
else (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> MakeEnv -> [MakeAction] -> IO [ThreadId]
forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask MakeEnv
env [MakeAction]
acts
kill_actions :: [ThreadId] -> IO ()
kill_actions :: [ThreadId] -> IO ()
kill_actions [ThreadId]
tids = (ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread [ThreadId]
tids
IO [ThreadId]
-> ([ThreadId] -> IO ()) -> ([ThreadId] -> IO ()) -> IO ()
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO [ThreadId]
spawn_actions [ThreadId] -> IO ()
kill_actions (([ThreadId] -> IO ()) -> IO ()) -> ([ThreadId] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[ThreadId]
_ -> do
(MakeAction -> IO ()) -> [MakeAction] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MakeAction -> IO ()
waitMakeAction [MakeAction]
acts
runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]
runLoop :: forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO a
_ MakeEnv
_env [] = [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO a
fork_thread MakeEnv
env (MakeAction RunMakeM a
act MVar (Maybe a)
res_var :[MakeAction]
acts) = do
a
new_thread <-
((forall a. IO a -> IO a) -> IO ()) -> IO a
fork_thread (((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> (do
Maybe a
mres <- (IO (Maybe a) -> IO (Maybe a)
forall a. IO a -> IO a
unmask (IO (Maybe a) -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ RunMakeM a -> IO (Maybe a)
forall a. RunMakeM a -> IO (Maybe a)
run_pipeline (RunMakeM a -> RunMakeM a
forall a. RunMakeM a -> RunMakeM a
withLocalTmpFS RunMakeM a
act))
IO (Maybe a) -> IO () -> IO (Maybe a)
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`MC.onException` (MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
res_var Maybe a
forall a. Maybe a
Nothing)
MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
res_var Maybe a
mres)
[a]
threads <- (((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO a
fork_thread MakeEnv
env [MakeAction]
acts
return (a
new_thread a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
threads)
where
run_pipeline :: RunMakeM a -> IO (Maybe a)
run_pipeline :: forall a. RunMakeM a -> IO (Maybe a)
run_pipeline RunMakeM a
p = MaybeT IO a -> IO (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (RunMakeM a -> MakeEnv -> MaybeT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT RunMakeM a
p MakeEnv
env)
data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))
waitMakeAction :: MakeAction -> IO ()
waitMakeAction :: MakeAction -> IO ()
waitMakeAction (MakeAction RunMakeM a
_ MVar (Maybe a)
mvar) = () () -> IO (Maybe a) -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MVar (Maybe a) -> IO (Maybe a)
forall a. MVar a -> IO a
readMVar MVar (Maybe a)
mvar