{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Driver.Make (
depanal, depanalE, depanalPartial,
load, load', LoadHowMuch(..),
instantiationNodes,
downsweep,
topSortModuleGraph,
ms_home_srcimps, ms_home_imps,
summariseModule,
hscSourceToIsBoot,
findExtraSigImports,
implicitRequirementsShallow,
noModError, cyclicModuleErr,
moduleGraphNodes, SummaryNode,
IsBootInterface(..),
ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Tc.Utils.Backpack
import GHC.Tc.Utils.Monad ( initIfaceCheck )
import GHC.Runtime.Interpreter
import qualified GHC.Linker.Loader as Linker
import GHC.Linker.Types
import GHC.Runtime.Context
import GHC.Driver.Config
import GHC.Driver.Phases
import GHC.Driver.Pipeline
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Monad
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Main
import GHC.Parser.Header
import GHC.Parser.Errors.Ppr
import GHC.Iface.Load ( cannotFindModule )
import GHC.IfaceToCore ( typecheckIface )
import GHC.Iface.Recomp ( RecompileRequired ( MustCompile ) )
import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag )
import GHC.Data.Graph.Directed
import GHC.Data.FastString
import GHC.Data.Maybe ( expectJust )
import GHC.Data.StringBuffer
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.Exception ( tryIO )
import GHC.Utils.Monad ( allM )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Types.Basic
import GHC.Types.Target
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.Unique.DSet
import GHC.Types.Unique.Set
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Unit
import GHC.Unit.State
import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo
import Data.Either ( rights, partitionEithers )
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import qualified GHC.Data.FiniteMap as Map ( insertListWith )
import Control.Concurrent ( forkIOWithUnmask, killThread )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import qualified Control.Monad.Catch as MC
import Data.IORef
import Data.List (nub, sortBy, partition)
import qualified Data.List as List
import Data.Foldable (toList)
import Data.Maybe
import Data.Ord ( comparing )
import Data.Time
import Data.Bifunctor (first)
import System.Directory
import System.FilePath
import System.IO ( fixIO )
import System.IO.Error ( isDoesNotExistError )
import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
label_self :: String -> IO ()
label_self :: FilePath -> IO ()
label_self FilePath
thread_name = do
ThreadId
self_tid <- IO ThreadId
CC.myThreadId
ThreadId -> FilePath -> IO ()
CC.labelThread ThreadId
self_tid FilePath
thread_name
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
(ErrorMessages
errs, ModuleGraph
mod_graph) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots
if forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
then forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleGraph
mod_graph
else forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
errs
depanalE :: GhcMonad m =>
[ModuleName]
-> Bool
-> m (ErrorMessages, ModuleGraph)
depanalE :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
(ErrorMessages
errs, ModuleGraph
mod_graph) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots
if forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
then do
let unused_home_mod_err :: [MsgEnvelope DecoratedSDoc]
unused_home_mod_err = HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnMissingHomeModules HscEnv
hsc_env ModuleGraph
mod_graph
unused_pkg_err :: [MsgEnvelope DecoratedSDoc]
unused_pkg_err = HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnUnusedPackages HscEnv
hsc_env ModuleGraph
mod_graph
warns :: [MsgEnvelope DecoratedSDoc]
warns = [MsgEnvelope DecoratedSDoc]
unused_home_mod_err forall a. [a] -> [a] -> [a]
++ [MsgEnvelope DecoratedSDoc]
unused_pkg_err
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MsgEnvelope DecoratedSDoc]
warns) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings (forall a. [a] -> Bag a
listToBag [MsgEnvelope DecoratedSDoc]
warns)
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ErrorMessages
errs, ModuleGraph
mod_graph)
else do
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
emptyMG }
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ErrorMessages
errs, ModuleGraph
emptyMG)
depanalPartial
:: GhcMonad m
=> [ModuleName]
-> Bool
-> m (ErrorMessages, ModuleGraph)
depanalPartial :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
targets :: [Target]
targets = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
old_graph :: ModuleGraph
old_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags (FilePath -> SDoc
text FilePath
"Chasing dependencies") (forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 ([SDoc] -> SDoc
hcat [
FilePath -> SDoc
text FilePath
"Chasing modules from: ",
[SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma (forall a b. (a -> b) -> [a] -> [b]
map Target -> SDoc
pprTarget [Target]
targets))])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
flushFinderCaches HscEnv
hsc_env
[Either ErrorMessages ExtendedModSummary]
mod_summariesE <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> [ExtendedModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ExtendedModSummary]
downsweep
HscEnv
hsc_env (ModuleGraph -> [ExtendedModSummary]
mgExtendedModSummaries ModuleGraph
old_graph)
[ModuleName]
excluded_mods Bool
allow_dup_roots
let
([ErrorMessages]
errs, [ExtendedModSummary]
mod_summaries) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ErrorMessages ExtendedModSummary]
mod_summariesE
mod_graph :: ModuleGraph
mod_graph = [ModuleGraphNode] -> ModuleGraph
mkModuleGraph' forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtendedModSummary -> ModuleGraphNode
ModuleNode [ExtendedModSummary]
mod_summaries forall a. [a] -> [a] -> [a]
++ UnitState -> [ModuleGraphNode]
instantiationNodes (HscEnv -> UnitState
hsc_units HscEnv
hsc_env)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [Bag a] -> Bag a
unionManyBags [ErrorMessages]
errs, ModuleGraph
mod_graph)
instantiationNodes :: UnitState -> [ModuleGraphNode]
instantiationNodes :: UnitState -> [ModuleGraphNode]
instantiationNodes UnitState
unit_state = InstantiatedUnit -> ModuleGraphNode
InstantiationNode 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 =
forall a. Ord a => [a] -> [a]
nubSort forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {unit}. GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId (UnitState -> [Unit]
explicitUnits UnitState
unit_state)
where
goUnitId :: GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId GenUnit unit
uid =
[ GenInstantiatedUnit unit
recur
| VirtUnit GenInstantiatedUnit unit
indef <- [GenUnit unit
uid]
, (ModuleName, GenModule (GenUnit unit))
inst <- forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit unit
indef
, GenInstantiatedUnit unit
recur <- (GenInstantiatedUnit unit
indef forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (ModuleName, GenModule (GenUnit unit))
inst
]
warnMissingHomeModules :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnMissingHomeModules :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnMissingHomeModules HscEnv
hsc_env ModuleGraph
mod_graph =
if (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingHomeModules DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
missing))
then [MsgEnvelope DecoratedSDoc
warn]
else []
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
targets :: [TargetId]
targets = forall a b. (a -> b) -> [a] -> [b]
map Target -> TargetId
targetId (HscEnv -> [Target]
hsc_targets HscEnv
hsc_env)
is_known_module :: ModSummary -> Bool
is_known_module ModSummary
mod = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ModSummary -> TargetId -> Bool
is_my_target ModSummary
mod) [TargetId]
targets
is_my_target :: ModSummary -> TargetId -> Bool
is_my_target ModSummary
mod (TargetModule ModuleName
name)
= forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod) forall a. Eq a => a -> a -> Bool
== ModuleName
name
is_my_target ModSummary
mod (TargetFile FilePath
target_file Maybe Phase
_)
| Just FilePath
mod_file <- ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod)
= FilePath
target_file forall a. Eq a => a -> a -> Bool
== FilePath
mod_file Bool -> Bool -> Bool
||
FilePath -> FilePath
addBootSuffix FilePath
target_file forall a. Eq a => a -> a -> Bool
== FilePath
mod_file Bool -> Bool -> Bool
||
FilePath -> ModuleName
mkModuleName (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ FilePath -> (FilePath, FilePath)
splitExtension FilePath
target_file)
forall a. Eq a => a -> a -> Bool
== forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod)
is_my_target ModSummary
_ TargetId
_ = Bool
False
missing :: [ModuleName]
missing = forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Bool
is_known_module) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)
msg :: SDoc
msg
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildingCabalPackage DynFlags
dflags
= SDoc -> Int -> SDoc -> SDoc
hang
(FilePath -> SDoc
text FilePath
"These modules are needed for compilation but not listed in your .cabal file's other-modules: ")
Int
4
([SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [ModuleName]
missing))
| Bool
otherwise
=
SDoc -> Int -> SDoc -> SDoc
hang
(FilePath -> SDoc
text FilePath
"Modules are not listed in command line but needed for compilation: ")
Int
4
([SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [ModuleName]
missing))
warn :: MsgEnvelope DecoratedSDoc
warn = forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning
(WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingHomeModules)
(SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan SDoc
msg)
data LoadHowMuch
= LoadAllTargets
| LoadUpTo ModuleName
| LoadDependenciesOf ModuleName
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load :: forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
how_much = do
(ErrorMessages
errs, ModuleGraph
mod_graph) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalE [] Bool
False
SuccessFlag
success <- forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
how_much (forall a. a -> Maybe a
Just Messager
batchMsg) ModuleGraph
mod_graph
if forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
then forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
success
else forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
errs
warnUnusedPackages :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnUnusedPackages :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnUnusedPackages HscEnv
hsc_env ModuleGraph
mod_graph =
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
state :: UnitState
state = HscEnv -> UnitState
hsc_units HscEnv
hsc_env
loadedPackages :: [UnitInfo]
loadedPackages = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Maybe FastString
fs, GenLocated SrcSpan ModuleName
mn) -> UnitState -> ModuleName -> Maybe FastString -> Maybe [UnitInfo]
lookupModulePackage UnitState
state (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
mn) Maybe FastString
fs)
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_imps (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)
requestedArgs :: [PackageArg]
requestedArgs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PackageFlag -> Maybe PackageArg
packageArg (DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags)
unusedArgs :: [PackageArg]
unusedArgs
= forall a. (a -> Bool) -> [a] -> [a]
filter (\PackageArg
arg -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UnitState -> PackageArg -> UnitInfo -> Bool
matching UnitState
state PackageArg
arg) [UnitInfo]
loadedPackages)
[PackageArg]
requestedArgs
warn :: MsgEnvelope DecoratedSDoc
warn = forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning
(WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnusedPackages)
(SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan SDoc
msg)
msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ FilePath -> SDoc
text FilePath
"The following packages were specified" SDoc -> SDoc -> SDoc
<+>
FilePath -> SDoc
text FilePath
"via -package or -package-id flags,"
, FilePath -> SDoc
text FilePath
"but were not needed for compilation:"
, Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
withDash forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageArg -> SDoc
pprUnusedArg) [PackageArg]
unusedArgs)) ]
in if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageArg]
unusedArgs) Bool -> Bool -> Bool
&& WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnusedPackages DynFlags
dflags
then [MsgEnvelope DecoratedSDoc
warn]
else []
where
packageArg :: PackageFlag -> Maybe PackageArg
packageArg (ExposePackage FilePath
_ PackageArg
arg ModRenaming
_) = forall a. a -> Maybe a
Just PackageArg
arg
packageArg PackageFlag
_ = forall a. Maybe a
Nothing
pprUnusedArg :: PackageArg -> SDoc
pprUnusedArg (PackageArg FilePath
str) = FilePath -> SDoc
text FilePath
str
pprUnusedArg (UnitIdArg Unit
uid) = forall a. Outputable a => a -> SDoc
ppr Unit
uid
withDash :: SDoc -> SDoc
withDash = SDoc -> SDoc -> SDoc
(<+>) (FilePath -> SDoc
text FilePath
"-")
matchingStr :: String -> UnitInfo -> Bool
matchingStr :: FilePath -> UnitInfo -> Bool
matchingStr FilePath
str UnitInfo
p
= FilePath
str forall a. Eq a => a -> a -> Bool
== forall u. GenUnitInfo u -> FilePath
unitPackageIdString UnitInfo
p
Bool -> Bool -> Bool
|| FilePath
str forall a. Eq a => a -> a -> Bool
== forall u. GenUnitInfo u -> FilePath
unitPackageNameString UnitInfo
p
matching :: UnitState -> PackageArg -> UnitInfo -> Bool
matching :: UnitState -> PackageArg -> UnitInfo -> Bool
matching UnitState
_ (PackageArg FilePath
str) UnitInfo
p = FilePath -> UnitInfo -> Bool
matchingStr FilePath
str UnitInfo
p
matching UnitState
state (UnitIdArg Unit
uid) UnitInfo
p = Unit
uid forall a. Eq a => a -> a -> Bool
== UnitState -> UnitInfo -> Unit
realUnit UnitState
state UnitInfo
p
realUnit :: UnitState -> UnitInfo -> Unit
realUnit :: UnitState -> UnitInfo -> Unit
realUnit UnitState
state
= UnitState -> Unit -> Unit
unwireUnit UnitState
state
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall uid. Definite uid -> GenUnit uid
RealUnit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. unit -> Definite unit
Definite
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId
load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' :: forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
how_much Maybe Messager
mHscMessage ModuleGraph
mod_graph = do
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let hpt1 :: HomePackageTable
hpt1 = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
let all_home_mods :: UniqSet ModuleName
all_home_mods =
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [ ModSummary -> ModuleName
ms_mod_name ModSummary
s
| ModSummary
s <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph, ModSummary -> IsBootInterface
isBootSummary ModSummary
s forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot]
let checkHowMuch :: LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch (LoadUpTo ModuleName
m) = ModuleName -> m SuccessFlag -> m SuccessFlag
checkMod ModuleName
m
checkHowMuch (LoadDependenciesOf ModuleName
m) = ModuleName -> m SuccessFlag -> m SuccessFlag
checkMod ModuleName
m
checkHowMuch LoadHowMuch
_ = forall a. a -> a
id
checkMod :: ModuleName -> m SuccessFlag -> m SuccessFlag
checkMod ModuleName
m m SuccessFlag
and_then
| ModuleName
m forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
all_home_mods = m SuccessFlag
and_then
| Bool
otherwise = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
errorMsg Logger
logger DynFlags
dflags
(FilePath -> SDoc
text FilePath
"no such module:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
m))
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch LoadHowMuch
how_much forall a b. (a -> b) -> a -> b
$ do
let mg2_with_srcimps :: [SCC ModSummary]
mg2_with_srcimps :: [SCC ModSummary]
mg2_with_srcimps = [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules forall a b. (a -> b) -> a -> b
$
Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
True ModuleGraph
mod_graph forall a. Maybe a
Nothing
forall (m :: * -> *). GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports [SCC ModSummary]
mg2_with_srcimps
let
stable_mods :: StableModules
stable_mods@(UniqSet ModuleName
stable_obj,UniqSet ModuleName
stable_bco)
= HomePackageTable
-> [SCC ModSummary] -> UniqSet ModuleName -> StableModules
checkStability HomePackageTable
hpt1 [SCC ModSummary]
mg2_with_srcimps UniqSet ModuleName
all_home_mods
pruned_hpt :: HomePackageTable
pruned_hpt = HomePackageTable
hpt1
HomePackageTable
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate HomePackageTable
pruned_hpt
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
discardIC forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
pruned_hpt }
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Stable obj:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr UniqSet ModuleName
stable_obj SDoc -> SDoc -> SDoc
$$
FilePath -> SDoc
text FilePath
"Stable BCO:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr UniqSet ModuleName
stable_bco)
let stable_linkables :: [Linkable]
stable_linkables = [ Linkable
linkable
| ModuleName
m <- forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ModuleName
stable_obj forall a. [a] -> [a] -> [a]
++
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ModuleName
stable_bco,
Just HomeModInfo
hmi <- [HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
pruned_hpt ModuleName
m],
Just Linkable
linkable <- [HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi] ]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> [Linkable] -> IO ()
unload Interp
interp HscEnv
hsc_env [Linkable]
stable_linkables
let full_mg, partial_mg0, partial_mg, unstable_mg :: [SCC ModuleGraphNode]
stable_mg :: [SCC ExtendedModSummary]
full_mg :: [SCC ModuleGraphNode]
full_mg = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
False ModuleGraph
mod_graph forall a. Maybe a
Nothing
maybe_top_mod :: Maybe ModuleName
maybe_top_mod = case LoadHowMuch
how_much of
LoadUpTo ModuleName
m -> forall a. a -> Maybe a
Just ModuleName
m
LoadDependenciesOf ModuleName
m -> forall a. a -> Maybe a
Just ModuleName
m
LoadHowMuch
_ -> forall a. Maybe a
Nothing
partial_mg0 :: [SCC ModuleGraphNode]
partial_mg0 = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
False ModuleGraph
mod_graph Maybe ModuleName
maybe_top_mod
partial_mg :: [SCC ModuleGraphNode]
partial_mg
| LoadDependenciesOf ModuleName
_mod <- LoadHowMuch
how_much
= ASSERT( case last partial_mg0 of
AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod; _ -> False )
forall a. [a] -> [a]
List.init [SCC ModuleGraphNode]
partial_mg0
| Bool
otherwise
= [SCC ModuleGraphNode]
partial_mg0
stable_mg :: [SCC ExtendedModSummary]
stable_mg =
[ forall vertex. vertex -> SCC vertex
AcyclicSCC ExtendedModSummary
ems
| AcyclicSCC (ModuleNode ems :: ExtendedModSummary
ems@(ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_)) <- [SCC ModuleGraphNode]
full_mg
, ModSummary -> Bool
stable_mod_summary ModSummary
ms
]
stable_mod_summary :: ModSummary -> Bool
stable_mod_summary ModSummary
ms =
ModSummary -> ModuleName
ms_mod_name ModSummary
ms forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj Bool -> Bool -> Bool
||
ModSummary -> ModuleName
ms_mod_name ModSummary
ms forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco
unstable_mg :: [SCC ModuleGraphNode]
unstable_mg = forall a. (a -> Bool) -> [a] -> [a]
filter SCC ModuleGraphNode -> Bool
not_stable [SCC ModuleGraphNode]
partial_mg
where not_stable :: SCC ModuleGraphNode -> Bool
not_stable (CyclicSCC [ModuleGraphNode]
_) = Bool
True
not_stable (AcyclicSCC (InstantiationNode InstantiatedUnit
_)) = Bool
True
not_stable (AcyclicSCC (ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_)))
= Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ModSummary -> Bool
stable_mod_summary ModSummary
ms
mg :: [SCC ModuleGraphNode]
mg = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtendedModSummary -> ModuleGraphNode
ModuleNode) [SCC ExtendedModSummary]
stable_mg forall a. [a] -> [a] -> [a]
++ [SCC ModuleGraphNode]
unstable_mg
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
text FilePath
"Ready for upsweep")
Int
2 (forall a. Outputable a => a -> SDoc
ppr [SCC ModuleGraphNode]
mg))
Int
n_jobs <- case DynFlags -> Maybe Int
parMakeCount DynFlags
dflags of
Maybe Int
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
Just Int
n -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
let upsweep_fn :: Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
upsweep_fn | Int
n_jobs forall a. Ord a => a -> a -> Bool
> Int
1 = forall (m :: * -> *).
GhcMonad m =>
Int
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
parUpsweep Int
n_jobs
| Bool
otherwise = forall (m :: * -> *).
GhcMonad m =>
Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
upsweep
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
emptyHomePackageTable }
(SuccessFlag
upsweep_ok, [ModuleGraphNode]
modsUpswept) <- forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics forall a b. (a -> b) -> a -> b
$
Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
upsweep_fn Maybe Messager
mHscMessage HomePackageTable
pruned_hpt StableModules
stable_mods [SCC ModuleGraphNode]
mg
let nodesDone :: [ModuleGraphNode]
nodesDone = forall a. [a] -> [a]
reverse [ModuleGraphNode]
modsUpswept
([InstantiatedUnit]
_, [ExtendedModSummary]
modsDone) = [ModuleGraphNode] -> ([InstantiatedUnit], [ExtendedModSummary])
partitionNodes [ModuleGraphNode]
nodesDone
if SuccessFlag -> Bool
succeeded SuccessFlag
upsweep_ok
then
do forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Upsweep completely successful.")
HscEnv
hsc_env1 <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles Logger
logger (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env1) DynFlags
dflags
let ofile :: Maybe FilePath
ofile = DynFlags -> Maybe FilePath
outputFile DynFlags
dflags
let no_hs_main :: Bool
no_hs_main = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags
let
main_mod :: Module
main_mod = HscEnv -> Module
mainModIs HscEnv
hsc_env
a_root_is_Main :: Bool
a_root_is_Main = ModuleGraph -> Module -> Bool
mgElemModule ModuleGraph
mod_graph Module
main_mod
do_linking :: Bool
do_linking = Bool
a_root_is_Main Bool -> Bool -> Bool
|| Bool
no_hs_main Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
== GhcLink
LinkDynLib Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
== GhcLink
LinkStaticLib
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
SuccessFlag
linkresult <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GhcLink
-> Logger
-> TmpFs
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
Logger
logger
(HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env)
(HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env)
DynFlags
dflags
(HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
Bool
do_linking
(HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env1)
if DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
== GhcLink
LinkBinary Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe FilePath
ofile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
do_linking
then do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
errorMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text
(FilePath
"output was redirected with -o, " forall a. [a] -> [a] -> [a]
++
FilePath
"but no output will be generated\n" forall a. [a] -> [a] -> [a]
++
FilePath
"because there is no " forall a. [a] -> [a] -> [a]
++
ModuleName -> FilePath
moduleNameString (forall unit. GenModule unit -> ModuleName
moduleName Module
main_mod) forall a. [a] -> [a] -> [a]
++ FilePath
" module.")
forall (m :: * -> *).
GhcMonad m =>
SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
Failed SuccessFlag
linkresult
else
forall (m :: * -> *).
GhcMonad m =>
SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
Succeeded SuccessFlag
linkresult
else
do forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Upsweep partially successful.")
let modsDone_names :: [Module]
modsDone_names
= forall a b. (a -> b) -> [a] -> [b]
map (ModSummary -> Module
ms_mod forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtendedModSummary -> ModSummary
emsModSummary) [ExtendedModSummary]
modsDone
let mods_to_zap_names :: Set Module
mods_to_zap_names
= [Module] -> [SCC ModSummary] -> Set Module
findPartiallyCompletedCycles [Module]
modsDone_names
[SCC ModSummary]
mg2_with_srcimps
let ([ModSummary]
mods_to_clean, [ModSummary]
mods_to_keep) =
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
mods_to_zap_names)forall b c a. (b -> c) -> (a -> b) -> a -> c
.ModSummary -> Module
ms_mod) forall a b. (a -> b) -> a -> b
$
ExtendedModSummary -> ModSummary
emsModSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExtendedModSummary]
modsDone
HscEnv
hsc_env1 <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let hpt4 :: HomePackageTable
hpt4 = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env1
unneeded_temps :: [FilePath]
unneeded_temps = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[FilePath
ms_hspp_file forall a. a -> [a] -> [a]
: [FilePath]
object_files
| ModSummary{Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod, FilePath
ms_hspp_file :: ModSummary -> FilePath
ms_hspp_file :: FilePath
ms_hspp_file} <- [ModSummary]
mods_to_clean
, let object_files :: [FilePath]
object_files = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Linkable -> [FilePath]
linkableObjs forall a b. (a -> b) -> a -> b
$
HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt4 (forall unit. GenModule unit -> ModuleName
moduleName Module
ms_mod)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HomeModInfo -> Maybe Linkable
hm_linkable
]
TmpFs
tmpfs <- HscEnv -> TmpFs
hsc_tmpfs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime TmpFs
tmpfs TempFileLifetime
TFL_CurrentModule [FilePath]
unneeded_temps
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles Logger
logger TmpFs
tmpfs DynFlags
dflags
let hpt5 :: HomePackageTable
hpt5 = [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs (forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
mods_to_keep)
HomePackageTable
hpt4
let just_linkables :: Bool
just_linkables =
GhcLink -> Bool
isNoLink (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
Bool -> Bool -> Bool
|| (HomeModInfo -> Bool) -> HomePackageTable -> Bool
allHpt (forall a. Maybe a -> Bool
isJustforall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> Maybe Linkable
hm_linkable)
((HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable
filterHpt ((forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_srcforall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> ModIface
hm_iface)
HomePackageTable
hpt5)
ASSERT( just_linkables ) do
hsc_env <- getSession
linkresult <- liftIO $ link (ghcLink dflags)
logger
(hsc_tmpfs hsc_env)
(hsc_hooks hsc_env)
dflags
(hsc_unit_env hsc_env)
False
hpt5
modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
loadFinish Failed linkresult
partitionNodes
:: [ModuleGraphNode]
-> ( [InstantiatedUnit]
, [ExtendedModSummary]
)
partitionNodes :: [ModuleGraphNode] -> ([InstantiatedUnit], [ExtendedModSummary])
partitionNodes [ModuleGraphNode]
ns = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ModuleGraphNode]
ns forall a b. (a -> b) -> a -> b
$ \case
InstantiationNode InstantiatedUnit
x -> forall a b. a -> Either a b
Left InstantiatedUnit
x
ModuleNode ExtendedModSummary
x -> forall a b. b -> Either a b
Right ExtendedModSummary
x
loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish :: forall (m :: * -> *).
GhcMonad m =>
SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
_all_ok SuccessFlag
Failed
= do HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> [Linkable] -> IO ()
unload Interp
interp HscEnv
hsc_env []
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardProg
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
loadFinish SuccessFlag
all_ok SuccessFlag
Succeeded
= do forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardIC
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
all_ok
discardProg :: HscEnv -> HscEnv
discardProg :: HscEnv -> HscEnv
discardProg HscEnv
hsc_env
= HscEnv -> HscEnv
discardIC forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
emptyMG
, hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
emptyHomePackageTable }
discardIC :: HscEnv -> HscEnv
discardIC :: HscEnv -> HscEnv
discardIC HscEnv
hsc_env
= HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
empty_ic { ic_int_print :: Name
ic_int_print = Name
new_ic_int_print
, ic_monad :: Name
ic_monad = Name
new_ic_monad
, ic_plugins :: [LoadedPlugin]
ic_plugins = [LoadedPlugin]
old_plugins
} }
where
!new_ic_int_print :: Name
new_ic_int_print = (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_int_print
!new_ic_monad :: Name
new_ic_monad = (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_monad
!old_plugins :: [LoadedPlugin]
old_plugins = InteractiveContext -> [LoadedPlugin]
ic_plugins InteractiveContext
old_ic
dflags :: DynFlags
dflags = InteractiveContext -> DynFlags
ic_dflags InteractiveContext
old_ic
old_ic :: InteractiveContext
old_ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
empty_ic :: InteractiveContext
empty_ic = DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
keep_external_name :: (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_name
| HomeUnit -> Name -> Bool
nameIsFromExternalPackage HomeUnit
home_unit Name
old_name = Name
old_name
| Bool
otherwise = InteractiveContext -> Name
ic_name InteractiveContext
empty_ic
where
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
old_name :: Name
old_name = InteractiveContext -> Name
ic_name InteractiveContext
old_ic
guessOutputFile :: GhcMonad m => m ()
guessOutputFile :: forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile = forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession forall a b. (a -> b) -> a -> b
$ \HscEnv
env ->
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env
!mod_graph :: ModuleGraph
mod_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
env
mainModuleSrcPath :: Maybe String
mainModuleSrcPath :: Maybe FilePath
mainModuleSrcPath = do
ModSummary
ms <- ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph
mod_graph (HscEnv -> Module
mainModIs HscEnv
env)
ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
name :: Maybe FilePath
name = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
dropExtension Maybe FilePath
mainModuleSrcPath
name_exe :: Maybe FilePath
name_exe = do
#if defined(mingw32_HOST_OS)
name' <- fmap (<.> "exe") name
#else
FilePath
name' <- Maybe FilePath
name
#endif
FilePath
mainModuleSrcPath' <- Maybe FilePath
mainModuleSrcPath
if FilePath
name' forall a. Eq a => a -> a -> Bool
== FilePath
mainModuleSrcPath'
then forall a. GhcException -> a
throwGhcException forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcException
UsageError forall a b. (a -> b) -> a -> b
$
FilePath
"default output name would overwrite the input file; " forall a. [a] -> [a] -> [a]
++
FilePath
"must specify -o explicitly"
else forall a. a -> Maybe a
Just FilePath
name'
in
case DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags of
Just FilePath
_ -> HscEnv
env
Maybe FilePath
Nothing -> HscEnv
env { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags { outputFile_ :: Maybe FilePath
outputFile_ = Maybe FilePath
name_exe } }
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set Module
findPartiallyCompletedCycles [Module]
modsDone [SCC ModSummary]
theGraph
= forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
[Set Module
mods_in_this_cycle
| CyclicSCC [ModSummary]
vs <- [SCC ModSummary]
theGraph
, let names_in_this_cycle :: Set Module
names_in_this_cycle = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> Module
ms_mod [ModSummary]
vs)
mods_in_this_cycle :: Set Module
mods_in_this_cycle =
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (forall a. Ord a => [a] -> Set a
Set.fromList [Module]
modsDone) Set Module
names_in_this_cycle
, forall a. Set a -> Int
Set.size Set Module
mods_in_this_cycle forall a. Ord a => a -> a -> Bool
< forall a. Set a -> Int
Set.size Set Module
names_in_this_cycle]
unload :: Interp -> HscEnv -> [Linkable] -> IO ()
unload :: Interp -> HscEnv -> [Linkable] -> IO ()
unload Interp
interp HscEnv
hsc_env [Linkable]
stable_linkables
= case DynFlags -> GhcLink
ghcLink (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) of
GhcLink
LinkInMemory -> Interp -> HscEnv -> [Linkable] -> IO ()
Linker.unload Interp
interp HscEnv
hsc_env [Linkable]
stable_linkables
GhcLink
_other -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
type StableModules =
( UniqSet ModuleName
, UniqSet ModuleName
)
checkStability
:: HomePackageTable
-> [SCC ModSummary]
-> UniqSet ModuleName
-> StableModules
checkStability :: HomePackageTable
-> [SCC ModSummary] -> UniqSet ModuleName -> StableModules
checkStability HomePackageTable
hpt [SCC ModSummary]
sccs UniqSet ModuleName
all_home_mods =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' StableModules -> SCC ModSummary -> StableModules
checkSCC (forall a. UniqSet a
emptyUniqSet, forall a. UniqSet a
emptyUniqSet) [SCC ModSummary]
sccs
where
checkSCC :: StableModules -> SCC ModSummary -> StableModules
checkSCC :: StableModules -> SCC ModSummary -> StableModules
checkSCC (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco) SCC ModSummary
scc0
| Bool
stableObjects = (forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
addListToUniqSet UniqSet ModuleName
stable_obj [ModuleName]
scc_mods, UniqSet ModuleName
stable_bco)
| Bool
stableBCOs = (UniqSet ModuleName
stable_obj, forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
addListToUniqSet UniqSet ModuleName
stable_bco [ModuleName]
scc_mods)
| Bool
otherwise = (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco)
where
scc :: [ModSummary]
scc = forall vertex. SCC vertex -> [vertex]
flattenSCC SCC ModSummary
scc0
scc_mods :: [ModuleName]
scc_mods = forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
scc
home_module :: ModuleName -> Bool
home_module ModuleName
m =
ModuleName
m forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
all_home_mods Bool -> Bool -> Bool
&& ModuleName
m forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
scc_mods
scc_allimps :: [ModuleName]
scc_allimps = forall a. Eq a => [a] -> [a]
nub (forall a. (a -> Bool) -> [a] -> [a]
filter ModuleName -> Bool
home_module (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [ModuleName]
ms_home_allimps [ModSummary]
scc))
stable_obj_imps :: [Bool]
stable_obj_imps = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj) [ModuleName]
scc_allimps
stable_bco_imps :: [Bool]
stable_bco_imps = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco) [ModuleName]
scc_allimps
stableObjects :: Bool
stableObjects =
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
stable_obj_imps
Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ModSummary -> Bool
object_ok [ModSummary]
scc
stableBCOs :: Bool
stableBCOs =
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(||) [Bool]
stable_obj_imps [Bool]
stable_bco_imps)
Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ModSummary -> Bool
bco_ok [ModSummary]
scc
object_ok :: ModSummary -> Bool
object_ok ModSummary
ms
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) = Bool
False
| Just UTCTime
t <- ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
ms = UTCTime
t forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
ms
Bool -> Bool -> Bool
&& UTCTime -> Bool
same_as_prev UTCTime
t
| Bool
otherwise = Bool
False
where
same_as_prev :: UTCTime -> Bool
same_as_prev UTCTime
t = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) of
Just HomeModInfo
hmi | Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi
-> Linkable -> Bool
isObjectLinkable Linkable
l Bool -> Bool -> Bool
&& UTCTime
t forall a. Eq a => a -> a -> Bool
== Linkable -> UTCTime
linkableTime Linkable
l
Maybe HomeModInfo
_other -> Bool
True
bco_ok :: ModSummary -> Bool
bco_ok ModSummary
ms
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) = Bool
False
| Bool
otherwise = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) of
Just HomeModInfo
hmi | Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi ->
Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
l) Bool -> Bool -> Bool
&&
Linkable -> UTCTime
linkableTime Linkable
l forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
ms
Maybe HomeModInfo
_other -> Bool
False
data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)])
!(MVar ())
type CompilationGraph = [(ModuleGraphNode, MVar SuccessFlag, LogQueue)]
buildCompGraph :: [SCC ModuleGraphNode] -> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph :: [SCC ModuleGraphNode]
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. Maybe a
Nothing)
buildCompGraph (SCC ModuleGraphNode
scc:[SCC ModuleGraphNode]
sccs) = case SCC ModuleGraphNode
scc of
AcyclicSCC ModuleGraphNode
ms -> do
MVar SuccessFlag
mvar <- forall a. IO (MVar a)
newEmptyMVar
LogQueue
log_queue <- do
IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref <- forall a. a -> IO (IORef a)
newIORef []
MVar ()
sem <- forall a. IO (MVar a)
newEmptyMVar
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> MVar () -> LogQueue
LogQueue IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref MVar ()
sem)
(CompilationGraph
rest,Maybe [ModuleGraphNode]
cycle) <- [SCC ModuleGraphNode]
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph [SCC ModuleGraphNode]
sccs
forall (m :: * -> *) a. Monad m => a -> m a
return ((ModuleGraphNode
ms,MVar SuccessFlag
mvar,LogQueue
log_queue)forall a. a -> [a] -> [a]
:CompilationGraph
rest, Maybe [ModuleGraphNode]
cycle)
CyclicSCC [ModuleGraphNode]
mss -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just [ModuleGraphNode]
mss)
data BuildModule = BuildModule_Unit {-# UNPACK #-} !InstantiatedUnit | BuildModule_Module {-# UNPACK #-} !ModuleWithIsBoot
deriving (BuildModule -> BuildModule -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuildModule -> BuildModule -> Bool
$c/= :: BuildModule -> BuildModule -> Bool
== :: BuildModule -> BuildModule -> Bool
$c== :: BuildModule -> BuildModule -> Bool
Eq, Eq BuildModule
BuildModule -> BuildModule -> Bool
BuildModule -> BuildModule -> Ordering
BuildModule -> BuildModule -> BuildModule
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BuildModule -> BuildModule -> BuildModule
$cmin :: BuildModule -> BuildModule -> BuildModule
max :: BuildModule -> BuildModule -> BuildModule
$cmax :: BuildModule -> BuildModule -> BuildModule
>= :: BuildModule -> BuildModule -> Bool
$c>= :: BuildModule -> BuildModule -> Bool
> :: BuildModule -> BuildModule -> Bool
$c> :: BuildModule -> BuildModule -> Bool
<= :: BuildModule -> BuildModule -> Bool
$c<= :: BuildModule -> BuildModule -> Bool
< :: BuildModule -> BuildModule -> Bool
$c< :: BuildModule -> BuildModule -> Bool
compare :: BuildModule -> BuildModule -> Ordering
$ccompare :: BuildModule -> BuildModule -> Ordering
Ord)
hscSourceToIsBoot :: HscSource -> IsBootInterface
hscSourceToIsBoot :: HscSource -> IsBootInterface
hscSourceToIsBoot HscSource
HsBootFile = IsBootInterface
IsBoot
hscSourceToIsBoot HscSource
_ = IsBootInterface
NotBoot
mkBuildModule :: ModuleGraphNode -> BuildModule
mkBuildModule :: ModuleGraphNode -> BuildModule
mkBuildModule = \case
InstantiationNode InstantiatedUnit
x -> InstantiatedUnit -> BuildModule
BuildModule_Unit InstantiatedUnit
x
ModuleNode ExtendedModSummary
ems -> ModuleWithIsBoot -> BuildModule
BuildModule_Module forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleWithIsBoot
mkBuildModule0 (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems)
mkHomeBuildModule :: ModuleGraphNode -> NodeKey
mkHomeBuildModule :: ModuleGraphNode -> NodeKey
mkHomeBuildModule = \case
InstantiationNode InstantiatedUnit
x -> InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
x
ModuleNode ExtendedModSummary
ems -> ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ ModSummary -> ModNodeKey
mkHomeBuildModule0 (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems)
mkBuildModule0 :: ModSummary -> ModuleWithIsBoot
mkBuildModule0 :: ModSummary -> ModuleWithIsBoot
mkBuildModule0 ModSummary
ms = GWIB
{ gwib_mod :: Module
gwib_mod = ModSummary -> Module
ms_mod ModSummary
ms
, gwib_isBoot :: IsBootInterface
gwib_isBoot = ModSummary -> IsBootInterface
isBootSummary ModSummary
ms
}
mkHomeBuildModule0 :: ModSummary -> ModuleNameWithIsBoot
mkHomeBuildModule0 :: ModSummary -> ModNodeKey
mkHomeBuildModule0 ModSummary
ms = GWIB
{ gwib_mod :: ModuleName
gwib_mod = forall unit. GenModule unit -> ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
ms
, gwib_isBoot :: IsBootInterface
gwib_isBoot = ModSummary -> IsBootInterface
isBootSummary ModSummary
ms
}
parUpsweep
:: GhcMonad m
=> Int
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag,
[ModuleGraphNode])
parUpsweep :: forall (m :: * -> *).
GhcMonad m =>
Int
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
parUpsweep Int
n_jobs Maybe Messager
mHscMessage HomePackageTable
old_hpt StableModules
stable_mods [SCC ModuleGraphNode]
sccs = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
MVar HscEnv
hsc_env_var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar HscEnv
hsc_env
IORef HomePackageTable
old_hpt_var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef HomePackageTable
old_hpt
QSem
par_sem <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO QSem
newQSem Int
n_jobs
let updNumCapabilities :: m Int
updNumCapabilities = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 = forall a. Ord a => a -> a -> a
min Int
n_jobs Int
n_cpus
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n_capabilities forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
n_caps
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n_capabilities
let resetNumCapabilities :: Int -> m ()
resetNumCapabilities Int
orig_n = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
orig_n
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket m Int
updNumCapabilities forall {m :: * -> *}. MonadIO m => Int -> m ()
resetNumCapabilities forall a b. (a -> b) -> a -> b
$ \Int
_ -> do
let finallySyncSession :: m (SuccessFlag, [ModuleGraphNode])
-> m (SuccessFlag, [ModuleGraphNode])
finallySyncSession m (SuccessFlag, [ModuleGraphNode])
io = m (SuccessFlag, [ModuleGraphNode])
io forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`MC.finally` do
HscEnv
hsc_env <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env
m (SuccessFlag, [ModuleGraphNode])
-> m (SuccessFlag, [ModuleGraphNode])
finallySyncSession forall a b. (a -> b) -> a -> b
$ do
(CompilationGraph
comp_graph,Maybe [ModuleGraphNode]
cycle) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [SCC ModuleGraphNode]
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph [SCC ModuleGraphNode]
sccs
let comp_graph_w_idx :: [((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx = forall a b. [a] -> [b] -> [(a, b)]
zip CompilationGraph
comp_graph [Int
1..]
let graph :: [ModuleGraphNode]
graph = forall a b. (a -> b) -> [a] -> [b]
map forall a b c. (a, b, c) -> a
fstOf3 (forall a. [a] -> [a]
reverse CompilationGraph
comp_graph)
boot_modules :: ModuleSet
boot_modules = [Module] -> ModuleSet
mkModuleSet
[ModSummary -> Module
ms_mod ModSummary
ms | ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_) <- [ModuleGraphNode]
graph, ModSummary -> IsBootInterface
isBootSummary ModSummary
ms forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot]
comp_graph_loops :: [[BuildModule]]
comp_graph_loops = [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
graph ModuleSet
boot_modules
where
remove :: ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
bm = case ModSummary -> IsBootInterface
isBootSummary ModSummary
ms of
IsBootInterface
IsBoot -> ModuleSet -> Module -> ModuleSet
delModuleSet ModuleSet
bm (ModSummary -> Module
ms_mod ModSummary
ms)
IsBootInterface
NotBoot -> ModuleSet
bm
go :: [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [] ModuleSet
_ = []
go (InstantiationNode InstantiatedUnit
_ : [ModuleGraphNode]
mss) ModuleSet
boot_modules
= [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
mss ModuleSet
boot_modules
go mg :: [ModuleGraphNode]
mg@(mnode :: ModuleGraphNode
mnode@(ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_)) : [ModuleGraphNode]
mss) ModuleSet
boot_modules
| Just [ModuleGraphNode]
loop <- ModSummary
-> [ModuleGraphNode] -> (Module -> Bool) -> Maybe [ModuleGraphNode]
getModLoop ModSummary
ms [ModuleGraphNode]
mg (Module -> ModuleSet -> Bool
`elemModuleSet` ModuleSet
boot_modules)
= forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> BuildModule
mkBuildModule (ModuleGraphNode
mnode forall a. a -> [a] -> [a]
: [ModuleGraphNode]
loop) forall a. a -> [a] -> [a]
: [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
mss (ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
boot_modules)
| Bool
otherwise
= [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
mss (ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
boot_modules)
let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
home_mod_map =
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ModuleGraphNode -> BuildModule
mkBuildModule ModuleGraphNode
ms, (MVar SuccessFlag
mvar, Int
idx))
| ((ModuleGraphNode
ms,MVar SuccessFlag
mvar,LogQueue
_),Int
idx) <- [((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx ]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self FilePath
"main --make thread"
Logger
thread_safe_logger <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> IO Logger
makeThreadSafe Logger
logger
let { spawnWorkers :: IO [ThreadId]
spawnWorkers = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx forall a b. (a -> b) -> a -> b
$ \((ModuleGraphNode
mod,!MVar SuccessFlag
mvar,!LogQueue
log_queue),!Int
mod_idx) ->
((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ FilePath
"worker --make thread" ]
, case ModuleGraphNode
mod of
InstantiationNode InstantiatedUnit
iuid ->
[ FilePath
"for instantiation of unit"
, forall a. Show a => a -> FilePath
show forall a b. (a -> b) -> a -> b
$ forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid
]
ModuleNode ExtendedModSummary
ems ->
[ FilePath
"for module"
, forall a. Show a => a -> FilePath
show (ModuleName -> FilePath
moduleNameString (ModSummary -> ModuleName
ms_mod_name (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems)))
]
, [FilePath
"number"
, forall a. Show a => a -> FilePath
show Int
mod_idx
]
]
let lcl_logger :: Logger
lcl_logger = (LogAction -> LogAction) -> Logger -> Logger
pushLogHook (forall a b. a -> b -> a
const (LogQueue -> LogAction
parLogAction LogQueue
log_queue)) Logger
thread_safe_logger
TmpFs
lcl_tmpfs <- TmpFs -> IO TmpFs
forkTmpFsFrom TmpFs
tmpfs
Either SomeException SuccessFlag
m_res <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors DynFlags
dflags forall a b. (a -> b) -> a -> b
$
case ModuleGraphNode
mod of
InstantiationNode InstantiatedUnit
iuid -> do
HscEnv
hsc_env <- forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe Messager -> Int -> Int -> InstantiatedUnit -> IO ()
upsweep_inst HscEnv
hsc_env Maybe Messager
mHscMessage Int
mod_idx (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModuleGraphNode]
sccs) InstantiatedUnit
iuid
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
Succeeded
ModuleNode ExtendedModSummary
ems ->
ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> Logger
-> TmpFs
-> DynFlags
-> HomeUnit
-> Maybe Messager
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> StableModules
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems) Map BuildModule (MVar SuccessFlag, Int)
home_mod_map [[BuildModule]]
comp_graph_loops
Logger
lcl_logger TmpFs
lcl_tmpfs DynFlags
dflags (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env)
Maybe Messager
mHscMessage
QSem
par_sem MVar HscEnv
hsc_env_var IORef HomePackageTable
old_hpt_var
StableModules
stable_mods Int
mod_idx (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModuleGraphNode]
sccs)
SuccessFlag
res <- case Either SomeException SuccessFlag
m_res of
Right SuccessFlag
flag -> forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
flag
Left SomeException
exc -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just AsyncException
ThreadKilled)
(Logger -> DynFlags -> SDoc -> IO ()
errorMsg Logger
lcl_logger DynFlags
dflags (FilePath -> SDoc
text (forall a. Show a => a -> FilePath
show SomeException
exc)))
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
forall a. MVar a -> a -> IO ()
putMVar MVar SuccessFlag
mvar SuccessFlag
res
LogQueue -> Maybe (WarnReason, Severity, SrcSpan, SDoc) -> IO ()
writeLogQueue LogQueue
log_queue forall a. Maybe a
Nothing
TmpFs -> TmpFs -> IO ()
mergeTmpFsInto TmpFs
lcl_tmpfs TmpFs
tmpfs
; killWorkers :: [ThreadId] -> IO ()
killWorkers = forall (m :: * -> *) a. MonadMask m => m a -> m a
MC.uninterruptibleMask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread }
[Maybe ModuleGraphNode]
results <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO [ThreadId]
spawnWorkers [ThreadId] -> IO ()
killWorkers forall a b. (a -> b) -> a -> b
$ \[ThreadId]
_ ->
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM CompilationGraph
comp_graph forall a b. (a -> b) -> a -> b
$ \(ModuleGraphNode
mod,MVar SuccessFlag
mvar,LogQueue
log_queue) -> do
Logger -> DynFlags -> LogQueue -> IO ()
printLogs Logger
logger DynFlags
dflags LogQueue
log_queue
SuccessFlag
result <- forall a. MVar a -> IO a
readMVar MVar SuccessFlag
mvar
if SuccessFlag -> Bool
succeeded SuccessFlag
result then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ModuleGraphNode
mod) else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
let ok_results :: [ModuleGraphNode]
ok_results = forall a. [a] -> [a]
reverse (forall a. [Maybe a] -> [a]
catMaybes [Maybe ModuleGraphNode]
results)
case Maybe [ModuleGraphNode]
cycle of
Just [ModuleGraphNode]
mss -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
fatalErrorMsg Logger
logger DynFlags
dflags ([ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
mss)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed,[ModuleGraphNode]
ok_results)
Maybe [ModuleGraphNode]
Nothing -> do
let success_flag :: SuccessFlag
success_flag = Bool -> SuccessFlag
successIf (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Maybe a -> Bool
isJust [Maybe ModuleGraphNode]
results)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
success_flag,[ModuleGraphNode]
ok_results)
where
writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,SDoc) -> IO ()
writeLogQueue :: LogQueue -> Maybe (WarnReason, Severity, SrcSpan, SDoc) -> IO ()
writeLogQueue (LogQueue IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref MVar ()
sem) Maybe (WarnReason, Severity, SrcSpan, SDoc)
msg = do
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref forall a b. (a -> b) -> a -> b
$ \[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs -> (Maybe (WarnReason, Severity, SrcSpan, SDoc)
msgforall a. a -> [a] -> [a]
:[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs,())
Bool
_ <- forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
sem ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
parLogAction :: LogQueue -> LogAction
parLogAction :: LogQueue -> LogAction
parLogAction LogQueue
log_queue DynFlags
_dflags !WarnReason
reason !Severity
severity !SrcSpan
srcSpan !SDoc
msg =
LogQueue -> Maybe (WarnReason, Severity, SrcSpan, SDoc) -> IO ()
writeLogQueue LogQueue
log_queue (forall a. a -> Maybe a
Just (WarnReason
reason,Severity
severity,SrcSpan
srcSpan,SDoc
msg))
printLogs :: Logger -> DynFlags -> LogQueue -> IO ()
printLogs :: Logger -> DynFlags -> LogQueue -> IO ()
printLogs !Logger
logger !DynFlags
dflags (LogQueue IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref MVar ()
sem) = IO ()
read_msgs
where read_msgs :: IO ()
read_msgs = do
forall a. MVar a -> IO a
takeMVar MVar ()
sem
[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref forall a b. (a -> b) -> a -> b
$ \[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs -> ([], forall a. [a] -> [a]
reverse [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs)
[Maybe (WarnReason, Severity, SrcSpan, SDoc)] -> IO ()
print_loop [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs
print_loop :: [Maybe (WarnReason, Severity, SrcSpan, SDoc)] -> IO ()
print_loop [] = IO ()
read_msgs
print_loop (Maybe (WarnReason, Severity, SrcSpan, SDoc)
x:[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs) = case Maybe (WarnReason, Severity, SrcSpan, SDoc)
x of
Just (WarnReason
reason,Severity
severity,SrcSpan
srcSpan,SDoc
msg) -> do
Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
reason Severity
severity SrcSpan
srcSpan SDoc
msg
[Maybe (WarnReason, Severity, SrcSpan, SDoc)] -> IO ()
print_loop [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs
Maybe (WarnReason, Severity, SrcSpan, SDoc)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
parUpsweep_one
:: ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> Logger
-> TmpFs
-> DynFlags
-> HomeUnit
-> Maybe Messager
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> StableModules
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one :: ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> Logger
-> TmpFs
-> DynFlags
-> HomeUnit
-> Maybe Messager
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> StableModules
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one ModSummary
mod Map BuildModule (MVar SuccessFlag, Int)
home_mod_map [[BuildModule]]
comp_graph_loops Logger
lcl_logger TmpFs
lcl_tmpfs DynFlags
lcl_dflags HomeUnit
home_unit Maybe Messager
mHscMessage QSem
par_sem
MVar HscEnv
hsc_env_var IORef HomePackageTable
old_hpt_var StableModules
stable_mods Int
mod_index Int
num_mods = do
let this_build_mod :: ModuleWithIsBoot
this_build_mod = ModSummary -> ModuleWithIsBoot
mkBuildModule0 ModSummary
mod
let home_imps :: [ModuleName]
home_imps = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
mod
let home_src_imps :: [ModuleName]
home_src_imps = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
mod
let textual_deps :: Set BuildModule
textual_deps = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ModuleName -> IsBootInterface -> BuildModule
f [ModuleName]
home_imps (forall a. a -> [a]
repeat IsBootInterface
NotBoot) forall a. [a] -> [a] -> [a]
++
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ModuleName -> IsBootInterface -> BuildModule
f [ModuleName]
home_src_imps (forall a. a -> [a]
repeat IsBootInterface
IsBoot)
where f :: ModuleName -> IsBootInterface -> BuildModule
f ModuleName
mn IsBootInterface
isBoot = ModuleWithIsBoot -> BuildModule
BuildModule_Module forall a b. (a -> b) -> a -> b
$ GWIB
{ gwib_mod :: Module
gwib_mod = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mn
, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
isBoot
}
let finish_loop :: Maybe [ModuleWithIsBoot]
finish_loop :: Maybe [ModuleWithIsBoot]
finish_loop = forall a. [a] -> Maybe a
listToMaybe
[ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. [a] -> [a]
tail [BuildModule]
loop) forall a b. (a -> b) -> a -> b
$ \case
BuildModule_Unit InstantiatedUnit
_ -> forall a. Maybe a
Nothing
BuildModule_Module ModuleWithIsBoot
ms -> forall a. a -> Maybe a
Just ModuleWithIsBoot
ms
| [BuildModule]
loop <- [[BuildModule]]
comp_graph_loops
, forall a. [a] -> a
head [BuildModule]
loop forall a. Eq a => a -> a -> Bool
== ModuleWithIsBoot -> BuildModule
BuildModule_Module ModuleWithIsBoot
this_build_mod
]
let int_loop_deps :: Set.Set BuildModule
int_loop_deps :: Set BuildModule
int_loop_deps = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
case Maybe [ModuleWithIsBoot]
finish_loop of
Maybe [ModuleWithIsBoot]
Nothing -> []
Just [ModuleWithIsBoot]
loop -> ModuleWithIsBoot -> BuildModule
BuildModule_Module forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= ModuleWithIsBoot
this_build_mod) [ModuleWithIsBoot]
loop
let ext_loop_deps :: Set.Set BuildModule
ext_loop_deps :: Set BuildModule
ext_loop_deps = forall a. Ord a => [a] -> Set a
Set.fromList
[ forall a. [a] -> a
head [BuildModule]
loop | [BuildModule]
loop <- [[BuildModule]]
comp_graph_loops
, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BuildModule
textual_deps) [BuildModule]
loop
, ModuleWithIsBoot -> BuildModule
BuildModule_Module ModuleWithIsBoot
this_build_mod forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [BuildModule]
loop ]
let all_deps :: Set BuildModule
all_deps = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Ord a => Set a -> Set a -> Set a
Set.union [Set BuildModule
textual_deps, Set BuildModule
int_loop_deps, Set BuildModule
ext_loop_deps]
let home_deps_with_idx :: [(MVar SuccessFlag, Int)]
home_deps_with_idx =
[ (MVar SuccessFlag, Int)
home_dep | BuildModule
dep <- forall a. Set a -> [a]
Set.toList Set BuildModule
all_deps
, Just (MVar SuccessFlag, Int)
home_dep <- [forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BuildModule
dep Map BuildModule (MVar SuccessFlag, Int)
home_mod_map]
]
let home_deps :: [MVar SuccessFlag]
home_deps = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd)) [(MVar SuccessFlag, Int)]
home_deps_with_idx
Bool
deps_ok <- forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SuccessFlag -> Bool
succeeded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO a
readMVar) [MVar SuccessFlag]
home_deps
if Bool -> Bool
not Bool
deps_ok
then forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
else do
HscEnv
hsc_env <- forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
HomePackageTable
old_hpt <- forall a. IORef a -> IO a
readIORef IORef HomePackageTable
old_hpt_var
let logg :: SourceError -> IO ()
logg SourceError
err = forall a.
RenderableDiagnostic a =>
Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
printBagOfErrors Logger
lcl_logger DynFlags
lcl_dflags (SourceError -> ErrorMessages
srcErrorMessages SourceError
err)
let withSem :: QSem -> IO b -> IO b
withSem QSem
sem = forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
MC.bracket_ (QSem -> IO ()
waitQSem QSem
sem) (QSem -> IO ()
signalQSem QSem
sem)
Maybe HomeModInfo
mb_mod_info <- forall {b}. QSem -> IO b -> IO b
withSem QSem
par_sem forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
err -> do SourceError -> IO ()
logg SourceError
err; forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
let lcl_hsc_env :: HscEnv
lcl_hsc_env = HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env
IORef (NameEnv TyThing)
type_env_var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. NameEnv a
emptyNameEnv
let lcl_hsc_env' :: HscEnv
lcl_hsc_env' = HscEnv
lcl_hsc_env { hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var =
forall a. a -> Maybe a
Just (ModSummary -> Module
ms_mod ModSummary
mod, IORef (NameEnv TyThing)
type_env_var) }
HscEnv
lcl_hsc_env'' <- case Maybe [ModuleWithIsBoot]
finish_loop of
Maybe [ModuleWithIsBoot]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
lcl_hsc_env'
Just [ModuleWithIsBoot]
loop -> DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
lcl_dflags HscEnv
lcl_hsc_env' forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= forall unit. GenModule unit -> ModuleName
moduleName (forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleWithIsBoot
this_build_mod)) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mod. GenWithIsBoot mod -> mod
gwib_mod) [ModuleWithIsBoot]
loop
HomeModInfo
mod_info <- HscEnv
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
lcl_hsc_env'' Maybe Messager
mHscMessage HomePackageTable
old_hpt StableModules
stable_mods
ModSummary
mod Int
mod_index Int
num_mods
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just HomeModInfo
mod_info)
case Maybe HomeModInfo
mb_mod_info of
Maybe HomeModInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
Just HomeModInfo
mod_info -> do
let this_mod :: ModuleName
this_mod = ModSummary -> ModuleName
ms_mod_name ModSummary
mod
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ModSummary -> IsBootInterface
isBootSummary ModSummary
mod forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) forall a b. (a -> b) -> a -> b
$
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef HomePackageTable
old_hpt_var forall a b. (a -> b) -> a -> b
$ \HomePackageTable
old_hpt ->
(HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt HomePackageTable
old_hpt ModuleName
this_mod, ())
HscEnv
lcl_hsc_env' <- forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar HscEnv
hsc_env_var forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
let hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env
{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
ModuleName
this_mod HomeModInfo
mod_info }
HscEnv
hsc_env'' <- case Maybe [ModuleWithIsBoot]
finish_loop of
Maybe [ModuleWithIsBoot]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env'
Just [ModuleWithIsBoot]
loop -> DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
lcl_dflags HscEnv
hsc_env' forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mod. GenWithIsBoot mod -> mod
gwib_mod) [ModuleWithIsBoot]
loop
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env'', HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env'')
Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles (HscEnv -> Logger
hsc_logger HscEnv
lcl_hsc_env')
(HscEnv -> TmpFs
hsc_tmpfs HscEnv
lcl_hsc_env')
(HscEnv -> DynFlags
hsc_dflags HscEnv
lcl_hsc_env')
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
where
localize_hsc_env :: HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env
= HscEnv
hsc_env { hsc_logger :: Logger
hsc_logger = Logger
lcl_logger
, hsc_tmpfs :: TmpFs
hsc_tmpfs = TmpFs
lcl_tmpfs
}
upsweep
:: forall m
. GhcMonad m
=> Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag,
[ModuleGraphNode])
upsweep :: forall (m :: * -> *).
GhcMonad m =>
Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
upsweep Maybe Messager
mHscMessage HomePackageTable
old_hpt StableModules
stable_mods [SCC ModuleGraphNode]
sccs = do
(SuccessFlag
res, ModuleGraph
done) <- HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
emptyMG [SCC ModuleGraphNode]
sccs Int
1 (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModuleGraphNode]
sccs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
res, forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
done)
where
keep_going
:: [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
keep_going :: [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
keep_going [NodeKey]
this_mods HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods Int
mod_index Int
nmods = do
let sum_deps :: [NodeKey] -> SCC ModuleGraphNode -> [NodeKey]
sum_deps [NodeKey]
ms (AcyclicSCC ModuleGraphNode
iuidOrMod) =
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem forall a b. (a -> b) -> a -> b
$ Bool -> ModuleGraphNode -> [NodeKey]
unfilteredEdges Bool
False ModuleGraphNode
iuidOrMod) forall a b. (a -> b) -> a -> b
$ [NodeKey]
ms
then ModuleGraphNode -> NodeKey
mkHomeBuildModule ModuleGraphNode
iuidOrMod forall a. a -> [a] -> [a]
: [NodeKey]
ms
else [NodeKey]
ms
sum_deps [NodeKey]
ms SCC ModuleGraphNode
_ = [NodeKey]
ms
dep_closure :: [NodeKey]
dep_closure = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [NodeKey] -> SCC ModuleGraphNode -> [NodeKey]
sum_deps [NodeKey]
this_mods [SCC ModuleGraphNode]
mods
dropped_ms :: [NodeKey]
dropped_ms = forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeKey]
this_mods) (forall a. [a] -> [a]
reverse [NodeKey]
dep_closure)
prunable :: SCC ModuleGraphNode -> Bool
prunable (AcyclicSCC ModuleGraphNode
node) = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (ModuleGraphNode -> NodeKey
mkHomeBuildModule ModuleGraphNode
node) [NodeKey]
dep_closure
prunable SCC ModuleGraphNode
_ = Bool
False
mods' :: [SCC ModuleGraphNode]
mods' = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC ModuleGraphNode -> Bool
prunable) [SCC ModuleGraphNode]
mods
nmods' :: Int
nmods' = Int
nmods forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeKey]
dropped_ms
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeKey]
dropped_ms) forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
fatalErrorMsg Logger
logger DynFlags
dflags ([NodeKey] -> SDoc
keepGoingPruneErr forall a b. (a -> b) -> a -> b
$ [NodeKey]
dropped_ms)
(SuccessFlag
_, ModuleGraph
done') <- HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods' (Int
mod_indexforall a. Num a => a -> a -> a
+Int
1) Int
nmods'
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done')
upsweep'
:: HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' :: HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
_old_hpt ModuleGraph
done
[] Int
_ Int
_
= forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Succeeded, ModuleGraph
done)
upsweep' HomePackageTable
_old_hpt ModuleGraph
done
(CyclicSCC [ModuleGraphNode]
ms : [SCC ModuleGraphNode]
mods) Int
mod_index Int
nmods
= do DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
fatalErrorMsg Logger
logger DynFlags
dflags ([ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
ms)
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepGoing DynFlags
dflags
then [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
keep_going (ModuleGraphNode -> NodeKey
mkHomeBuildModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleGraphNode]
ms) HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods Int
mod_index Int
nmods
else forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done)
upsweep' HomePackageTable
old_hpt ModuleGraph
done
(AcyclicSCC (InstantiationNode InstantiatedUnit
iuid) : [SCC ModuleGraphNode]
mods) Int
mod_index Int
nmods
= do HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe Messager -> Int -> Int -> InstantiatedUnit -> IO ()
upsweep_inst HscEnv
hsc_env Maybe Messager
mHscMessage Int
mod_index Int
nmods InstantiatedUnit
iuid
HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods (Int
mod_indexforall a. Num a => a -> a -> a
+Int
1) Int
nmods
upsweep' HomePackageTable
old_hpt ModuleGraph
done
(AcyclicSCC (ModuleNode ems :: ExtendedModSummary
ems@(ExtendedModSummary ModSummary
mod [InstantiatedUnit]
_)) : [SCC ModuleGraphNode]
mods) Int
mod_index Int
nmods
= do
let logg :: p -> Maybe SourceError -> m ()
logg p
_mod = WarnErrLogger
defaultWarnErrLogger
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
(HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env)
(HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
IORef (NameEnv TyThing)
type_env_var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. NameEnv a
emptyNameEnv
let hsc_env1 :: HscEnv
hsc_env1 = HscEnv
hsc_env { hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var =
forall a. a -> Maybe a
Just (ModSummary -> Module
ms_mod ModSummary
mod, IORef (NameEnv TyThing)
type_env_var) }
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env1
HscEnv
hsc_env2 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env1 ModSummary
mod ModuleGraph
done
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env2
Maybe HomeModInfo
mb_mod_info
<- forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError
(\SourceError
err -> do forall {m :: * -> *} {p}.
GhcMonad m =>
p -> Maybe SourceError -> m ()
logg ModSummary
mod (forall a. a -> Maybe a
Just SourceError
err); forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
HomeModInfo
mod_info <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
hsc_env2 Maybe Messager
mHscMessage HomePackageTable
old_hpt StableModules
stable_mods
ModSummary
mod Int
mod_index Int
nmods
forall {m :: * -> *} {p}.
GhcMonad m =>
p -> Maybe SourceError -> m ()
logg ModSummary
mod forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just HomeModInfo
mod_info)
case Maybe HomeModInfo
mb_mod_info of
Maybe HomeModInfo
Nothing -> do
DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepGoing DynFlags
dflags
then [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
keep_going [ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ ModSummary -> ModNodeKey
mkHomeBuildModule0 ModSummary
mod] HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods Int
mod_index Int
nmods
else forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done)
Just HomeModInfo
mod_info -> do
let this_mod :: ModuleName
this_mod = ModSummary -> ModuleName
ms_mod_name ModSummary
mod
hpt1 :: HomePackageTable
hpt1 = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env2) ModuleName
this_mod HomeModInfo
mod_info
hsc_env3 :: HscEnv
hsc_env3 = HscEnv
hsc_env2 { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
hpt1, hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var = forall a. Maybe a
Nothing }
old_hpt1 :: HomePackageTable
old_hpt1 = case ModSummary -> IsBootInterface
isBootSummary ModSummary
mod of
IsBootInterface
IsBoot -> HomePackageTable
old_hpt
IsBootInterface
NotBoot -> HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt HomePackageTable
old_hpt ModuleName
this_mod
done' :: ModuleGraph
done' = ModuleGraph -> ExtendedModSummary -> ModuleGraph
extendMG ModuleGraph
done ExtendedModSummary
ems
HscEnv
hsc_env4 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env3 ModSummary
mod ModuleGraph
done'
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env4
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env4) forall a. Eq a => a -> a -> Bool
== Backend
Interpreter) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env4
[ SptEntry
spt
| Just Linkable
linkable <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
mod_info
, Unlinked
unlinked <- Linkable -> [Unlinked]
linkableUnlinked Linkable
linkable
, BCOs CompiledByteCode
_ [SptEntry]
spts <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Unlinked
unlinked
, SptEntry
spt <- [SptEntry]
spts
]
HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt1 ModuleGraph
done' [SCC ModuleGraphNode]
mods (Int
mod_indexforall a. Num a => a -> a -> a
+Int
1) Int
nmods
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate DynFlags
dflags ModLocation
location
| DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags
= FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
location)
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
upsweep_inst :: HscEnv
-> Maybe Messager
-> Int
-> Int
-> InstantiatedUnit
-> IO ()
upsweep_inst :: HscEnv -> Maybe Messager -> Int -> Int -> InstantiatedUnit -> IO ()
upsweep_inst HscEnv
hsc_env Maybe Messager
mHscMessage Int
mod_index Int
nmods InstantiatedUnit
iuid = do
case Maybe Messager
mHscMessage of
Just Messager
hscMessage -> Messager
hscMessage HscEnv
hsc_env (Int
mod_index, Int
nmods) RecompileRequired
MustCompile (InstantiatedUnit -> ModuleGraphNode
InstantiationNode InstantiatedUnit
iuid)
Maybe Messager
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv -> Unit -> IO (Messages DecoratedSDoc, Maybe ())
tcRnCheckUnit HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
upsweep_mod :: HscEnv
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod :: HscEnv
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
hsc_env Maybe Messager
mHscMessage HomePackageTable
old_hpt (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco) ModSummary
summary Int
mod_index Int
nmods
= let
this_mod_name :: ModuleName
this_mod_name = ModSummary -> ModuleName
ms_mod_name ModSummary
summary
this_mod :: Module
this_mod = ModSummary -> Module
ms_mod ModSummary
summary
mb_obj_date :: Maybe UTCTime
mb_obj_date = ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
summary
mb_if_date :: Maybe UTCTime
mb_if_date = ModSummary -> Maybe UTCTime
ms_iface_date ModSummary
summary
obj_fn :: FilePath
obj_fn = ModLocation -> FilePath
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
summary)
hs_date :: UTCTime
hs_date = ModSummary -> UTCTime
ms_hs_date ModSummary
summary
is_stable_obj :: Bool
is_stable_obj = ModuleName
this_mod_name forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj
is_stable_bco :: Bool
is_stable_bco = ModuleName
this_mod_name forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco
old_hmi :: Maybe HomeModInfo
old_hmi = HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
old_hpt ModuleName
this_mod_name
lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary
prevailing_backend :: Backend
prevailing_backend = DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
local_backend :: Backend
local_backend = DynFlags -> Backend
backend DynFlags
lcl_dflags
bcknd :: Backend
bcknd = case (Backend
prevailing_backend,Backend
local_backend) of
(Backend
LLVM,Backend
NCG) -> Backend
NCG
(Backend
NCG,Backend
LLVM) -> Backend
LLVM
(Backend
NoBackend,Backend
b)
| Backend -> Bool
backendProducesObject Backend
b -> Backend
b
(Backend
Interpreter,Backend
b)
| Backend -> Bool
backendProducesObject Backend
b -> Backend
b
(Backend, Backend)
_ -> Backend
prevailing_backend
summary' :: ModSummary
summary' = ModSummary
summary{ ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
lcl_dflags { backend :: Backend
backend = Backend
bcknd } }
mb_old_iface :: Maybe ModIface
mb_old_iface
= case Maybe HomeModInfo
old_hmi of
Maybe HomeModInfo
Nothing -> forall a. Maybe a
Nothing
Just HomeModInfo
hm_info | ModSummary -> IsBootInterface
isBootSummary ModSummary
summary forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot -> forall a. a -> Maybe a
Just ModIface
iface
| ModIface -> IsBootInterface
mi_boot ModIface
iface forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot -> forall a. a -> Maybe a
Just ModIface
iface
| Bool
otherwise -> forall a. Maybe a
Nothing
where
iface :: ModIface
iface = HomeModInfo -> ModIface
hm_iface HomeModInfo
hm_info
compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it Maybe Linkable
mb_linkable SourceModified
src_modified =
Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' forall a. Maybe a
Nothing Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary' Int
mod_index Int
nmods
Maybe ModIface
mb_old_iface Maybe Linkable
mb_linkable SourceModified
src_modified
compile_it_discard_iface :: Maybe Linkable -> SourceModified
-> IO HomeModInfo
compile_it_discard_iface :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it_discard_iface Maybe Linkable
mb_linkable SourceModified
src_modified =
Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' forall a. Maybe a
Nothing Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary' Int
mod_index Int
nmods
forall a. Maybe a
Nothing Maybe Linkable
mb_linkable SourceModified
src_modified
is_fake_linkable :: Bool
is_fake_linkable
| Just HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi, Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi =
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Linkable -> [Unlinked]
linkableUnlinked Linkable
l)
| Bool
otherwise =
Bool
False
implies :: Bool -> Bool -> Bool
implies Bool
False Bool
_ = Bool
True
implies Bool
True Bool
x = Bool
x
debug_trace :: Int -> SDoc -> IO ()
debug_trace Int
n SDoc
t = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int
n SDoc
t
in
case () of
()
_
| Bool
is_stable_obj, Just HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi -> do
Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"skipping stable obj mod:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi
| Bool
is_stable_obj, forall a. Maybe a -> Bool
isNothing Maybe HomeModInfo
old_hmi -> do
Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling stable on-disk mod:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Linkable
linkable <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Module -> FilePath -> UTCTime -> IO Linkable
findObjectLinkable Module
this_mod FilePath
obj_fn
(forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"upsweep1" Maybe UTCTime
mb_obj_date)
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (forall a. a -> Maybe a
Just Linkable
linkable) SourceModified
SourceUnmodifiedAndStable
| Bool -> Bool
not (Backend -> Bool
backendProducesObject Backend
bcknd), Bool
is_stable_bco,
(Backend
bcknd forall a. Eq a => a -> a -> Bool
/= Backend
NoBackend) Bool -> Bool -> Bool
`implies` Bool -> Bool
not Bool
is_fake_linkable ->
ASSERT(isJust old_hmi)
let Just HomeModInfo
hmi = Maybe HomeModInfo
old_hmi in do
Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"skipping stable BCO mod:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi
| Bool -> Bool
not (Backend -> Bool
backendProducesObject Backend
bcknd),
Just HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi,
Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi,
Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
l),
(Backend
bcknd forall a. Eq a => a -> a -> Bool
/= Backend
NoBackend) Bool -> Bool -> Bool
`implies` Bool -> Bool
not Bool
is_fake_linkable,
Linkable -> UTCTime
linkableTime Linkable
l forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
summary -> do
Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling non-stable BCO mod:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (forall a. a -> Maybe a
Just Linkable
l) SourceModified
SourceUnmodified
| Backend -> Bool
backendProducesObject Backend
bcknd,
Just UTCTime
obj_date <- Maybe UTCTime
mb_obj_date,
UTCTime
obj_date forall a. Ord a => a -> a -> Bool
>= UTCTime
hs_date -> do
case Maybe HomeModInfo
old_hmi of
Just HomeModInfo
hmi
| Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi,
Linkable -> Bool
isObjectLinkable Linkable
l Bool -> Bool -> Bool
&& Linkable -> UTCTime
linkableTime Linkable
l forall a. Eq a => a -> a -> Bool
== UTCTime
obj_date -> do
Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling mod with new on-disk obj:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (forall a. a -> Maybe a
Just Linkable
l) SourceModified
SourceUnmodified
Maybe HomeModInfo
_otherwise -> do
Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling mod with new on-disk obj2:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Linkable
linkable <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Module -> FilePath -> UTCTime -> IO Linkable
findObjectLinkable Module
this_mod FilePath
obj_fn UTCTime
obj_date
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it_discard_iface (forall a. a -> Maybe a
Just Linkable
linkable) SourceModified
SourceUnmodified
| DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
lcl_dflags,
Just UTCTime
if_date <- Maybe UTCTime
mb_if_date,
UTCTime
if_date forall a. Ord a => a -> a -> Bool
>= UTCTime
hs_date -> do
Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"skipping tc'd mod:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it forall a. Maybe a
Nothing SourceModified
SourceUnmodified
()
_otherwise -> do
Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling mod:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it forall a. Maybe a
Nothing SourceModified
SourceModified
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs [ModuleName]
keep_these HomePackageTable
hpt
= [(ModuleName, HomeModInfo)] -> HomePackageTable
listToHpt [ (ModuleName
mod, forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"retain" Maybe HomeModInfo
mb_mod_info)
| ModuleName
mod <- [ModuleName]
keep_these
, let mb_mod_info :: Maybe HomeModInfo
mb_mod_info = HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt ModuleName
mod
, forall a. Maybe a -> Bool
isJust Maybe HomeModInfo
mb_mod_info ]
reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env ModSummary
ms ModuleGraph
graph
| Just [ModuleGraphNode]
loop <- ModSummary
-> [ModuleGraphNode] -> (Module -> Bool) -> Maybe [ModuleGraphNode]
getModLoop ModSummary
ms [ModuleGraphNode]
mss Module -> Bool
appearsAsBoot
, let non_boot :: [ModSummary]
non_boot = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [ModuleGraphNode]
loop forall a b. (a -> b) -> a -> b
$ \case
InstantiationNode InstantiatedUnit
_ -> forall a. Maybe a
Nothing
ModuleNode ExtendedModSummary
ems -> do
let l :: ModSummary
l = ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ModSummary -> IsBootInterface
isBootSummary ModSummary
l forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot Bool -> Bool -> Bool
&& ModSummary -> Module
ms_mod ModSummary
l forall a. Eq a => a -> a -> Bool
== ModSummary -> Module
ms_mod ModSummary
ms
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModSummary
l
= DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) HscEnv
hsc_env (forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
non_boot)
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
where
mss :: [ModuleGraphNode]
mss = ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
graph
appearsAsBoot :: Module -> Bool
appearsAsBoot = (Module -> ModuleSet -> Bool
`elemModuleSet` ModuleGraph -> ModuleSet
mgBootModules ModuleGraph
graph)
getModLoop
:: ModSummary
-> [ModuleGraphNode]
-> (Module -> Bool)
-> Maybe [ModuleGraphNode]
getModLoop :: ModSummary
-> [ModuleGraphNode] -> (Module -> Bool) -> Maybe [ModuleGraphNode]
getModLoop ModSummary
ms [ModuleGraphNode]
graph Module -> Bool
appearsAsBoot
| ModSummary -> IsBootInterface
isBootSummary ModSummary
ms forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot
, Module -> Bool
appearsAsBoot Module
this_mod
, let mss :: [ModuleGraphNode]
mss = ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]
reachableBackwards (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) [ModuleGraphNode]
graph
= forall a. a -> Maybe a
Just [ModuleGraphNode]
mss
| Bool
otherwise
= forall a. Maybe a
Nothing
where
this_mod :: Module
this_mod = ModSummary -> Module
ms_mod ModSummary
ms
typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
dflags HscEnv
hsc_env [ModuleName]
mods = do
Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
text FilePath
"Re-typechecking loop: " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr [ModuleName]
mods
HomePackageTable
new_hpt <-
forall a. (a -> IO a) -> IO a
fixIO forall a b. (a -> b) -> a -> b
$ \HomePackageTable
new_hpt -> do
let new_hsc_env :: HscEnv
new_hsc_env = HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
new_hpt }
[ModDetails]
mds <- forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (FilePath -> SDoc
text FilePath
"typecheckLoop") HscEnv
new_hsc_env forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModIface -> IOEnv (Env IfGblEnv ()) ModDetails
typecheckIface forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis
let new_hpt :: HomePackageTable
new_hpt = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt HomePackageTable
old_hpt
(forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
mods [ HomeModInfo
hmi{ hm_details :: ModDetails
hm_details = ModDetails
details }
| (HomeModInfo
hmi,ModDetails
details) <- forall a b. [a] -> [b] -> [(a, b)]
zip [HomeModInfo]
hmis [ModDetails]
mds ])
forall (m :: * -> *) a. Monad m => a -> m a
return HomePackageTable
new_hpt
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
new_hpt }
where
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
old_hpt :: HomePackageTable
old_hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
hmis :: [HomeModInfo]
hmis = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"typecheckLoop" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
old_hpt) [ModuleName]
mods
reachableBackwards :: ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]
reachableBackwards :: ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]
reachableBackwards ModuleName
mod [ModuleGraphNode]
summaries
= [ forall key payload. Node key payload -> payload
node_payload SummaryNode
node | SummaryNode
node <- forall node. Graph node -> node -> [node]
reachableG (forall node. Graph node -> Graph node
transposeG Graph SummaryNode
graph) SummaryNode
root ]
where
(Graph SummaryNode
graph, NodeKey -> Maybe SummaryNode
lookup_node) = Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
False [ModuleGraphNode]
summaries
root :: SummaryNode
root = forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"reachableBackwards" (NodeKey -> Maybe SummaryNode
lookup_node forall a b. (a -> b) -> a -> b
$ ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mod IsBootInterface
IsBoot)
topSortModuleGraph
:: Bool
-> ModuleGraph
-> Maybe ModuleName
-> [SCC ModuleGraphNode]
topSortModuleGraph :: Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
drop_hs_boot_nodes ModuleGraph
module_graph Maybe ModuleName
mb_root_mod
= forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SummaryNode -> ModuleGraphNode
summaryNodeSummary) forall a b. (a -> b) -> a -> b
$ forall node. Graph node -> [SCC node]
stronglyConnCompG Graph SummaryNode
initial_graph
where
summaries :: [ModuleGraphNode]
summaries = ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
module_graph
(Graph SummaryNode
graph, NodeKey -> Maybe SummaryNode
lookup_node) =
Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
drop_hs_boot_nodes (forall a. [a] -> [a]
reverse [ModuleGraphNode]
summaries)
initial_graph :: Graph SummaryNode
initial_graph = case Maybe ModuleName
mb_root_mod of
Maybe ModuleName
Nothing -> Graph SummaryNode
graph
Just ModuleName
root_mod ->
let root :: SummaryNode
root | Just SummaryNode
node <- NodeKey -> Maybe SummaryNode
lookup_node forall a b. (a -> b) -> a -> b
$ ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
root_mod IsBootInterface
NotBoot
, Graph SummaryNode
graph forall node. Graph node -> node -> Bool
`hasVertexG` SummaryNode
node
= SummaryNode
node
| Bool
otherwise
= forall a. GhcException -> a
throwGhcException (FilePath -> GhcException
ProgramError FilePath
"module does not exist")
in forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq (seq :: forall a b. a -> b -> b
seq SummaryNode
root (forall node. Graph node -> node -> [node]
reachableG Graph SummaryNode
graph SummaryNode
root))
type SummaryNode = Node Int ModuleGraphNode
summaryNodeKey :: SummaryNode -> Int
summaryNodeKey :: SummaryNode -> Int
summaryNodeKey = forall key payload. Node key payload -> key
node_key
summaryNodeSummary :: SummaryNode -> ModuleGraphNode
summaryNodeSummary :: SummaryNode -> ModuleGraphNode
summaryNodeSummary = forall key payload. Node key payload -> payload
node_payload
unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]
unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]
unfilteredEdges Bool
drop_hs_boot_nodes = \case
InstantiationNode InstantiatedUnit
iuid ->
ModNodeKey -> NodeKey
NodeKey_Module forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB IsBootInterface
NotBoot forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. UniqDSet a -> [a]
uniqDSetToList (forall unit. GenInstantiatedUnit unit -> UniqDSet ModuleName
instUnitHoles InstantiatedUnit
iuid)
ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bds) ->
(ModNodeKey -> NodeKey
NodeKey_Module forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB IsBootInterface
hs_boot_key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
ms) forall a. [a] -> [a] -> [a]
++
(ModNodeKey -> NodeKey
NodeKey_Module forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB IsBootInterface
NotBoot forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
ms) forall a. [a] -> [a] -> [a]
++
[ ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
IsBoot
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Bool
drop_hs_boot_nodes Bool -> Bool -> Bool
|| ModSummary -> HscSource
ms_hsc_src ModSummary
ms forall a. Eq a => a -> a -> Bool
== HscSource
HsBootFile
] forall a. [a] -> [a] -> [a]
++
[ InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
inst_unit
| InstantiatedUnit
inst_unit <- [InstantiatedUnit]
bds
]
where
hs_boot_key :: IsBootInterface
hs_boot_key | Bool
drop_hs_boot_nodes = IsBootInterface
NotBoot
| Bool
otherwise = IsBootInterface
IsBoot
moduleGraphNodes :: Bool -> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes :: Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
drop_hs_boot_nodes [ModuleGraphNode]
summaries =
(forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [SummaryNode]
nodes, NodeKey -> Maybe SummaryNode
lookup_node)
where
numbered_summaries :: [(ModuleGraphNode, Int)]
numbered_summaries = forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleGraphNode]
summaries [Int
1..]
lookup_node :: NodeKey -> Maybe SummaryNode
lookup_node :: NodeKey -> Maybe SummaryNode
lookup_node NodeKey
key = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeKey
key (forall a. NodeMap a -> Map NodeKey a
unNodeMap NodeMap SummaryNode
node_map)
lookup_key :: NodeKey -> Maybe Int
lookup_key :: NodeKey -> Maybe Int
lookup_key = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SummaryNode -> Int
summaryNodeKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> Maybe SummaryNode
lookup_node
node_map :: NodeMap SummaryNode
node_map :: NodeMap SummaryNode
node_map = forall a. Map NodeKey a -> NodeMap a
NodeMap forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ModuleGraphNode -> NodeKey
mkHomeBuildModule ModuleGraphNode
s, SummaryNode
node)
| SummaryNode
node <- [SummaryNode]
nodes
, let s :: ModuleGraphNode
s = SummaryNode -> ModuleGraphNode
summaryNodeSummary SummaryNode
node
]
nodes :: [SummaryNode]
nodes :: [SummaryNode]
nodes = [ forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode ModuleGraphNode
s Int
key forall a b. (a -> b) -> a -> b
$ [NodeKey] -> [Int]
out_edge_keys forall a b. (a -> b) -> a -> b
$ Bool -> ModuleGraphNode -> [NodeKey]
unfilteredEdges Bool
drop_hs_boot_nodes ModuleGraphNode
s
| (ModuleGraphNode
s, Int
key) <- [(ModuleGraphNode, Int)]
numbered_summaries
, case ModuleGraphNode
s of
InstantiationNode InstantiatedUnit
_ -> Bool
True
ModuleNode ExtendedModSummary
ems -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ModSummary -> IsBootInterface
isBootSummary (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems) forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot Bool -> Bool -> Bool
&& Bool
drop_hs_boot_nodes
]
out_edge_keys :: [NodeKey] -> [Int]
out_edge_keys :: [NodeKey] -> [Int]
out_edge_keys = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe Int
lookup_key
type ModNodeKey = ModuleNameWithIsBoot
newtype ModNodeMap a = ModNodeMap { forall a. ModNodeMap a -> Map ModNodeKey a
unModNodeMap :: Map.Map ModNodeKey a }
deriving (forall a b. a -> ModNodeMap b -> ModNodeMap a
forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
$c<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
fmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
$cfmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
Functor, Functor ModNodeMap
Foldable ModNodeMap
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
sequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
Traversable, forall a. Eq a => a -> ModNodeMap a -> Bool
forall a. Num a => ModNodeMap a -> a
forall a. Ord a => ModNodeMap a -> a
forall m. Monoid m => ModNodeMap m -> m
forall a. ModNodeMap a -> Bool
forall a. ModNodeMap a -> Int
forall a. ModNodeMap a -> [a]
forall a. (a -> a -> a) -> ModNodeMap a -> a
forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => ModNodeMap a -> a
$cproduct :: forall a. Num a => ModNodeMap a -> a
sum :: forall a. Num a => ModNodeMap a -> a
$csum :: forall a. Num a => ModNodeMap a -> a
minimum :: forall a. Ord a => ModNodeMap a -> a
$cminimum :: forall a. Ord a => ModNodeMap a -> a
maximum :: forall a. Ord a => ModNodeMap a -> a
$cmaximum :: forall a. Ord a => ModNodeMap a -> a
elem :: forall a. Eq a => a -> ModNodeMap a -> Bool
$celem :: forall a. Eq a => a -> ModNodeMap a -> Bool
length :: forall a. ModNodeMap a -> Int
$clength :: forall a. ModNodeMap a -> Int
null :: forall a. ModNodeMap a -> Bool
$cnull :: forall a. ModNodeMap a -> Bool
toList :: forall a. ModNodeMap a -> [a]
$ctoList :: forall a. ModNodeMap a -> [a]
foldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
fold :: forall m. Monoid m => ModNodeMap m -> m
$cfold :: forall m. Monoid m => ModNodeMap m -> m
Foldable)
emptyModNodeMap :: ModNodeMap a
emptyModNodeMap :: forall a. ModNodeMap a
emptyModNodeMap = forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap forall k a. Map k a
Map.empty
modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert :: forall a. ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert ModNodeKey
k a
v (ModNodeMap Map ModNodeKey a
m) = forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ModNodeKey
k a
v Map ModNodeKey a
m)
modNodeMapElems :: ModNodeMap a -> [a]
modNodeMapElems :: forall a. ModNodeMap a -> [a]
modNodeMapElems (ModNodeMap Map ModNodeKey a
m) = forall k a. Map k a -> [a]
Map.elems Map ModNodeKey a
m
modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup :: forall a. ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup ModNodeKey
k (ModNodeMap Map ModNodeKey a
m) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModNodeKey
k Map ModNodeKey a
m
data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey
deriving (NodeKey -> NodeKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeKey -> NodeKey -> Bool
$c/= :: NodeKey -> NodeKey -> Bool
== :: NodeKey -> NodeKey -> Bool
$c== :: NodeKey -> NodeKey -> Bool
Eq, Eq NodeKey
NodeKey -> NodeKey -> Bool
NodeKey -> NodeKey -> Ordering
NodeKey -> NodeKey -> NodeKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NodeKey -> NodeKey -> NodeKey
$cmin :: NodeKey -> NodeKey -> NodeKey
max :: NodeKey -> NodeKey -> NodeKey
$cmax :: NodeKey -> NodeKey -> NodeKey
>= :: NodeKey -> NodeKey -> Bool
$c>= :: NodeKey -> NodeKey -> Bool
> :: NodeKey -> NodeKey -> Bool
$c> :: NodeKey -> NodeKey -> Bool
<= :: NodeKey -> NodeKey -> Bool
$c<= :: NodeKey -> NodeKey -> Bool
< :: NodeKey -> NodeKey -> Bool
$c< :: NodeKey -> NodeKey -> Bool
compare :: NodeKey -> NodeKey -> Ordering
$ccompare :: NodeKey -> NodeKey -> Ordering
Ord)
newtype NodeMap a = NodeMap { forall a. NodeMap a -> Map NodeKey a
unNodeMap :: Map.Map NodeKey a }
deriving (forall a b. a -> NodeMap b -> NodeMap a
forall a b. (a -> b) -> NodeMap a -> NodeMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> NodeMap b -> NodeMap a
$c<$ :: forall a b. a -> NodeMap b -> NodeMap a
fmap :: forall a b. (a -> b) -> NodeMap a -> NodeMap b
$cfmap :: forall a b. (a -> b) -> NodeMap a -> NodeMap b
Functor, Functor NodeMap
Foldable NodeMap
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => NodeMap (m a) -> m (NodeMap a)
forall (f :: * -> *) a.
Applicative f =>
NodeMap (f a) -> f (NodeMap a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NodeMap a -> m (NodeMap b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NodeMap a -> f (NodeMap b)
sequence :: forall (m :: * -> *) a. Monad m => NodeMap (m a) -> m (NodeMap a)
$csequence :: forall (m :: * -> *) a. Monad m => NodeMap (m a) -> m (NodeMap a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NodeMap a -> m (NodeMap b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NodeMap a -> m (NodeMap b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
NodeMap (f a) -> f (NodeMap a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
NodeMap (f a) -> f (NodeMap a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NodeMap a -> f (NodeMap b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NodeMap a -> f (NodeMap b)
Traversable, forall a. Eq a => a -> NodeMap a -> Bool
forall a. Num a => NodeMap a -> a
forall a. Ord a => NodeMap a -> a
forall m. Monoid m => NodeMap m -> m
forall a. NodeMap a -> Bool
forall a. NodeMap a -> Int
forall a. NodeMap a -> [a]
forall a. (a -> a -> a) -> NodeMap a -> a
forall m a. Monoid m => (a -> m) -> NodeMap a -> m
forall b a. (b -> a -> b) -> b -> NodeMap a -> b
forall a b. (a -> b -> b) -> b -> NodeMap a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => NodeMap a -> a
$cproduct :: forall a. Num a => NodeMap a -> a
sum :: forall a. Num a => NodeMap a -> a
$csum :: forall a. Num a => NodeMap a -> a
minimum :: forall a. Ord a => NodeMap a -> a
$cminimum :: forall a. Ord a => NodeMap a -> a
maximum :: forall a. Ord a => NodeMap a -> a
$cmaximum :: forall a. Ord a => NodeMap a -> a
elem :: forall a. Eq a => a -> NodeMap a -> Bool
$celem :: forall a. Eq a => a -> NodeMap a -> Bool
length :: forall a. NodeMap a -> Int
$clength :: forall a. NodeMap a -> Int
null :: forall a. NodeMap a -> Bool
$cnull :: forall a. NodeMap a -> Bool
toList :: forall a. NodeMap a -> [a]
$ctoList :: forall a. NodeMap a -> [a]
foldl1 :: forall a. (a -> a -> a) -> NodeMap a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> NodeMap a -> a
foldr1 :: forall a. (a -> a -> a) -> NodeMap a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> NodeMap a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
foldl :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
foldr :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
fold :: forall m. Monoid m => NodeMap m -> m
$cfold :: forall m. Monoid m => NodeMap m -> m
Foldable)
msKey :: ModSummary -> ModNodeKey
msKey :: ModSummary -> ModNodeKey
msKey = ModSummary -> ModNodeKey
mkHomeBuildModule0
mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey = \case
InstantiationNode InstantiatedUnit
x -> InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
x
ModuleNode ExtendedModSummary
x -> ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ ModSummary -> ModNodeKey
mkHomeBuildModule0 (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
x)
pprNodeKey :: NodeKey -> SDoc
pprNodeKey :: NodeKey -> SDoc
pprNodeKey (NodeKey_Unit InstantiatedUnit
iu) = forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
iu
pprNodeKey (NodeKey_Module ModNodeKey
mk) = forall a. Outputable a => a -> SDoc
ppr ModNodeKey
mk
mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
mkNodeMap [ExtendedModSummary]
summaries = forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (ModSummary -> ModNodeKey
msKey forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
s, ExtendedModSummary
s) | ExtendedModSummary
s <- [ExtendedModSummary]
summaries]
warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports :: forall (m :: * -> *). GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports [SCC ModSummary]
sccs = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnusedImports DynFlags
dflags)
(forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings (forall a. [a] -> Bag a
listToBag (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([ModSummary] -> [MsgEnvelope DecoratedSDoc]
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall vertex. SCC vertex -> [vertex]
flattenSCC) [SCC ModSummary]
sccs)))
where check :: [ModSummary] -> [MsgEnvelope DecoratedSDoc]
check [ModSummary]
ms =
let mods_in_this_cycle :: [ModuleName]
mods_in_this_cycle = forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
ms in
[ GenLocated SrcSpan ModuleName -> MsgEnvelope DecoratedSDoc
warn GenLocated SrcSpan ModuleName
i | ModSummary
m <- [ModSummary]
ms, GenLocated SrcSpan ModuleName
i <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
m,
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
mods_in_this_cycle ]
warn :: Located ModuleName -> WarnMsg
warn :: GenLocated SrcSpan ModuleName -> MsgEnvelope DecoratedSDoc
warn (L SrcSpan
loc ModuleName
mod) =
SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc
(FilePath -> SDoc
text FilePath
"Warning: {-# SOURCE #-} unnecessary in import of "
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
mod))
downsweep :: HscEnv
-> [ExtendedModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ExtendedModSummary]
downsweep :: HscEnv
-> [ExtendedModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ExtendedModSummary]
downsweep HscEnv
hsc_env [ExtendedModSummary]
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots
= do
[Either ErrorMessages ExtendedModSummary]
rootSummaries <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Target -> IO (Either ErrorMessages ExtendedModSummary)
getRootSummary [Target]
roots
let ([ErrorMessages]
errs, [ExtendedModSummary]
rootSummariesOk) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ErrorMessages ExtendedModSummary]
rootSummaries
root_map :: ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map = [ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
mkRootMap [ExtendedModSummary]
rootSummariesOk
ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO ()
checkDuplicates ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map
ModNodeMap [Either ErrorMessages ExtendedModSummary]
map0 <- [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ExtendedModSummary
-> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
calcDeps [ExtendedModSummary]
rootSummariesOk) ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map
let default_backend :: Backend
default_backend = Platform -> Backend
platformDefaultBackend (DynFlags -> Platform
targetPlatform DynFlags
dflags)
let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
ModNodeMap [Either ErrorMessages ExtendedModSummary]
map1 <- case DynFlags -> Backend
backend DynFlags
dflags of
Backend
NoBackend -> Logger
-> TmpFs
-> HomeUnit
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenForTH Logger
logger TmpFs
tmpfs HomeUnit
home_unit Backend
default_backend ModNodeMap [Either ErrorMessages ExtendedModSummary]
map0
Backend
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ModNodeMap [Either ErrorMessages ExtendedModSummary]
map0
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorMessages]
errs
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. ModNodeMap a -> [a]
modNodeMapElems ModNodeMap [Either ErrorMessages ExtendedModSummary]
map1
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left [ErrorMessages]
errs
where
calcDeps :: ExtendedModSummary
-> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
calcDeps (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_bkp_deps) = ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
msDeps ModSummary
ms
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
roots :: [Target]
roots = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
old_summary_map :: ModNodeMap ExtendedModSummary
old_summary_map :: ModNodeMap ExtendedModSummary
old_summary_map = [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
mkNodeMap [ExtendedModSummary]
old_summaries
getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)
getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)
getRootSummary (Target (TargetFile FilePath
file Maybe Phase
mb_phase) Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf)
= do Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
file
if Bool
exists Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe (InputFileBuffer, UTCTime)
maybe_buf
then HscEnv
-> [ExtendedModSummary]
-> FilePath
-> Maybe Phase
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either ErrorMessages ExtendedModSummary)
summariseFile HscEnv
hsc_env [ExtendedModSummary]
old_summaries FilePath
file Maybe Phase
mb_phase
Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
text FilePath
"can't find file:" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
file
getRootSummary (Target (TargetModule ModuleName
modl) Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf)
= do Maybe (Either ErrorMessages ExtendedModSummary)
maybe_summary <- HscEnv
-> ModNodeMap ExtendedModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
summariseModule HscEnv
hsc_env ModNodeMap ExtendedModSummary
old_summary_map IsBootInterface
NotBoot
(forall l e. l -> e -> GenLocated l e
L SrcSpan
rootLoc ModuleName
modl) Bool
obj_allowed
Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
case Maybe (Either ErrorMessages ExtendedModSummary)
maybe_summary of
Maybe (Either ErrorMessages ExtendedModSummary)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ModuleName -> ErrorMessages
moduleNotFoundErr ModuleName
modl
Just Either ErrorMessages ExtendedModSummary
s -> forall (m :: * -> *) a. Monad m => a -> m a
return Either ErrorMessages ExtendedModSummary
s
rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"<command line>")
checkDuplicates
:: ModNodeMap
[Either ErrorMessages
ExtendedModSummary]
-> IO ()
checkDuplicates :: ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO ()
checkDuplicates ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map
| Bool
allow_dup_roots = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ExtendedModSummary]]
dup_roots = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [ModSummary] -> IO ()
multiRootsErr (ExtendedModSummary -> ModSummary
emsModSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> a
head [[ExtendedModSummary]]
dup_roots)
where
dup_roots :: [[ExtendedModSummary]]
dup_roots :: [[ExtendedModSummary]]
dup_roots = forall a. (a -> Bool) -> [a] -> [a]
filterOut forall a. [a] -> Bool
isSingleton forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. [Either a b] -> [b]
rights forall a b. (a -> b) -> a -> b
$ forall a. ModNodeMap a -> [a]
modNodeMapElems ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map
loop :: [GenWithIsBoot (Located ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop :: [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop [] ModNodeMap [Either ErrorMessages ExtendedModSummary]
done = forall (m :: * -> *) a. Monad m => a -> m a
return ModNodeMap [Either ErrorMessages ExtendedModSummary]
done
loop (GenWithIsBoot (GenLocated SrcSpan ModuleName)
s : [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss) ModNodeMap [Either ErrorMessages ExtendedModSummary]
done
| Just [Either ErrorMessages ExtendedModSummary]
summs <- forall a. ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup ModNodeKey
key ModNodeMap [Either ErrorMessages ExtendedModSummary]
done
= if forall a. [a] -> Bool
isSingleton [Either ErrorMessages ExtendedModSummary]
summs then
[GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss ModNodeMap [Either ErrorMessages ExtendedModSummary]
done
else
do { [ModSummary] -> IO ()
multiRootsErr (ExtendedModSummary -> ModSummary
emsModSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [Either a b] -> [b]
rights [Either ErrorMessages ExtendedModSummary]
summs)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap forall k a. Map k a
Map.empty)
}
| Bool
otherwise
= do Maybe (Either ErrorMessages ExtendedModSummary)
mb_s <- HscEnv
-> ModNodeMap ExtendedModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
summariseModule HscEnv
hsc_env ModNodeMap ExtendedModSummary
old_summary_map
IsBootInterface
is_boot GenLocated SrcSpan ModuleName
wanted_mod Bool
True
forall a. Maybe a
Nothing [ModuleName]
excl_mods
case Maybe (Either ErrorMessages ExtendedModSummary)
mb_s of
Maybe (Either ErrorMessages ExtendedModSummary)
Nothing -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss ModNodeMap [Either ErrorMessages ExtendedModSummary]
done
Just (Left ErrorMessages
e) -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss (forall a. ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert ModNodeKey
key [forall a b. a -> Either a b
Left ErrorMessages
e] ModNodeMap [Either ErrorMessages ExtendedModSummary]
done)
Just (Right ExtendedModSummary
s)-> do
ModNodeMap [Either ErrorMessages ExtendedModSummary]
new_map <-
[GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop (ExtendedModSummary
-> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
calcDeps ExtendedModSummary
s) (forall a. ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert ModNodeKey
key [forall a b. b -> Either a b
Right ExtendedModSummary
s] ModNodeMap [Either ErrorMessages ExtendedModSummary]
done)
[GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss ModNodeMap [Either ErrorMessages ExtendedModSummary]
new_map
where
GWIB { gwib_mod :: forall mod. GenWithIsBoot mod -> mod
gwib_mod = L SrcSpan
loc ModuleName
mod, gwib_isBoot :: forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot = IsBootInterface
is_boot } = GenWithIsBoot (GenLocated SrcSpan ModuleName)
s
wanted_mod :: GenLocated SrcSpan ModuleName
wanted_mod = forall l e. l -> e -> GenLocated l e
L SrcSpan
loc ModuleName
mod
key :: ModNodeKey
key = GWIB
{ gwib_mod :: ModuleName
gwib_mod = forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
wanted_mod
, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
is_boot
}
enableCodeGenForTH
:: Logger
-> TmpFs
-> HomeUnit
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenForTH :: Logger
-> TmpFs
-> HomeUnit
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenForTH Logger
logger TmpFs
tmpfs HomeUnit
home_unit =
Logger
-> TmpFs
-> (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenWhen Logger
logger TmpFs
tmpfs ModSummary -> Bool
condition ModSummary -> Bool
should_modify TempFileLifetime
TFL_CurrentModule TempFileLifetime
TFL_GhcSession
where
condition :: ModSummary -> Bool
condition = ModSummary -> Bool
isTemplateHaskellOrQQNonBoot
should_modify :: ModSummary -> Bool
should_modify (ModSummary { ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags }) =
DynFlags -> Backend
backend DynFlags
dflags forall a. Eq a => a -> a -> Bool
== Backend
NoBackend Bool -> Bool -> Bool
&&
forall u. GenHomeUnit u -> Bool
isHomeUnitDefinite HomeUnit
home_unit
enableCodeGenWhen
:: Logger
-> TmpFs
-> (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenWhen :: Logger
-> TmpFs
-> (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenWhen Logger
logger TmpFs
tmpfs ModSummary -> Bool
condition ModSummary -> Bool
should_modify TempFileLifetime
staticLife TempFileLifetime
dynLife Backend
bcknd ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap =
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ExtendedModSummary -> IO ExtendedModSummary
enable_code_gen)) ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap
where
enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary
enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary
enable_code_gen (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bkp_deps)
| ModSummary
{ ms_mod :: ModSummary -> Module
ms_mod = Module
ms_mod
, ms_location :: ModSummary -> ModLocation
ms_location = ModLocation
ms_location
, ms_hsc_src :: ModSummary -> HscSource
ms_hsc_src = HscSource
HsSrcFile
, ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags
} <- ModSummary
ms
, ModSummary -> Bool
should_modify ModSummary
ms
, Module
ms_mod forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
needs_codegen_set
= do
let new_temp_file :: FilePath -> FilePath -> IO FilePath
new_temp_file FilePath
suf FilePath
dynsuf = do
FilePath
tn <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs DynFlags
dflags TempFileLifetime
staticLife FilePath
suf
let dyn_tn :: FilePath
dyn_tn = FilePath
tn FilePath -> FilePath -> FilePath
-<.> FilePath
dynsuf
TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
dynLife [FilePath
dyn_tn]
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
tn
(FilePath
hi_file, FilePath
o_file) <-
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
then forall (m :: * -> *) a. Monad m => a -> m a
return (ModLocation -> FilePath
ml_hi_file ModLocation
ms_location, ModLocation -> FilePath
ml_obj_file ModLocation
ms_location)
else (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> IO FilePath
new_temp_file (DynFlags -> FilePath
hiSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynHiSuf_ DynFlags
dflags))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> FilePath -> IO FilePath
new_temp_file (DynFlags -> FilePath
objectSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynObjectSuf_ DynFlags
dflags))
let ms' :: ModSummary
ms' = ModSummary
ms
{ ms_location :: ModLocation
ms_location =
ModLocation
ms_location {ml_hi_file :: FilePath
ml_hi_file = FilePath
hi_file, ml_obj_file :: FilePath
ml_obj_file = FilePath
o_file}
, ms_hspp_opts :: DynFlags
ms_hspp_opts = Int -> DynFlags -> DynFlags
updOptLevel Int
0 forall a b. (a -> b) -> a -> b
$ DynFlags
dflags {backend :: Backend
backend = Backend
bcknd}
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModSummary -> [InstantiatedUnit] -> ExtendedModSummary
ExtendedModSummary ModSummary
ms' [InstantiatedUnit]
bkp_deps)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> [InstantiatedUnit] -> ExtendedModSummary
ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bkp_deps)
needs_codegen_set :: Set Module
needs_codegen_set = [ModSummary] -> Set Module
transitive_deps_set
[ ModSummary
ms
| [Either ErrorMessages ExtendedModSummary]
mss <- forall a. ModNodeMap a -> [a]
modNodeMapElems ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap
, Right (ExtendedModSummary { emsModSummary :: ExtendedModSummary -> ModSummary
emsModSummary = ModSummary
ms }) <- [Either ErrorMessages ExtendedModSummary]
mss
, ModSummary -> Bool
condition ModSummary
ms
]
transitive_deps_set :: [ModSummary] -> Set.Set Module
transitive_deps_set :: [ModSummary] -> Set Module
transitive_deps_set [ModSummary]
modSums = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Module -> ModSummary -> Set Module
go forall a. Set a
Set.empty [ModSummary]
modSums
where
go :: Set Module -> ModSummary -> Set Module
go Set Module
marked_mods ms :: ModSummary
ms@ModSummary{Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod}
| Module
ms_mod forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
marked_mods = Set Module
marked_mods
| Bool
otherwise =
let deps :: [ModSummary]
deps =
[ ModSummary
dep_ms
| GenWithIsBoot (GenLocated SrcSpan ModuleName)
dep <- ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
msDeps ModSummary
ms
, IsBootInterface
NotBoot forall a. Eq a => a -> a -> Bool
== forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot GenWithIsBoot (GenLocated SrcSpan ModuleName)
dep
, [Either ErrorMessages ExtendedModSummary]
dep_ms_0 <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall a. ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup (forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenWithIsBoot (GenLocated SrcSpan ModuleName)
dep) ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap
, Either ErrorMessages ExtendedModSummary
dep_ms_1 <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ [Either ErrorMessages ExtendedModSummary]
dep_ms_0
, (ExtendedModSummary { emsModSummary :: ExtendedModSummary -> ModSummary
emsModSummary = ModSummary
dep_ms }) <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ Either ErrorMessages ExtendedModSummary
dep_ms_1
]
new_marked_mods :: Set Module
new_marked_mods = forall a. Ord a => a -> Set a -> Set a
Set.insert Module
ms_mod Set Module
marked_mods
in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Module -> ModSummary -> Set Module
go Set Module
new_marked_mods [ModSummary]
deps
mkRootMap
:: [ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
mkRootMap :: [ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
mkRootMap [ExtendedModSummary]
summaries = forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap forall a b. (a -> b) -> a -> b
$ forall key elt.
Ord key =>
(elt -> elt -> elt) -> [(key, elt)] -> Map key elt -> Map key elt
Map.insertListWith
(forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. [a] -> [a] -> [a]
(++))
[ (ModSummary -> ModNodeKey
msKey forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
s, [forall a b. b -> Either a b
Right ExtendedModSummary
s]) | ExtendedModSummary
s <- [ExtendedModSummary]
summaries ]
forall k a. Map k a
Map.empty
msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]
msDeps :: ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
msDeps ModSummary
s = [ GenWithIsBoot (GenLocated SrcSpan ModuleName)
d
| GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
s
, GenWithIsBoot (GenLocated SrcSpan ModuleName)
d <- [ GWIB { gwib_mod :: GenLocated SrcSpan ModuleName
gwib_mod = GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
IsBoot }
, GWIB { gwib_mod :: GenLocated SrcSpan ModuleName
gwib_mod = GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
]
]
forall a. [a] -> [a] -> [a]
++ [ GWIB { gwib_mod :: GenLocated SrcSpan ModuleName
gwib_mod = GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
| GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
s
]
summariseFile
:: HscEnv
-> [ExtendedModSummary]
-> FilePath
-> Maybe Phase
-> Bool
-> Maybe (StringBuffer,UTCTime)
-> IO (Either ErrorMessages ExtendedModSummary)
summariseFile :: HscEnv
-> [ExtendedModSummary]
-> FilePath
-> Maybe Phase
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either ErrorMessages ExtendedModSummary)
summariseFile HscEnv
hsc_env [ExtendedModSummary]
old_summaries FilePath
src_fn Maybe Phase
mb_phase Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf
| Just ExtendedModSummary
old_summary <- [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary
findSummaryBySourceFile [ExtendedModSummary]
old_summaries FilePath
src_fn
= do
let location :: ModLocation
location = ModSummary -> ModLocation
ms_location forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
old_summary
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
UTCTime
src_timestamp <- IO UTCTime
get_src_timestamp
forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBootInterface
-> (UTCTime -> IO (Either e ExtendedModSummary))
-> ExtendedModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ExtendedModSummary)
checkSummaryTimestamp
HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBootInterface
NotBoot (FilePath -> UTCTime -> IO (Either ErrorMessages ExtendedModSummary)
new_summary FilePath
src_fn)
ExtendedModSummary
old_summary ModLocation
location UTCTime
src_timestamp
| Bool
otherwise
= do UTCTime
src_timestamp <- IO UTCTime
get_src_timestamp
FilePath -> UTCTime -> IO (Either ErrorMessages ExtendedModSummary)
new_summary FilePath
src_fn UTCTime
src_timestamp
where
get_src_timestamp :: IO UTCTime
get_src_timestamp = case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
Just (InputFileBuffer
_,UTCTime
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
t
Maybe (InputFileBuffer, UTCTime)
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationUTCTime FilePath
src_fn
new_summary :: FilePath -> UTCTime -> IO (Either ErrorMessages ExtendedModSummary)
new_summary FilePath
src_fn UTCTime
src_timestamp = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
preimps :: PreprocessedImports
preimps@PreprocessedImports {FilePath
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
ModuleName
DynFlags
InputFileBuffer
SrcSpan
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_theimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
..}
<- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf
ModLocation
location <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> FilePath -> IO ModLocation
mkHomeModLocation (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) ModuleName
pi_mod_name FilePath
src_fn
Module
mod <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env ModuleName
pi_mod_name ModLocation
location
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
makeNewModSummary HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
{ nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
, nms_src_timestamp :: UTCTime
nms_src_timestamp = UTCTime
src_timestamp
, nms_is_boot :: IsBootInterface
nms_is_boot = IsBootInterface
NotBoot
, nms_hsc_src :: HscSource
nms_hsc_src =
if FilePath -> Bool
isHaskellSigFilename FilePath
src_fn
then HscSource
HsigFile
else HscSource
HsSrcFile
, nms_location :: ModLocation
nms_location = ModLocation
location
, nms_mod :: Module
nms_mod = Module
mod
, nms_obj_allowed :: Bool
nms_obj_allowed = Bool
obj_allowed
, nms_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
}
findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary
findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary
findSummaryBySourceFile [ExtendedModSummary]
summaries FilePath
file = case
[ ExtendedModSummary
ms
| ExtendedModSummary
ms <- [ExtendedModSummary]
summaries
, HscSource
HsSrcFile <- [ModSummary -> HscSource
ms_hsc_src forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ms]
, let derived_file :: Maybe FilePath
derived_file = ModLocation -> Maybe FilePath
ml_hs_file forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ms
, forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"findSummaryBySourceFile" Maybe FilePath
derived_file forall a. Eq a => a -> a -> Bool
== FilePath
file
]
of
[] -> forall a. Maybe a
Nothing
(ExtendedModSummary
x:[ExtendedModSummary]
_) -> forall a. a -> Maybe a
Just ExtendedModSummary
x
checkSummaryTimestamp
:: HscEnv -> DynFlags -> Bool -> IsBootInterface
-> (UTCTime -> IO (Either e ExtendedModSummary))
-> ExtendedModSummary -> ModLocation -> UTCTime
-> IO (Either e ExtendedModSummary)
checkSummaryTimestamp :: forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBootInterface
-> (UTCTime -> IO (Either e ExtendedModSummary))
-> ExtendedModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ExtendedModSummary)
checkSummaryTimestamp
HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBootInterface
is_boot UTCTime -> IO (Either e ExtendedModSummary)
new_summary
(ExtendedModSummary { emsModSummary :: ExtendedModSummary -> ModSummary
emsModSummary = ModSummary
old_summary, emsInstantiatedUnits :: ExtendedModSummary -> [InstantiatedUnit]
emsInstantiatedUnits = [InstantiatedUnit]
bkp_deps})
ModLocation
location UTCTime
src_timestamp
| ModSummary -> UTCTime
ms_hs_date ModSummary
old_summary forall a. Eq a => a -> a -> Bool
== UTCTime
src_timestamp Bool -> Bool -> Bool
&&
Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) = do
Maybe UTCTime
obj_timestamp <-
if Backend -> Bool
backendProducesObject (DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
Bool -> Bool -> Bool
|| Bool
obj_allowed
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
location IsBootInterface
is_boot
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Module
_ <- HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env
(forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
old_summary)) ModLocation
location
Maybe UTCTime
hi_timestamp <- DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate DynFlags
dflags ModLocation
location
Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
location)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
( ExtendedModSummary { emsModSummary :: ModSummary
emsModSummary = ModSummary
old_summary
{ ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
, ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
, ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
}
, emsInstantiatedUnits :: [InstantiatedUnit]
emsInstantiatedUnits = [InstantiatedUnit]
bkp_deps
}
)
| Bool
otherwise =
UTCTime -> IO (Either e ExtendedModSummary)
new_summary UTCTime
src_timestamp
summariseModule
:: HscEnv
-> ModNodeMap ExtendedModSummary
-> IsBootInterface
-> Located ModuleName
-> Bool
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
summariseModule :: HscEnv
-> ModNodeMap ExtendedModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
summariseModule HscEnv
hsc_env ModNodeMap ExtendedModSummary
old_summary_map IsBootInterface
is_boot (L SrcSpan
loc ModuleName
wanted_mod)
Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
| ModuleName
wanted_mod forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
excl_mods
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Just ExtendedModSummary
old_summary <- forall a. ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup
(GWIB { gwib_mod :: ModuleName
gwib_mod = ModuleName
wanted_mod, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
is_boot })
ModNodeMap ExtendedModSummary
old_summary_map
= do
let location :: ModLocation
location = ModSummary -> ModLocation
ms_location forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
old_summary
src_fn :: FilePath
src_fn = forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"summariseModule" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location)
case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
Just (InputFileBuffer
_,UTCTime
t) ->
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtendedModSummary
-> ModLocation
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
check_timestamp ExtendedModSummary
old_summary ModLocation
location FilePath
src_fn UTCTime
t
Maybe (InputFileBuffer, UTCTime)
Nothing -> do
Either IOException UTCTime
m <- forall a. IO a -> IO (Either IOException a)
tryIO (FilePath -> IO UTCTime
getModificationUTCTime FilePath
src_fn)
case Either IOException UTCTime
m of
Right UTCTime
t ->
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtendedModSummary
-> ModLocation
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
check_timestamp ExtendedModSummary
old_summary ModLocation
location FilePath
src_fn UTCTime
t
Left IOException
e | IOException -> Bool
isDoesNotExistError IOException
e -> IO (Maybe (Either ErrorMessages ExtendedModSummary))
find_it
| Bool
otherwise -> forall a. IOException -> IO a
ioError IOException
e
| Bool
otherwise = IO (Maybe (Either ErrorMessages ExtendedModSummary))
find_it
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
check_timestamp :: ExtendedModSummary
-> ModLocation
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
check_timestamp ExtendedModSummary
old_summary ModLocation
location FilePath
src_fn =
forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBootInterface
-> (UTCTime -> IO (Either e ExtendedModSummary))
-> ExtendedModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ExtendedModSummary)
checkSummaryTimestamp
HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBootInterface
is_boot
(ModLocation
-> Module
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
new_summary ModLocation
location (ModSummary -> Module
ms_mod forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
old_summary) FilePath
src_fn)
ExtendedModSummary
old_summary ModLocation
location
find_it :: IO (Maybe (Either ErrorMessages ExtendedModSummary))
find_it = do
FindResult
found <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
wanted_mod forall a. Maybe a
Nothing
case FindResult
found of
Found ModLocation
location Module
mod
| forall a. Maybe a -> Bool
isJust (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location) ->
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModLocation
-> Module -> IO (Either ErrorMessages ExtendedModSummary)
just_found ModLocation
location Module
mod
FindResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
just_found :: ModLocation
-> Module -> IO (Either ErrorMessages ExtendedModSummary)
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 = forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"summarise2" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location')
Maybe UTCTime
maybe_t <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists FilePath
src_fn
case Maybe UTCTime
maybe_t of
Maybe UTCTime
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SrcSpan -> FilePath -> ErrorMessages
noHsFileErr SrcSpan
loc FilePath
src_fn
Just UTCTime
t -> ModLocation
-> Module
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
new_summary ModLocation
location' Module
mod FilePath
src_fn UTCTime
t
new_summary :: ModLocation
-> Module
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
new_summary ModLocation
location Module
mod FilePath
src_fn UTCTime
src_timestamp
= forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
preimps :: PreprocessedImports
preimps@PreprocessedImports {FilePath
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
ModuleName
DynFlags
InputFileBuffer
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_theimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..}
<- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn forall a. Maybe a
Nothing Maybe (InputFileBuffer, UTCTime)
maybe_buf
let hsc_src :: HscSource
hsc_src
| IsBootInterface
is_boot forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot = HscSource
HsBootFile
| FilePath -> Bool
isHaskellSigFilename FilePath
src_fn = HscSource
HsigFile
| Bool
otherwise = HscSource
HsSrcFile
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
pi_mod_name forall a. Eq a => a -> a -> Bool
/= ModuleName
wanted_mod) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
pi_mod_name_loc forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
text FilePath
"File name does not match module name:"
SDoc -> SDoc -> SDoc
$$ FilePath -> SDoc
text FilePath
"Saw:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name)
SDoc -> SDoc -> SDoc
$$ FilePath -> SDoc
text FilePath
"Expected:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
wanted_mod)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HscSource
hsc_src forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
pi_mod_name (forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit))) forall a b. (a -> b) -> a -> b
$
let suggested_instantiated_with :: SDoc
suggested_instantiated_with =
[SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma forall a b. (a -> b) -> a -> b
$
[ forall a. Outputable a => a -> SDoc
ppr ModuleName
k SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Module
v
| (ModuleName
k,Module
v) <- ((ModuleName
pi_mod_name, forall u. ModuleName -> GenModule (GenUnit u)
mkHoleModule ModuleName
pi_mod_name)
forall a. a -> [a] -> [a]
: forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit)
])
in forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
pi_mod_name_loc forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
text FilePath
"Unexpected signature:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name)
SDoc -> SDoc -> SDoc
$$ if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildingCabalPackage DynFlags
dflags
then SDoc -> SDoc
parens (FilePath -> SDoc
text FilePath
"Try adding" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name)
SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"to the"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FilePath -> SDoc
text FilePath
"signatures")
SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"field in your Cabal file.")
else SDoc -> SDoc
parens (FilePath -> SDoc
text FilePath
"Try passing -instantiated-with=\"" SDoc -> SDoc -> SDoc
<>
SDoc
suggested_instantiated_with SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"\"" SDoc -> SDoc -> SDoc
$$
FilePath -> SDoc
text FilePath
"replacing <" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"> as necessary.")
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
makeNewModSummary HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
{ nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
, nms_src_timestamp :: UTCTime
nms_src_timestamp = UTCTime
src_timestamp
, nms_is_boot :: IsBootInterface
nms_is_boot = IsBootInterface
is_boot
, nms_hsc_src :: HscSource
nms_hsc_src = HscSource
hsc_src
, nms_location :: ModLocation
nms_location = ModLocation
location
, nms_mod :: Module
nms_mod = Module
mod
, nms_obj_allowed :: Bool
nms_obj_allowed = Bool
obj_allowed
, nms_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
}
data MakeNewModSummary
= MakeNewModSummary
{ MakeNewModSummary -> FilePath
nms_src_fn :: FilePath
, MakeNewModSummary -> UTCTime
nms_src_timestamp :: UTCTime
, MakeNewModSummary -> IsBootInterface
nms_is_boot :: IsBootInterface
, MakeNewModSummary -> HscSource
nms_hsc_src :: HscSource
, MakeNewModSummary -> ModLocation
nms_location :: ModLocation
, MakeNewModSummary -> Module
nms_mod :: Module
, MakeNewModSummary -> Bool
nms_obj_allowed :: Bool
, MakeNewModSummary -> PreprocessedImports
nms_preimps :: PreprocessedImports
}
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
makeNewModSummary HscEnv
hsc_env MakeNewModSummary{Bool
FilePath
UTCTime
Module
IsBootInterface
ModLocation
HscSource
PreprocessedImports
nms_preimps :: PreprocessedImports
nms_obj_allowed :: Bool
nms_mod :: Module
nms_location :: ModLocation
nms_hsc_src :: HscSource
nms_is_boot :: IsBootInterface
nms_src_timestamp :: UTCTime
nms_src_fn :: FilePath
nms_preimps :: MakeNewModSummary -> PreprocessedImports
nms_obj_allowed :: MakeNewModSummary -> Bool
nms_mod :: MakeNewModSummary -> Module
nms_location :: MakeNewModSummary -> ModLocation
nms_hsc_src :: MakeNewModSummary -> HscSource
nms_is_boot :: MakeNewModSummary -> IsBootInterface
nms_src_timestamp :: MakeNewModSummary -> UTCTime
nms_src_fn :: MakeNewModSummary -> FilePath
..} = do
let PreprocessedImports{FilePath
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
ModuleName
DynFlags
InputFileBuffer
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_theimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..} = PreprocessedImports
nms_preimps
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
Maybe UTCTime
obj_timestamp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
if Backend -> Bool
backendProducesObject (DynFlags -> Backend
backend DynFlags
dflags)
Bool -> Bool -> Bool
|| Bool
nms_obj_allowed
then ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
nms_location IsBootInterface
nms_is_boot
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Maybe UTCTime
hi_timestamp <- DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate DynFlags
dflags ModLocation
nms_location
Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
nms_location)
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
extra_sig_imports <- HscEnv
-> HscSource
-> ModuleName
-> IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
findExtraSigImports HscEnv
hsc_env HscSource
nms_hsc_src ModuleName
pi_mod_name
([ModuleName]
implicit_sigs, [InstantiatedUnit]
inst_deps) <- HscEnv
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow HscEnv
hsc_env [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_theimps
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExtendedModSummary
{ emsModSummary :: ModSummary
emsModSummary =
ModSummary
{ ms_mod :: Module
ms_mod = Module
nms_mod
, ms_hsc_src :: HscSource
ms_hsc_src = HscSource
nms_hsc_src
, ms_location :: ModLocation
ms_location = ModLocation
nms_location
, ms_hspp_file :: FilePath
ms_hspp_file = FilePath
pi_hspp_fn
, ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
pi_local_dflags
, ms_hspp_buf :: Maybe InputFileBuffer
ms_hspp_buf = forall a. a -> Maybe a
Just InputFileBuffer
pi_hspp_buf
, ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = forall a. Maybe a
Nothing
, ms_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_srcimps = [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps
, ms_textual_imps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_textual_imps =
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_theimps forall a. [a] -> [a] -> [a]
++
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
extra_sig_imports forall a. [a] -> [a] -> [a]
++
((,) forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Located e
noLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
implicit_sigs)
, ms_hs_date :: UTCTime
ms_hs_date = UTCTime
nms_src_timestamp
, ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
, ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
, ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
}
, emsInstantiatedUnits :: [InstantiatedUnit]
emsInstantiatedUnits = [InstantiatedUnit]
inst_deps
}
getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
location IsBootInterface
is_boot
= case IsBootInterface
is_boot of
IsBootInterface
IsBoot -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
IsBootInterface
NotBoot -> FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_obj_file ModLocation
location)
data PreprocessedImports
= PreprocessedImports
{ PreprocessedImports -> DynFlags
pi_local_dflags :: DynFlags
, PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, Located ModuleName)]
, PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(Maybe FastString, Located ModuleName)]
, PreprocessedImports -> FilePath
pi_hspp_fn :: FilePath
, PreprocessedImports -> InputFileBuffer
pi_hspp_buf :: StringBuffer
, PreprocessedImports -> SrcSpan
pi_mod_name_loc :: SrcSpan
, PreprocessedImports -> ModuleName
pi_mod_name :: ModuleName
}
getPreprocessedImports
:: HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports :: HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf = do
(DynFlags
pi_local_dflags, FilePath
pi_hspp_fn)
<- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, FilePath))
preprocess HscEnv
hsc_env FilePath
src_fn (forall a b. (a, b) -> a
fst 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO InputFileBuffer
hGetStringBuffer FilePath
pi_hspp_fn
([(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps, [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_theimps, L SrcSpan
pi_mod_name_loc ModuleName
pi_mod_name)
<- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
let imp_prelude :: Bool
imp_prelude = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitPrelude DynFlags
pi_local_dflags
popts :: ParserOpts
popts = DynFlags -> ParserOpts
initParserOpts DynFlags
pi_local_dflags
Either
(Bag PsError)
([(Maybe FastString, GenLocated SrcSpan ModuleName)],
[(Maybe FastString, GenLocated SrcSpan ModuleName)],
GenLocated SrcSpan ModuleName)
mimps <- ParserOpts
-> Bool
-> InputFileBuffer
-> FilePath
-> FilePath
-> IO
(Either
(Bag PsError)
([(Maybe FastString, GenLocated SrcSpan ModuleName)],
[(Maybe FastString, GenLocated SrcSpan ModuleName)],
GenLocated SrcSpan ModuleName))
getImports ParserOpts
popts Bool
imp_prelude InputFileBuffer
pi_hspp_buf FilePath
pi_hspp_fn FilePath
src_fn
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError) Either
(Bag PsError)
([(Maybe FastString, GenLocated SrcSpan ModuleName)],
[(Maybe FastString, GenLocated SrcSpan ModuleName)],
GenLocated SrcSpan ModuleName)
mimps)
forall (m :: * -> *) a. Monad m => a -> m a
return PreprocessedImports {FilePath
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
ModuleName
DynFlags
InputFileBuffer
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_local_dflags :: DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
..}
withDeferredDiagnostics :: GhcMonad m => m a -> m a
withDeferredDiagnostics :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics m a
f = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if Bool -> Bool
not 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
IORef [IO ()]
errors <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
IORef [IO ()]
fatals <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
let deferDiagnostics :: LogAction
deferDiagnostics DynFlags
_dflags !WarnReason
reason !Severity
severity !SrcSpan
srcSpan !SDoc
msg = do
let action :: IO ()
action = Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
reason Severity
severity SrcSpan
srcSpan SDoc
msg
case Severity
severity of
Severity
SevWarning -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
warnings forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
Severity
SevError -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
errors forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
Severity
SevFatal -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
fatals forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
Severity
_ -> IO ()
action
printDeferredDiagnostics :: m ()
printDeferredDiagnostics = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
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] forall a b. (a -> b) -> a -> b
$ \IORef [IO ()]
ref -> do
[IO ()]
actions <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
ref forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> ([], [IO ()]
i)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [IO ()]
actions
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket
(forall (m :: * -> *).
GhcMonad m =>
(LogAction -> LogAction) -> m ()
pushLogHookM (forall a b. a -> b -> a
const LogAction
deferDiagnostics))
(\()
_ -> forall (m :: * -> *). GhcMonad m => m ()
popLogHookM forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
printDeferredDiagnostics)
(\()
_ -> m a
f)
noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc
noModError :: HscEnv
-> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc
noModError HscEnv
hsc_env SrcSpan
loc ModuleName
wanted_mod FindResult
err
= SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
hsc_env ModuleName
wanted_mod FindResult
err
noHsFileErr :: SrcSpan -> String -> ErrorMessages
noHsFileErr :: SrcSpan -> FilePath -> ErrorMessages
noHsFileErr SrcSpan
loc FilePath
path
= forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text FilePath
"Can't find" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
path
moduleNotFoundErr :: ModuleName -> ErrorMessages
moduleNotFoundErr :: ModuleName -> ErrorMessages
moduleNotFoundErr ModuleName
mod
= forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
mod) SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"cannot be found locally"
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = forall a. FilePath -> a
panic FilePath
"multiRootsErr"
multiRootsErr summs :: [ModSummary]
summs@(ModSummary
summ1:[ModSummary]
_)
= forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope DecoratedSDoc -> io a
throwOneError forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Module
mod) SDoc -> SDoc -> SDoc
<+>
FilePath -> SDoc
text FilePath
"is defined in multiple files:" SDoc -> SDoc -> SDoc
<+>
[SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map FilePath -> SDoc
text [FilePath]
files)
where
mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
summ1
files :: [FilePath]
files = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"checkDup" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModLocation -> Maybe FilePath
ml_hs_file forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
ms_location) [ModSummary]
summs
keepGoingPruneErr :: [NodeKey] -> SDoc
keepGoingPruneErr :: [NodeKey] -> SDoc
keepGoingPruneErr [NodeKey]
ms
= [SDoc] -> SDoc
vcat (( FilePath -> SDoc
text FilePath
"-fkeep-going in use, removing the following" SDoc -> SDoc -> SDoc
<+>
FilePath -> SDoc
text FilePath
"dependencies and continuing:")forall a. a -> [a] -> [a]
:
forall a b. (a -> b) -> [a] -> [b]
map (Int -> SDoc -> SDoc
nest Int
6 forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> SDoc
pprNodeKey) [NodeKey]
ms )
cyclicModuleErr :: [ModuleGraphNode] -> SDoc
cyclicModuleErr :: [ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
mss
= ASSERT( not (null mss) )
case forall payload key.
Ord key =>
[Node key payload] -> Maybe [payload]
findCycle [Node NodeKey ModuleGraphNode]
graph of
Maybe [ModuleGraphNode]
Nothing -> FilePath -> SDoc
text FilePath
"Unexpected non-cycle" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [ModuleGraphNode]
mss
Just [ModuleGraphNode]
path0 -> [SDoc] -> SDoc
vcat
[ case [ModuleGraphNode] -> ([InstantiatedUnit], [ExtendedModSummary])
partitionNodes [ModuleGraphNode]
path0 of
([],[ExtendedModSummary]
_) -> FilePath -> SDoc
text FilePath
"Module imports form a cycle:"
([InstantiatedUnit]
_,[]) -> FilePath -> SDoc
text FilePath
"Module instantiations form a cycle:"
([InstantiatedUnit], [ExtendedModSummary])
_ -> FilePath -> SDoc
text FilePath
"Module imports and instantiations form a cycle:"
, Int -> SDoc -> SDoc
nest Int
2 ([ModuleGraphNode] -> SDoc
show_path [ModuleGraphNode]
path0)]
where
graph :: [Node NodeKey ModuleGraphNode]
graph :: [Node NodeKey ModuleGraphNode]
graph =
[ DigraphNode
{ node_payload :: ModuleGraphNode
node_payload = ModuleGraphNode
ms
, node_key :: NodeKey
node_key = ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
ms
, node_dependencies :: [NodeKey]
node_dependencies = ModuleGraphNode -> [NodeKey]
get_deps ModuleGraphNode
ms
}
| ModuleGraphNode
ms <- [ModuleGraphNode]
mss
]
get_deps :: ModuleGraphNode -> [NodeKey]
get_deps :: ModuleGraphNode -> [NodeKey]
get_deps = \case
InstantiationNode InstantiatedUnit
iuid ->
[ ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ GWIB { gwib_mod :: ModuleName
gwib_mod = ModuleName
hole, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
| ModuleName
hole <- forall a. UniqDSet a -> [a]
uniqDSetToList forall a b. (a -> b) -> a -> b
$ forall unit. GenInstantiatedUnit unit -> UniqDSet ModuleName
instUnitHoles InstantiatedUnit
iuid
]
ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bds) ->
[ ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ GWIB { gwib_mod :: ModuleName
gwib_mod = forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
IsBoot }
| GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
ms ] forall a. [a] -> [a] -> [a]
++
[ ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ GWIB { gwib_mod :: ModuleName
gwib_mod = forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
| GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
ms ] forall a. [a] -> [a] -> [a]
++
[ InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
inst_unit
| InstantiatedUnit
inst_unit <- [InstantiatedUnit]
bds
]
show_path :: [ModuleGraphNode] -> SDoc
show_path :: [ModuleGraphNode] -> SDoc
show_path [] = forall a. FilePath -> a
panic FilePath
"show_path"
show_path [ModuleGraphNode
m] = ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"imports itself"
show_path (ModuleGraphNode
m1:ModuleGraphNode
m2:[ModuleGraphNode]
ms) = [SDoc] -> SDoc
vcat ( Int -> SDoc -> SDoc
nest Int
6 (ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m1)
forall a. a -> [a] -> [a]
: Int -> SDoc -> SDoc
nest Int
6 (FilePath -> SDoc
text FilePath
"imports" SDoc -> SDoc -> SDoc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m2)
forall a. a -> [a] -> [a]
: [ModuleGraphNode] -> [SDoc]
go [ModuleGraphNode]
ms )
where
go :: [ModuleGraphNode] -> [SDoc]
go [] = [FilePath -> SDoc
text FilePath
"which imports" SDoc -> SDoc -> SDoc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m1]
go (ModuleGraphNode
m:[ModuleGraphNode]
ms) = (FilePath -> SDoc
text FilePath
"which imports" SDoc -> SDoc -> SDoc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m) forall a. a -> [a] -> [a]
: [ModuleGraphNode] -> [SDoc]
go [ModuleGraphNode]
ms
ppr_node :: ModuleGraphNode -> SDoc
ppr_node :: ModuleGraphNode -> SDoc
ppr_node (ModuleNode ExtendedModSummary
m) = FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> ModSummary -> SDoc
ppr_ms (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
m)
ppr_node (InstantiationNode InstantiatedUnit
u) = FilePath -> SDoc
text FilePath
"instantiated unit" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
u
ppr_ms :: ModSummary -> SDoc
ppr_ms :: ModSummary -> SDoc
ppr_ms ModSummary
ms = SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
ms))) SDoc -> SDoc -> SDoc
<+>
(SDoc -> SDoc
parens (FilePath -> SDoc
text (ModSummary -> FilePath
msHsFilePath ModSummary
ms)))