{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Driver.Backpack (doBackpack) where
import GHC.Prelude
import GHC.Driver.Backend
import GHC.Driver.Backpack.Syntax
import GHC.Driver.Config.Finder (initFinderOpts)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Monad
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Main
import GHC.Driver.Make
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Parser
import GHC.Parser.Header
import GHC.Parser.Lexer
import GHC.Parser.Annotation
import GHC.Rename.Names
import GHC hiding (Failed, Succeeded)
import GHC.Tc.Utils.Monad
import GHC.Iface.Recomp
import GHC.Builtin.Names
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.SourceFile
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Types.Unique.DSet
import GHC.Utils.Outputable
import GHC.Utils.Fingerprint
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Finder
import GHC.Unit.Module.Graph
import GHC.Unit.Module.ModSummary
import GHC.Unit.Home.ModInfo
import GHC.Linker.Types
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Maybe
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.Data.EnumSet as EnumSet
import qualified GHC.Data.ShortText as ST
import Data.List ( partition )
import System.Exit
import Control.Monad
import System.FilePath
import Data.Version
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
doBackpack :: [FilePath] -> Ghc ()
doBackpack :: [FilePath] -> Ghc ()
doBackpack [FilePath
src_filename] = do
DynFlags
dflags0 <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let dflags1 :: DynFlags
dflags1 = DynFlags
dflags0
let parser_opts1 :: ParserOpts
parser_opts1 = DynFlags -> ParserOpts
initParserOpts DynFlags
dflags1
(Messages PsMessage
p_warns, [Located FilePath]
src_opts) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ParserOpts
-> FilePath -> IO (Messages PsMessage, [Located FilePath])
getOptionsFromFile ParserOpts
parser_opts1 FilePath
src_filename
(DynFlags
dflags, [Located FilePath]
unhandled_flags, [Warn]
warns) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFilePragma DynFlags
dflags1 [Located FilePath]
src_opts
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags)
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
$ forall (m :: * -> *). MonadIO m => [Located FilePath] -> m ()
checkProcessArgsResult [Located FilePath]
unhandled_flags
let print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger DiagnosticOpts GhcMessage
print_config (DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags) (PsMessage -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsMessage
p_warns)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> GhcMessageOpts -> DiagOpts -> [Warn] -> IO ()
handleFlagWarnings Logger
logger DiagnosticOpts GhcMessage
print_config (DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags) [Warn]
warns
StringBuffer
buf <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO StringBuffer
hGetStringBuffer FilePath
src_filename
let loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
src_filename) Int
1 Int
1
case forall a. P a -> PState -> ParseResult a
unP P [LHsUnit PackageName]
parseBackpack (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) StringBuffer
buf RealSrcLoc
loc) of
PFailed PState
pst -> forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsMessage -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PState -> Messages PsMessage
getPsErrorMessages PState
pst)
POk PState
_ [LHsUnit PackageName]
pkgname_bkp -> do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let bkp :: [LHsUnit HsComponentId]
bkp = UnitState
-> PackageNameMap HsComponentId
-> [LHsUnit PackageName]
-> [LHsUnit HsComponentId]
renameHsUnits (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env) ([LHsUnit PackageName] -> PackageNameMap HsComponentId
bkpPackageNameMap [LHsUnit PackageName]
pkgname_bkp) [LHsUnit PackageName]
pkgname_bkp
forall a. FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
initBkpM FilePath
src_filename [LHsUnit HsComponentId]
bkp forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [LHsUnit HsComponentId]
bkp) forall a b. (a -> b) -> a -> b
$ \(Int
i, LHsUnit HsComponentId
lunit) -> do
let comp_name :: HsComponentId
comp_name = forall l e. GenLocated l e -> e
unLoc (forall n. HsUnit n -> Located n
hsunitName (forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
lunit))
(Int, Int) -> HsComponentId -> IOEnv BkpEnv ()
msgTopPackage (Int
i,forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsUnit HsComponentId]
bkp) HsComponentId
comp_name
forall a. BkpM a -> BkpM a
innerBkpM forall a b. (a -> b) -> a -> b
$ do
let (UnitId
cid, [(ModuleName, Module)]
insts) = LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)])
computeUnitId LHsUnit HsComponentId
lunit
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, Module)]
insts
then if UnitId
cid forall a. Eq a => a -> a -> Bool
== FastString -> UnitId
UnitId (FilePath -> FastString
fsLit FilePath
"main")
then LHsUnit HsComponentId -> IOEnv BkpEnv ()
compileExe LHsUnit HsComponentId
lunit
else UnitId -> [(ModuleName, Module)] -> IOEnv BkpEnv ()
compileUnit UnitId
cid []
else UnitId -> [(ModuleName, Module)] -> IOEnv BkpEnv ()
typecheckUnit UnitId
cid [(ModuleName, Module)]
insts
doBackpack [FilePath]
_ =
forall a. GhcException -> a
throwGhcException (FilePath -> GhcException
CmdLineError FilePath
"--backpack can only process a single file")
computeUnitId :: LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)])
computeUnitId :: LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)])
computeUnitId (L SrcSpan
_ HsUnit HsComponentId
unit) = (UnitId
cid, [ (ModuleName
r, forall u. ModuleName -> GenModule (GenUnit u)
mkHoleModule ModuleName
r) | ModuleName
r <- [ModuleName]
reqs ])
where
cid :: UnitId
cid = HsComponentId -> UnitId
hsComponentId (forall l e. GenLocated l e -> e
unLoc (forall n. HsUnit n -> Located n
hsunitName HsUnit HsComponentId
unit))
reqs :: [ModuleName]
reqs = forall a. UniqDSet a -> [a]
uniqDSetToList (forall a. [UniqDSet a] -> UniqDSet a
unionManyUniqDSets (forall a b. (a -> b) -> [a] -> [b]
map (HsUnitDecl HsComponentId -> UniqDSet ModuleName
get_reqs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) (forall n. HsUnit n -> [LHsUnitDecl n]
hsunitBody HsUnit HsComponentId
unit)))
get_reqs :: HsUnitDecl HsComponentId -> UniqDSet ModuleName
get_reqs (DeclD HscSource
HsigFile (L SrcSpan
_ ModuleName
modname) Located (HsModule GhcPs)
_) = forall a. Uniquable a => a -> UniqDSet a
unitUniqDSet ModuleName
modname
get_reqs (DeclD HscSource
HsSrcFile GenLocated SrcSpan ModuleName
_ Located (HsModule GhcPs)
_) = forall a. UniqDSet a
emptyUniqDSet
get_reqs (DeclD HscSource
HsBootFile GenLocated SrcSpan ModuleName
_ Located (HsModule GhcPs)
_) = forall a. UniqDSet a
emptyUniqDSet
get_reqs (IncludeD (IncludeDecl (L SrcSpan
_ HsUnitId HsComponentId
hsuid) Maybe [LRenaming]
_ Bool
_)) =
forall u. GenUnit u -> UniqDSet ModuleName
unitFreeModuleHoles (HsUnitId HsComponentId -> Unit
convertHsComponentId HsUnitId HsComponentId
hsuid)
data SessionType
= ExeSession
| TcSession
| CompSession
deriving (SessionType -> SessionType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SessionType -> SessionType -> Bool
$c/= :: SessionType -> SessionType -> Bool
== :: SessionType -> SessionType -> Bool
$c== :: SessionType -> SessionType -> Bool
Eq)
withBkpSession :: UnitId
-> [(ModuleName, Module)]
-> [(Unit, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
withBkpSession :: forall a.
UnitId
-> [(ModuleName, Module)]
-> [(Unit, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
withBkpSession UnitId
cid [(ModuleName, Module)]
insts [(Unit, ModRenaming)]
deps SessionType
session_type BkpM a
do_this = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let cid_fs :: FastString
cid_fs = forall u. IsUnitId u => u -> FastString
unitFS UnitId
cid
is_primary :: Bool
is_primary = Bool
False
uid_str :: FilePath
uid_str = FastString -> FilePath
unpackFS (forall u.
IsUnitId u =>
u -> [(ModuleName, GenModule (GenUnit u))] -> FastString
mkInstantiatedUnitHash UnitId
cid [(ModuleName, Module)]
insts)
cid_str :: FilePath
cid_str = FastString -> FilePath
unpackFS FastString
cid_fs
key_base :: (DynFlags -> Maybe FilePath) -> FilePath
key_base DynFlags -> Maybe FilePath
p | Just FilePath
f <- DynFlags -> Maybe FilePath
p DynFlags
dflags = FilePath
f
| Bool
otherwise = FilePath
"."
sub_comp :: FilePath -> FilePath
sub_comp FilePath
p | Bool
is_primary = FilePath
p
| Bool
otherwise = FilePath
p FilePath -> FilePath -> FilePath
</> FilePath
cid_str
outdir :: (DynFlags -> Maybe FilePath) -> FilePath
outdir DynFlags -> Maybe FilePath
p | SessionType
CompSession <- SessionType
session_type
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, Module)]
insts) = FilePath -> FilePath
sub_comp ((DynFlags -> Maybe FilePath) -> FilePath
key_base DynFlags -> Maybe FilePath
p) FilePath -> FilePath -> FilePath
</> FilePath
uid_str
| Bool
otherwise = FilePath -> FilePath
sub_comp ((DynFlags -> Maybe FilePath) -> FilePath
key_base DynFlags -> Maybe FilePath
p)
mk_temp_env :: HscEnv -> HscEnv
mk_temp_env HscEnv
hsc_env =
(DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags (\DynFlags
dflags -> UnitState -> DynFlags -> DynFlags
mk_temp_dflags (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env) DynFlags
dflags) HscEnv
hsc_env
mk_temp_dflags :: UnitState -> DynFlags -> DynFlags
mk_temp_dflags UnitState
unit_state DynFlags
dflags = DynFlags
dflags
{ backend :: Backend
backend = case SessionType
session_type of
SessionType
TcSession -> Backend
noBackend
SessionType
_ -> DynFlags -> Backend
backend DynFlags
dflags
, ghcLink :: GhcLink
ghcLink = case SessionType
session_type of
SessionType
TcSession -> GhcLink
NoLink
SessionType
_ -> DynFlags -> GhcLink
ghcLink DynFlags
dflags
, homeUnitInstantiations_ :: [(ModuleName, Module)]
homeUnitInstantiations_ = [(ModuleName, Module)]
insts
, homeUnitInstanceOf_ :: Maybe UnitId
homeUnitInstanceOf_ = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, Module)]
insts then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just UnitId
cid
, homeUnitId_ :: UnitId
homeUnitId_ = case SessionType
session_type of
SessionType
TcSession -> UnitId -> Maybe FastString -> UnitId
newUnitId UnitId
cid forall a. Maybe a
Nothing
SessionType
_ | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, Module)]
insts -> UnitId -> Maybe FastString -> UnitId
newUnitId UnitId
cid forall a. Maybe a
Nothing
| Bool
otherwise -> UnitId -> Maybe FastString -> UnitId
newUnitId UnitId
cid (forall a. a -> Maybe a
Just (forall u.
IsUnitId u =>
u -> [(ModuleName, GenModule (GenUnit u))] -> FastString
mkInstantiatedUnitHash UnitId
cid [(ModuleName, Module)]
insts))
, generalFlags :: EnumSet GeneralFlag
generalFlags = case SessionType
session_type of
SessionType
TcSession
| Backend -> Bool
backendSupportsInterfaceWriting forall a b. (a -> b) -> a -> b
$ DynFlags -> Backend
backend DynFlags
dflags
-> forall a. Enum a => a -> EnumSet a -> EnumSet a
EnumSet.insert GeneralFlag
Opt_WriteInterface (DynFlags -> EnumSet GeneralFlag
generalFlags DynFlags
dflags)
SessionType
_ -> DynFlags -> EnumSet GeneralFlag
generalFlags DynFlags
dflags
, objectDir :: Maybe FilePath
objectDir = forall a. a -> Maybe a
Just ((DynFlags -> Maybe FilePath) -> FilePath
outdir DynFlags -> Maybe FilePath
objectDir)
, hiDir :: Maybe FilePath
hiDir = forall a. a -> Maybe a
Just ((DynFlags -> Maybe FilePath) -> FilePath
outdir DynFlags -> Maybe FilePath
hiDir)
, stubDir :: Maybe FilePath
stubDir = forall a. a -> Maybe a
Just ((DynFlags -> Maybe FilePath) -> FilePath
outdir DynFlags -> Maybe FilePath
stubDir)
, outputFile_ :: Maybe FilePath
outputFile_ = case SessionType
session_type of
SessionType
ExeSession -> DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags
SessionType
_ -> forall a. Maybe a
Nothing
, dynOutputFile_ :: Maybe FilePath
dynOutputFile_ = case SessionType
session_type of
SessionType
ExeSession -> DynFlags -> Maybe FilePath
dynOutputFile_ DynFlags
dflags
SessionType
_ -> forall a. Maybe a
Nothing
, importPaths :: [FilePath]
importPaths = []
, packageFlags :: [PackageFlag]
packageFlags = DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (\(Unit
uid0, ModRenaming
rn) ->
let uid :: Unit
uid = UnitState -> Unit -> Unit
unwireUnit UnitState
unit_state
forall a b. (a -> b) -> a -> b
$ UnitState -> Unit -> Unit
improveUnit UnitState
unit_state
forall a b. (a -> b) -> a -> b
$ UnitState -> ShHoleSubst -> Unit -> Unit
renameHoleUnit UnitState
unit_state (forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(ModuleName, Module)]
insts) Unit
uid0
in FilePath -> PackageArg -> ModRenaming -> PackageFlag
ExposePackage
(DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags
(forall doc. IsLine doc => FilePath -> doc
text FilePath
"-unit-id" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Unit
uid forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ModRenaming
rn))
(Unit -> PackageArg
UnitIdArg Unit
uid) ModRenaming
rn) [(Unit, ModRenaming)]
deps
}
forall (m :: * -> *) a.
GhcMonad m =>
(HscEnv -> HscEnv) -> m a -> m a
withTempSession HscEnv -> HscEnv
mk_temp_env forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags DynFlags
dflags
BkpM a
do_this
withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession :: forall a. [(Unit, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession [(Unit, ModRenaming)]
deps BkpM a
do_this =
forall a.
UnitId
-> [(ModuleName, Module)]
-> [(Unit, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
withBkpSession (FastString -> UnitId
UnitId (FilePath -> FastString
fsLit FilePath
"main")) [] [(Unit, ModRenaming)]
deps SessionType
ExeSession BkpM a
do_this
getSource :: UnitId -> BkpM (LHsUnit HsComponentId)
getSource :: UnitId -> BkpM (LHsUnit HsComponentId)
getSource UnitId
cid = do
BkpEnv
bkp_env <- BkpM BkpEnv
getBkpEnv
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
cid (BkpEnv -> Map UnitId (LHsUnit HsComponentId)
bkp_table BkpEnv
bkp_env) of
Maybe (LHsUnit HsComponentId)
Nothing -> forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"missing needed dependency" (forall a. Outputable a => a -> SDoc
ppr UnitId
cid)
Just LHsUnit HsComponentId
lunit -> forall (m :: * -> *) a. Monad m => a -> m a
return LHsUnit HsComponentId
lunit
typecheckUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
typecheckUnit :: UnitId -> [(ModuleName, Module)] -> IOEnv BkpEnv ()
typecheckUnit UnitId
cid [(ModuleName, Module)]
insts = do
LHsUnit HsComponentId
lunit <- UnitId -> BkpM (LHsUnit HsComponentId)
getSource UnitId
cid
SessionType
-> UnitId
-> [(ModuleName, Module)]
-> LHsUnit HsComponentId
-> IOEnv BkpEnv ()
buildUnit SessionType
TcSession UnitId
cid [(ModuleName, Module)]
insts LHsUnit HsComponentId
lunit
compileUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
compileUnit :: UnitId -> [(ModuleName, Module)] -> IOEnv BkpEnv ()
compileUnit UnitId
cid [(ModuleName, Module)]
insts = do
Unit -> IOEnv BkpEnv ()
msgUnitId (forall u.
IsUnitId u =>
u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u
mkVirtUnit UnitId
cid [(ModuleName, Module)]
insts)
LHsUnit HsComponentId
lunit <- UnitId -> BkpM (LHsUnit HsComponentId)
getSource UnitId
cid
SessionType
-> UnitId
-> [(ModuleName, Module)]
-> LHsUnit HsComponentId
-> IOEnv BkpEnv ()
buildUnit SessionType
CompSession UnitId
cid [(ModuleName, Module)]
insts LHsUnit HsComponentId
lunit
hsunitDeps :: Bool -> HsUnit HsComponentId -> [(Unit, ModRenaming)]
hsunitDeps :: Bool -> HsUnit HsComponentId -> [(Unit, ModRenaming)]
hsunitDeps Bool
include_sigs HsUnit HsComponentId
unit = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenLocated SrcSpan (HsUnitDecl HsComponentId)
-> [(Unit, ModRenaming)]
get_dep (forall n. HsUnit n -> [LHsUnitDecl n]
hsunitBody HsUnit HsComponentId
unit)
where
get_dep :: GenLocated SrcSpan (HsUnitDecl HsComponentId)
-> [(Unit, ModRenaming)]
get_dep (L SrcSpan
_ (IncludeD (IncludeDecl (L SrcSpan
_ HsUnitId HsComponentId
hsuid) Maybe [LRenaming]
mb_lrn Bool
is_sig)))
| Bool
include_sigs Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
is_sig = [(HsUnitId HsComponentId -> Unit
convertHsComponentId HsUnitId HsComponentId
hsuid, forall {l}. Maybe [GenLocated l Renaming] -> ModRenaming
go Maybe [LRenaming]
mb_lrn)]
| Bool
otherwise = []
where
go :: Maybe [GenLocated l Renaming] -> ModRenaming
go Maybe [GenLocated l Renaming]
Nothing = Bool -> [(ModuleName, ModuleName)] -> ModRenaming
ModRenaming Bool
True []
go (Just [GenLocated l Renaming]
lrns) = Bool -> [(ModuleName, ModuleName)] -> ModRenaming
ModRenaming Bool
False (forall a b. (a -> b) -> [a] -> [b]
map forall {l}. GenLocated l Renaming -> (ModuleName, ModuleName)
convRn [GenLocated l Renaming]
lrns)
where
convRn :: GenLocated l Renaming -> (ModuleName, ModuleName)
convRn (L l
_ (Renaming (L SrcSpan
_ ModuleName
from) Maybe (GenLocated SrcSpan ModuleName)
Nothing)) = (ModuleName
from, ModuleName
from)
convRn (L l
_ (Renaming (L SrcSpan
_ ModuleName
from) (Just (L SrcSpan
_ ModuleName
to)))) = (ModuleName
from, ModuleName
to)
get_dep GenLocated SrcSpan (HsUnitDecl HsComponentId)
_ = []
buildUnit :: SessionType -> UnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
buildUnit :: SessionType
-> UnitId
-> [(ModuleName, Module)]
-> LHsUnit HsComponentId
-> IOEnv BkpEnv ()
buildUnit SessionType
session UnitId
cid [(ModuleName, Module)]
insts LHsUnit HsComponentId
lunit = do
let deps_w_rns :: [(Unit, ModRenaming)]
deps_w_rns = Bool -> HsUnit HsComponentId -> [(Unit, ModRenaming)]
hsunitDeps (SessionType
session forall a. Eq a => a -> a -> Bool
== SessionType
TcSession) (forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
lunit)
raw_deps :: [Unit]
raw_deps = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Unit, ModRenaming)]
deps_w_rns
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let hsubst :: ShHoleSubst
hsubst = forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(ModuleName, Module)]
insts
deps0 :: [Unit]
deps0 = forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> ShHoleSubst -> Unit -> Unit
renameHoleUnit (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env) ShHoleSubst
hsubst) [Unit]
raw_deps
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Unit]
deps0) forall a b. (a -> b) -> a -> b
$ \(Int
i, Unit
dep) ->
case SessionType
session of
SessionType
TcSession -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
SessionType
_ -> Int -> (Int, Unit) -> IOEnv BkpEnv ()
compileInclude (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Unit]
deps0) (Int
i, Unit
dep)
let deps :: [Unit]
deps = forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> Unit -> Unit
improveUnit (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env)) [Unit]
deps0
Maybe ExternalPackageState
mb_old_eps <- case SessionType
session of
SessionType
TcSession -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall (m :: * -> *). GhcMonad m => m ExternalPackageState
getEpsGhc
SessionType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
GenericUnitInfo PackageId PackageName UnitId ModuleName Module
conf <- forall a.
UnitId
-> [(ModuleName, Module)]
-> [(Unit, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
withBkpSession UnitId
cid [(ModuleName, Module)]
insts [(Unit, ModRenaming)]
deps_w_rns SessionType
session forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
ModuleGraph
mod_graph <- Bool -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph Bool
False (forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
lunit)
Messager
msg <- BkpM Messager
mkBackpackMsg
SuccessFlag
ok <- forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' Maybe ModIfaceCache
noIfaceCache LoadHowMuch
LoadAllTargets (forall a. a -> Maybe a
Just Messager
msg) ModuleGraph
mod_graph
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SuccessFlag -> Bool
failed SuccessFlag
ok) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1))
let hi_dir :: FilePath
hi_dir = forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust (forall a. HasCallStack => FilePath -> a
panic FilePath
"hiDir Backpack") forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe FilePath
hiDir DynFlags
dflags
export_mod :: ModSummary -> (ModuleName, Module)
export_mod ModSummary
ms = (ModSummary -> ModuleName
ms_mod_name ModSummary
ms, ModSummary -> Module
ms_mod ModSummary
ms)
mods :: [(ModuleName, Module)]
mods = [ ModSummary -> (ModuleName, Module)
export_mod ModSummary
ms | ModSummary
ms <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph
, ModSummary -> HscSource
ms_hsc_src ModSummary
ms forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile ]
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let home_mod_infos :: [HomeModInfo]
home_mod_infos = forall key elt. UniqDFM key elt -> [elt]
eltsUDFM (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
linkables :: [Linkable]
linkables = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"bkp link" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> Maybe Linkable
homeModInfoObject)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((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_src forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface)
forall a b. (a -> b) -> a -> b
$ [HomeModInfo]
home_mod_infos
getOfiles :: Linkable -> [FilePath]
getOfiles LM{ linkableUnlinked :: Linkable -> [Unlinked]
linkableUnlinked = [Unlinked]
us } = forall a b. (a -> b) -> [a] -> [b]
map Unlinked -> FilePath
nameOfObject (forall a. (a -> Bool) -> [a] -> [a]
filter Unlinked -> Bool
isObject [Unlinked]
us)
obj_files :: [FilePath]
obj_files = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Linkable -> [FilePath]
getOfiles [Linkable]
linkables
state :: UnitState
state = HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env
let compat_fs :: FastString
compat_fs = UnitId -> FastString
unitIdFS UnitId
cid
compat_pn :: PackageName
compat_pn = FastString -> PackageName
PackageName FastString
compat_fs
unit_id :: UnitId
unit_id = forall u. GenHomeUnit u -> UnitId
homeUnitId (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env)
forall (m :: * -> *) a. Monad m => a -> m a
return GenericUnitInfo {
unitAbiHash :: ShortText
unitAbiHash = ShortText
"",
unitPackageId :: PackageId
unitPackageId = FastString -> PackageId
PackageId FastString
compat_fs,
unitPackageName :: PackageName
unitPackageName = PackageName
compat_pn,
unitPackageVersion :: Version
unitPackageVersion = [Int] -> Version
makeVersion [],
unitId :: UnitId
unitId = UnitId
unit_id,
unitComponentName :: Maybe PackageName
unitComponentName = forall a. Maybe a
Nothing,
unitInstanceOf :: UnitId
unitInstanceOf = UnitId
cid,
unitInstantiations :: [(ModuleName, Module)]
unitInstantiations = [(ModuleName, Module)]
insts,
unitExposedModules :: [(ModuleName, Maybe Module)]
unitExposedModules = forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
m,Module
n) -> (ModuleName
m,forall a. a -> Maybe a
Just Module
n)) [(ModuleName, Module)]
mods,
unitHiddenModules :: [ModuleName]
unitHiddenModules = [],
unitDepends :: [UnitId]
unitDepends = case SessionType
session of
SessionType
TcSession -> []
SessionType
_ -> forall a b. (a -> b) -> [a] -> [b]
map (Unit -> UnitId
toUnitId forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitState -> Unit -> Unit
unwireUnit UnitState
state)
forall a b. (a -> b) -> a -> b
$ [Unit]
deps forall a. [a] -> [a] -> [a]
++ [ forall unit. GenModule unit -> unit
moduleUnit Module
mod
| (ModuleName
_, Module
mod) <- [(ModuleName, Module)]
insts
, Bool -> Bool
not (forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
mod) ],
unitAbiDepends :: [(UnitId, ShortText)]
unitAbiDepends = [],
unitLinkerOptions :: [ShortText]
unitLinkerOptions = case SessionType
session of
SessionType
TcSession -> []
SessionType
_ -> forall a b. (a -> b) -> [a] -> [b]
map FilePath -> ShortText
ST.pack forall a b. (a -> b) -> a -> b
$ [FilePath]
obj_files,
unitImportDirs :: [ShortText]
unitImportDirs = [ FilePath -> ShortText
ST.pack forall a b. (a -> b) -> a -> b
$ FilePath
hi_dir ],
unitIsExposed :: Bool
unitIsExposed = Bool
False,
unitIsIndefinite :: Bool
unitIsIndefinite = case SessionType
session of
SessionType
TcSession -> Bool
True
SessionType
_ -> Bool
False,
unitLibraries :: [ShortText]
unitLibraries = [],
unitExtDepLibsSys :: [ShortText]
unitExtDepLibsSys = [],
unitExtDepLibsGhc :: [ShortText]
unitExtDepLibsGhc = [],
unitLibraryDynDirs :: [ShortText]
unitLibraryDynDirs = [],
unitLibraryDirs :: [ShortText]
unitLibraryDirs = [],
unitExtDepFrameworks :: [ShortText]
unitExtDepFrameworks = [],
unitExtDepFrameworkDirs :: [ShortText]
unitExtDepFrameworkDirs = [],
unitCcOptions :: [ShortText]
unitCcOptions = [],
unitIncludes :: [ShortText]
unitIncludes = [],
unitIncludeDirs :: [ShortText]
unitIncludeDirs = [],
unitHaddockInterfaces :: [ShortText]
unitHaddockInterfaces = [],
unitHaddockHTMLs :: [ShortText]
unitHaddockHTMLs = [],
unitIsTrusted :: Bool
unitIsTrusted = Bool
False
}
forall (m :: * -> *).
GhcMonad m =>
GenericUnitInfo PackageId PackageName UnitId ModuleName Module
-> m ()
addUnit GenericUnitInfo PackageId PackageName UnitId ModuleName Module
conf
case Maybe ExternalPackageState
mb_old_eps of
Just ExternalPackageState
old_eps -> forall (m :: * -> *).
GhcMonad m =>
(ExternalPackageState -> ExternalPackageState) -> m ()
updateEpsGhc_ (forall a b. a -> b -> a
const ExternalPackageState
old_eps)
Maybe ExternalPackageState
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
compileExe :: LHsUnit HsComponentId -> BkpM ()
compileExe :: LHsUnit HsComponentId -> IOEnv BkpEnv ()
compileExe LHsUnit HsComponentId
lunit = do
Unit -> IOEnv BkpEnv ()
msgUnitId Unit
mainUnit
let deps_w_rns :: [(Unit, ModRenaming)]
deps_w_rns = Bool -> HsUnit HsComponentId -> [(Unit, ModRenaming)]
hsunitDeps Bool
False (forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
lunit)
deps :: [Unit]
deps = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Unit, ModRenaming)]
deps_w_rns
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Unit]
deps) forall a b. (a -> b) -> a -> b
$ \(Int
i, Unit
dep) ->
Int -> (Int, Unit) -> IOEnv BkpEnv ()
compileInclude (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Unit]
deps) (Int
i, Unit
dep)
forall a. [(Unit, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession [(Unit, ModRenaming)]
deps_w_rns forall a b. (a -> b) -> a -> b
$ do
ModuleGraph
mod_graph <- Bool -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph Bool
True (forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
lunit)
Messager
msg <- BkpM Messager
mkBackpackMsg
SuccessFlag
ok <- forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' Maybe ModIfaceCache
noIfaceCache LoadHowMuch
LoadAllTargets (forall a. a -> Maybe a
Just Messager
msg) ModuleGraph
mod_graph
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SuccessFlag -> Bool
failed SuccessFlag
ok) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1))
addUnit :: GhcMonad m => UnitInfo -> m ()
addUnit :: forall (m :: * -> *).
GhcMonad m =>
GenericUnitInfo PackageId PackageName UnitId ModuleName Module
-> m ()
addUnit GenericUnitInfo PackageId PackageName UnitId ModuleName Module
u = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
let dflags0 :: DynFlags
dflags0 = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let old_unit_env :: UnitEnv
old_unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
[UnitDatabase UnitId]
newdbs <- case UnitEnv -> Maybe [UnitDatabase UnitId]
ue_unit_dbs UnitEnv
old_unit_env of
Maybe [UnitDatabase UnitId]
Nothing -> forall a. HasCallStack => FilePath -> a
panic FilePath
"addUnit: called too early"
Just [UnitDatabase UnitId]
dbs ->
let newdb :: UnitDatabase UnitId
newdb = UnitDatabase
{ unitDatabasePath :: FilePath
unitDatabasePath = FilePath
"(in memory " forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags0 (forall a. Outputable a => a -> SDoc
ppr (forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo PackageId PackageName UnitId ModuleName Module
u)) forall a. [a] -> [a] -> [a]
++ FilePath
")"
, unitDatabaseUnits :: [GenericUnitInfo PackageId PackageName UnitId ModuleName Module]
unitDatabaseUnits = [GenericUnitInfo PackageId PackageName UnitId ModuleName Module
u]
}
in forall (m :: * -> *) a. Monad m => a -> m a
return ([UnitDatabase UnitId]
dbs forall a. [a] -> [a] -> [a]
++ [UnitDatabase UnitId
newdb])
([UnitDatabase UnitId]
dbs,UnitState
unit_state,HomeUnit
home_unit,Maybe PlatformConstants
mconstants) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> Set UnitId
-> IO
([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags0 (forall a. a -> Maybe a
Just [UnitDatabase UnitId]
newdbs) (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env)
DynFlags
dflags <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe PlatformConstants -> IO DynFlags
updatePlatformConstants DynFlags
dflags0 Maybe PlatformConstants
mconstants
let unit_env :: UnitEnv
unit_env = UnitState -> UnitEnv -> UnitEnv
ue_setUnits UnitState
unit_state forall a b. (a -> b) -> a -> b
$ Maybe [UnitDatabase UnitId] -> UnitEnv -> UnitEnv
ue_setUnitDbs (forall a. a -> Maybe a
Just [UnitDatabase UnitId]
dbs) forall a b. (a -> b) -> a -> b
$ UnitEnv
{ ue_platform :: Platform
ue_platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
, ue_namever :: GhcNameVersion
ue_namever = DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags
, ue_current_unit :: UnitId
ue_current_unit = forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit
, ue_home_unit_graph :: HomeUnitGraph
ue_home_unit_graph =
forall v. UnitId -> v -> UnitEnvGraph v
unitEnv_singleton
(forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit)
(DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
mkHomeUnitEnv DynFlags
dflags (HasDebugCallStack => UnitEnv -> HomePackageTable
ue_hpt UnitEnv
old_unit_env) (forall a. a -> Maybe a
Just HomeUnit
home_unit))
, ue_eps :: ExternalUnitCache
ue_eps = UnitEnv -> ExternalUnitCache
ue_eps UnitEnv
old_unit_env
}
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_unit_env :: UnitEnv
hsc_unit_env = UnitEnv
unit_env }
compileInclude :: Int -> (Int, Unit) -> BkpM ()
compileInclude :: Int -> (Int, Unit) -> IOEnv BkpEnv ()
compileInclude Int
n (Int
i, Unit
uid) = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let pkgs :: UnitState
pkgs = HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env
(Int, Int) -> Unit -> IOEnv BkpEnv ()
msgInclude (Int
i, Int
n) Unit
uid
case Unit
uid of
Unit
HoleUnit -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
RealUnit Definite UnitId
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
VirtUnit GenInstantiatedUnit UnitId
i -> case UnitState
-> Unit
-> Maybe
(GenericUnitInfo PackageId PackageName UnitId ModuleName Module)
lookupUnit UnitState
pkgs Unit
uid of
Maybe
(GenericUnitInfo PackageId PackageName UnitId ModuleName Module)
Nothing -> forall a. BkpM a -> BkpM a
innerBkpM forall a b. (a -> b) -> a -> b
$ UnitId -> [(ModuleName, Module)] -> IOEnv BkpEnv ()
compileUnit (forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf GenInstantiatedUnit UnitId
i) (forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit UnitId
i)
Just GenericUnitInfo PackageId PackageName UnitId ModuleName Module
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
type BkpM = IOEnv BkpEnv
data BkpEnv
= BkpEnv {
BkpEnv -> Session
bkp_session :: Session,
BkpEnv -> FilePath
bkp_filename :: FilePath,
BkpEnv -> Map UnitId (LHsUnit HsComponentId)
bkp_table :: Map UnitId (LHsUnit HsComponentId),
BkpEnv -> Int
bkp_level :: Int
}
instance {-# OVERLAPPING #-} HasDynFlags BkpM where
getDynFlags :: BkpM DynFlags
getDynFlags = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HscEnv -> DynFlags
hsc_dflags forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
instance {-# OVERLAPPING #-} HasLogger BkpM where
getLogger :: BkpM Logger
getLogger = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HscEnv -> Logger
hsc_logger forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
instance GhcMonad BkpM where
getSession :: BkpM HscEnv
getSession = do
Session IORef HscEnv
s <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BkpEnv -> Session
bkp_session forall env. IOEnv env env
getEnv
forall a env. IORef a -> IOEnv env a
readMutVar IORef HscEnv
s
setSession :: HscEnv -> IOEnv BkpEnv ()
setSession HscEnv
hsc_env = do
Session IORef HscEnv
s <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BkpEnv -> Session
bkp_session forall env. IOEnv env env
getEnv
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef HscEnv
s HscEnv
hsc_env
getBkpEnv :: BkpM BkpEnv
getBkpEnv :: BkpM BkpEnv
getBkpEnv = forall env. IOEnv env env
getEnv
getBkpLevel :: BkpM Int
getBkpLevel :: BkpM Int
getBkpLevel = BkpEnv -> Int
bkp_level forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` BkpM BkpEnv
getBkpEnv
innerBkpM :: BkpM a -> BkpM a
innerBkpM :: forall a. BkpM a -> BkpM a
innerBkpM BkpM a
do_this =
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\BkpEnv
env -> BkpEnv
env { bkp_level :: Int
bkp_level = BkpEnv -> Int
bkp_level BkpEnv
env forall a. Num a => a -> a -> a
+ Int
1 }) BkpM a
do_this
updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
updateEpsGhc_ :: forall (m :: * -> *).
GhcMonad m =>
(ExternalPackageState -> ExternalPackageState) -> m ()
updateEpsGhc_ ExternalPackageState -> ExternalPackageState
f = 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
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (ExternalUnitCache -> IORef ExternalPackageState
euc_eps (UnitEnv -> ExternalUnitCache
ue_eps (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env))) (\ExternalPackageState
x -> (ExternalPackageState -> ExternalPackageState
f ExternalPackageState
x, ()))
getEpsGhc :: GhcMonad m => m ExternalPackageState
getEpsGhc :: forall (m :: * -> *). GhcMonad m => m ExternalPackageState
getEpsGhc = 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 -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
initBkpM :: forall a. FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
initBkpM FilePath
file [LHsUnit HsComponentId]
bkp BkpM a
m =
forall a. (Session -> IO a) -> Ghc a
reifyGhc forall a b. (a -> b) -> a -> b
$ \Session
session -> do
let env :: BkpEnv
env = BkpEnv {
bkp_session :: Session
bkp_session = Session
session,
bkp_table :: Map UnitId (LHsUnit HsComponentId)
bkp_table = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(HsComponentId -> UnitId
hsComponentId (forall l e. GenLocated l e -> e
unLoc (forall n. HsUnit n -> Located n
hsunitName (forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
u))), LHsUnit HsComponentId
u) | LHsUnit HsComponentId
u <- [LHsUnit HsComponentId]
bkp],
bkp_filename :: FilePath
bkp_filename = FilePath
file,
bkp_level :: Int
bkp_level = Int
0
}
forall env a. env -> IOEnv env a -> IO a
runIOEnv BkpEnv
env BkpM a
m
backpackProgressMsg :: Int -> Logger -> SDoc -> IO ()
backpackProgressMsg :: Int -> Logger -> SDoc -> IO ()
backpackProgressMsg Int
level Logger
logger SDoc
msg =
Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => FilePath -> doc
text (forall a. Int -> a -> [a]
replicate (Int
level forall a. Num a => a -> a -> a
* Int
2) Char
' ')
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
msg
mkBackpackMsg :: BkpM Messager
mkBackpackMsg :: BkpM Messager
mkBackpackMsg = do
Int
level <- BkpM Int
getBkpLevel
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
recomp ModuleGraphNode
node ->
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
state :: UnitState
state = HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env
showMsg :: SDoc -> SDoc -> IO ()
showMsg SDoc
msg SDoc
reason =
Int -> Logger -> SDoc -> IO ()
backpackProgressMsg Int
level Logger
logger forall a b. (a -> b) -> a -> b
$ UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state forall a b. (a -> b) -> a -> b
$
(Int, Int) -> SDoc
showModuleIndex (Int, Int)
mod_index forall doc. IsLine doc => doc -> doc -> doc
<>
SDoc
msg forall doc. IsLine doc => doc -> doc -> doc
<> DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp) ModuleGraphNode
node
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
reason
in case ModuleGraphNode
node of
InstantiationNode UnitId
_ GenInstantiatedUnit UnitId
_ ->
case RecompileRequired
recomp of
RecompileRequired
UpToDate
| DynFlags -> Int
verbosity (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) forall a. Ord a => a -> a -> Bool
>= Int
2 -> SDoc -> SDoc -> IO ()
showMsg (forall doc. IsLine doc => FilePath -> doc
text FilePath
"Skipping ") forall doc. IsOutput doc => doc
empty
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
NeedsRecompile CompileReason
reason0 -> SDoc -> SDoc -> IO ()
showMsg (forall doc. IsLine doc => FilePath -> doc
text FilePath
"Instantiating ") forall a b. (a -> b) -> a -> b
$ case CompileReason
reason0 of
CompileReason
MustCompile -> forall doc. IsOutput doc => doc
empty
RecompBecause RecompReason
reason -> forall doc. IsLine doc => FilePath -> doc
text FilePath
" [" forall doc. IsLine doc => doc -> doc -> doc
<> UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state (forall a. Outputable a => a -> SDoc
ppr RecompReason
reason) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => FilePath -> doc
text FilePath
"]"
ModuleNode [NodeKey]
_ ModSummary
_ ->
case RecompileRequired
recomp of
RecompileRequired
UpToDate
| DynFlags -> Int
verbosity (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) forall a. Ord a => a -> a -> Bool
>= Int
2 -> SDoc -> SDoc -> IO ()
showMsg (forall doc. IsLine doc => FilePath -> doc
text FilePath
"Skipping ") forall doc. IsOutput doc => doc
empty
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
NeedsRecompile CompileReason
reason0 -> SDoc -> SDoc -> IO ()
showMsg (forall doc. IsLine doc => FilePath -> doc
text FilePath
"Compiling ") forall a b. (a -> b) -> a -> b
$ case CompileReason
reason0 of
CompileReason
MustCompile -> forall doc. IsOutput doc => doc
empty
RecompBecause RecompReason
reason -> forall doc. IsLine doc => FilePath -> doc
text FilePath
" [" forall doc. IsLine doc => doc -> doc -> doc
<> UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state (forall a. Outputable a => a -> SDoc
ppr RecompReason
reason) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => FilePath -> doc
text FilePath
"]"
LinkNode [NodeKey]
_ UnitId
_ -> SDoc -> SDoc -> IO ()
showMsg (forall doc. IsLine doc => FilePath -> doc
text FilePath
"Linking ") forall doc. IsOutput doc => doc
empty
backpackStyle :: PprStyle
backpackStyle :: PprStyle
backpackStyle =
NamePprCtx -> Depth -> PprStyle
mkUserStyle
(QueryQualifyName
-> QueryQualifyModule
-> QueryQualifyPackage
-> QueryPromotionTick
-> NamePprCtx
QueryQualify QueryQualifyName
neverQualifyNames
QueryQualifyModule
alwaysQualifyModules
QueryQualifyPackage
neverQualifyPackages
QueryPromotionTick
alwaysPrintPromTick)
Depth
AllTheWay
msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
msgTopPackage :: (Int, Int) -> HsComponentId -> IOEnv BkpEnv ()
msgTopPackage (Int
i,Int
n) (HsComponentId (PackageName FastString
fs_pn) UnitId
_) = do
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
Int
level <- BkpM Int
getBkpLevel
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Logger -> SDoc -> IO ()
backpackProgressMsg Int
level Logger
logger
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> SDoc
showModuleIndex (Int
i, Int
n) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => FilePath -> doc
text FilePath
"Processing " forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => FastString -> doc
ftext FastString
fs_pn
msgUnitId :: Unit -> BkpM ()
msgUnitId :: Unit -> IOEnv BkpEnv ()
msgUnitId Unit
pk = do
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
Int
level <- BkpM Int
getBkpLevel
let state :: UnitState
state = HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Logger -> SDoc -> IO ()
backpackProgressMsg Int
level Logger
logger
forall a b. (a -> b) -> a -> b
$ UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state
forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => FilePath -> doc
text FilePath
"Instantiating "
forall doc. IsLine doc => doc -> doc -> doc
<> PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
backpackStyle (forall a. Outputable a => a -> SDoc
ppr Unit
pk)
msgInclude :: (Int,Int) -> Unit -> BkpM ()
msgInclude :: (Int, Int) -> Unit -> IOEnv BkpEnv ()
msgInclude (Int
i,Int
n) Unit
uid = do
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
Int
level <- BkpM Int
getBkpLevel
let state :: UnitState
state = HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Logger -> SDoc -> IO ()
backpackProgressMsg Int
level Logger
logger
forall a b. (a -> b) -> a -> b
$ UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> SDoc
showModuleIndex (Int
i, Int
n) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => FilePath -> doc
text FilePath
"Including "
forall doc. IsLine doc => doc -> doc -> doc
<> PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
backpackStyle (forall a. Outputable a => a -> SDoc
ppr Unit
uid)
type PackageNameMap a = UniqFM PackageName a
unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
unitDefines (L SrcSpan
_ HsUnit{ hsunitName :: forall n. HsUnit n -> Located n
hsunitName = L SrcSpan
_ pn :: PackageName
pn@(PackageName FastString
fs) })
= (PackageName
pn, PackageName -> UnitId -> HsComponentId
HsComponentId PackageName
pn (FastString -> UnitId
UnitId FastString
fs))
bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
bkpPackageNameMap [LHsUnit PackageName]
units = forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM (forall a b. (a -> b) -> [a] -> [b]
map LHsUnit PackageName -> (PackageName, HsComponentId)
unitDefines [LHsUnit PackageName]
units)
renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
renameHsUnits :: UnitState
-> PackageNameMap HsComponentId
-> [LHsUnit PackageName]
-> [LHsUnit HsComponentId]
renameHsUnits UnitState
pkgstate PackageNameMap HsComponentId
m [LHsUnit PackageName]
units = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsUnit PackageName -> HsUnit HsComponentId
renameHsUnit) [LHsUnit PackageName]
units
where
renamePackageName :: PackageName -> HsComponentId
renamePackageName :: PackageName -> HsComponentId
renamePackageName PackageName
pn =
case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM PackageNameMap HsComponentId
m PackageName
pn of
Maybe HsComponentId
Nothing ->
case UnitState -> PackageName -> Maybe UnitId
lookupPackageName UnitState
pkgstate PackageName
pn of
Maybe UnitId
Nothing -> forall a. HasCallStack => FilePath -> a
error FilePath
"no package name"
Just UnitId
cid -> PackageName -> UnitId -> HsComponentId
HsComponentId PackageName
pn UnitId
cid
Just HsComponentId
hscid -> HsComponentId
hscid
renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
renameHsUnit HsUnit PackageName
u =
HsUnit {
hsunitName :: Located HsComponentId
hsunitName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageName -> HsComponentId
renamePackageName (forall n. HsUnit n -> Located n
hsunitName HsUnit PackageName
u),
hsunitBody :: [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
hsunitBody = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsUnitDecl PackageName -> HsUnitDecl HsComponentId
renameHsUnitDecl) (forall n. HsUnit n -> [LHsUnitDecl n]
hsunitBody HsUnit PackageName
u)
}
renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
renameHsUnitDecl (DeclD HscSource
a GenLocated SrcSpan ModuleName
b Located (HsModule GhcPs)
c) = forall n.
HscSource
-> GenLocated SrcSpan ModuleName
-> Located (HsModule GhcPs)
-> HsUnitDecl n
DeclD HscSource
a GenLocated SrcSpan ModuleName
b Located (HsModule GhcPs)
c
renameHsUnitDecl (IncludeD IncludeDecl PackageName
idecl) =
forall n. IncludeDecl n -> HsUnitDecl n
IncludeD IncludeDecl {
idUnitId :: GenLocated SrcSpan (HsUnitId HsComponentId)
idUnitId = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsUnitId PackageName -> HsUnitId HsComponentId
renameHsUnitId (forall n. IncludeDecl n -> LHsUnitId n
idUnitId IncludeDecl PackageName
idecl),
idModRenaming :: Maybe [LRenaming]
idModRenaming = forall n. IncludeDecl n -> Maybe [LRenaming]
idModRenaming IncludeDecl PackageName
idecl,
idSignatureInclude :: Bool
idSignatureInclude = forall n. IncludeDecl n -> Bool
idSignatureInclude IncludeDecl PackageName
idecl
}
renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
renameHsUnitId (HsUnitId GenLocated SrcSpan PackageName
ln [LHsModuleSubst PackageName]
subst)
= forall n. Located n -> [LHsModuleSubst n] -> HsUnitId n
HsUnitId (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageName -> HsComponentId
renamePackageName GenLocated SrcSpan PackageName
ln) (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsModuleSubst PackageName -> HsModuleSubst HsComponentId
renameHsModuleSubst) [LHsModuleSubst PackageName]
subst)
renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
renameHsModuleSubst (GenLocated SrcSpan ModuleName
lk, LHsModuleId PackageName
lm)
= (GenLocated SrcSpan ModuleName
lk, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsModuleId PackageName -> HsModuleId HsComponentId
renameHsModuleId LHsModuleId PackageName
lm)
renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
renameHsModuleId (HsModuleVar GenLocated SrcSpan ModuleName
lm) = forall n. GenLocated SrcSpan ModuleName -> HsModuleId n
HsModuleVar GenLocated SrcSpan ModuleName
lm
renameHsModuleId (HsModuleId LHsUnitId PackageName
luid GenLocated SrcSpan ModuleName
lm) = forall n.
LHsUnitId n -> GenLocated SrcSpan ModuleName -> HsModuleId n
HsModuleId (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsUnitId PackageName -> HsUnitId HsComponentId
renameHsUnitId LHsUnitId PackageName
luid) GenLocated SrcSpan ModuleName
lm
convertHsComponentId :: HsUnitId HsComponentId -> Unit
convertHsComponentId :: HsUnitId HsComponentId -> Unit
convertHsComponentId (HsUnitId (L SrcSpan
_ HsComponentId
hscid) [LHsModuleSubst HsComponentId]
subst)
= forall u.
IsUnitId u =>
u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u
mkVirtUnit (HsComponentId -> UnitId
hsComponentId HsComponentId
hscid) (forall a b. (a -> b) -> [a] -> [b]
map (HsModuleSubst HsComponentId -> (ModuleName, Module)
convertHsModuleSubst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LHsModuleSubst HsComponentId]
subst)
convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
convertHsModuleSubst (L SrcSpan
_ ModuleName
modname, L SrcSpan
_ HsModuleId HsComponentId
m) = (ModuleName
modname, HsModuleId HsComponentId -> Module
convertHsModuleId HsModuleId HsComponentId
m)
convertHsModuleId :: HsModuleId HsComponentId -> Module
convertHsModuleId :: HsModuleId HsComponentId -> Module
convertHsModuleId (HsModuleVar (L SrcSpan
_ ModuleName
modname)) = forall u. ModuleName -> GenModule (GenUnit u)
mkHoleModule ModuleName
modname
convertHsModuleId (HsModuleId (L SrcSpan
_ HsUnitId HsComponentId
hsuid) (L SrcSpan
_ ModuleName
modname)) = forall u. u -> ModuleName -> GenModule u
mkModule (HsUnitId HsComponentId -> Unit
convertHsComponentId HsUnitId HsComponentId
hsuid) ModuleName
modname
hsunitModuleGraph :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph Bool
do_link HsUnit HsComponentId
unit = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let decls :: [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
decls = forall n. HsUnit n -> [LHsUnitDecl n]
hsunitBody HsUnit HsComponentId
unit
pn :: PackageName
pn = HsComponentId -> PackageName
hsPackageName (forall l e. GenLocated l e -> e
unLoc (forall n. HsUnit n -> Located n
hsunitName HsUnit HsComponentId
unit))
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
sig_keys :: [NodeKey]
sig_keys = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit) forall a b. (a -> b) -> a -> b
$ \(ModuleName
mod_name, Module
_) -> ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mod_name IsBootInterface
NotBoot) (forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit))
keys :: [NodeKey]
keys = [ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid ModuleNameWithIsBoot
gwib (forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit)) | (DeclD HscSource
hsc_src GenLocated SrcSpan ModuleName
lmodname Located (HsModule GhcPs)
_) <- forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
decls, let gwib :: ModuleNameWithIsBoot
gwib = forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
lmodname) (HscSource -> IsBootInterface
hscSourceToIsBoot HscSource
hsc_src) ]
let get_decl :: GenLocated SrcSpan (HsUnitDecl HsComponentId)
-> IOEnv BkpEnv (Maybe ModuleGraphNode)
get_decl (L SrcSpan
_ (DeclD HscSource
hsc_src GenLocated SrcSpan ModuleName
lmodname Located (HsModule GhcPs)
hsmod)) =
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> HscSource
-> GenLocated SrcSpan ModuleName
-> Located (HsModule GhcPs)
-> [NodeKey]
-> BkpM ModuleGraphNode
summariseDecl PackageName
pn HscSource
hsc_src GenLocated SrcSpan ModuleName
lmodname Located (HsModule GhcPs)
hsmod ([NodeKey]
keys forall a. [a] -> [a] -> [a]
++ [NodeKey]
sig_keys)
get_decl GenLocated SrcSpan (HsUnitDecl HsComponentId)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
[ModuleGraphNode]
nodes <- forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM GenLocated SrcSpan (HsUnitDecl HsComponentId)
-> IOEnv BkpEnv (Maybe ModuleGraphNode)
get_decl [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
decls
let hsig_set :: Set ModuleName
hsig_set = forall a. Ord a => [a] -> Set a
Set.fromList
[ ModSummary -> ModuleName
ms_mod_name ModSummary
ms
| ModuleNode [NodeKey]
_ ModSummary
ms <- [ModuleGraphNode]
nodes
, ModSummary -> HscSource
ms_hsc_src ModSummary
ms forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
]
[ModuleGraphNode]
req_nodes <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit) forall a b. (a -> b) -> a -> b
$ \(ModuleName
mod_name, Module
_) ->
if forall a. Ord a => a -> Set a -> Bool
Set.member ModuleName
mod_name Set ModuleName
hsig_set
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageName -> ModuleName -> BkpM ModuleGraphNode
summariseRequirement PackageName
pn ModuleName
mod_name
let graph_nodes :: [ModuleGraphNode]
graph_nodes = [ModuleGraphNode]
nodes forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
req_nodes forall a. [a] -> [a] -> [a]
++ (UnitId -> UnitState -> [ModuleGraphNode]
instantiationNodes (forall u. GenHomeUnit u -> UnitId
homeUnitId forall a b. (a -> b) -> a -> b
$ HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env))
key_nodes :: [NodeKey]
key_nodes = forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey [ModuleGraphNode]
graph_nodes
all_nodes :: [ModuleGraphNode]
all_nodes = [ModuleGraphNode]
graph_nodes forall a. [a] -> [a] -> [a]
++ [[NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
key_nodes (forall u. GenHomeUnit u -> UnitId
homeUnitId forall a b. (a -> b) -> a -> b
$ HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) | Bool
do_link]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
(forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeKey]
key_nodes forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Ord a => [a] -> [a]
ordNub [NodeKey]
key_nodes))
(forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"Duplicate nodes keys in backpack file" (forall a. Outputable a => a -> SDoc
ppr [NodeKey]
key_nodes))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ModuleGraphNode] -> ModuleGraph
mkModuleGraph forall a b. (a -> b) -> a -> b
$ [ModuleGraphNode]
all_nodes
summariseRequirement :: PackageName -> ModuleName -> BkpM ModuleGraphNode
summariseRequirement :: PackageName -> ModuleName -> BkpM ModuleGraphNode
summariseRequirement PackageName
pn ModuleName
mod_name = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
let fopts :: FinderOpts
fopts = DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags
let PackageName FastString
pn_fs = PackageName
pn
let location :: ModLocation
location = FinderOpts -> ModuleName -> FilePath -> FilePath -> ModLocation
mkHomeModLocation2 FinderOpts
fopts ModuleName
mod_name
(FastString -> FilePath
unpackFS FastString
pn_fs FilePath -> FilePath -> FilePath
</> ModuleName -> FilePath
moduleNameSlashes ModuleName
mod_name) FilePath
"hsig"
BkpEnv
env <- BkpM BkpEnv
getBkpEnv
Fingerprint
src_hash <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Fingerprint
getFileHash (BkpEnv -> FilePath
bkp_filename BkpEnv
env)
Maybe UTCTime
hi_timestamp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
location)
Maybe UTCTime
hie_timestamp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
location)
let loc :: SrcSpan
loc = SrcLoc -> SrcSpan
srcLocSpan (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
mkFastString (BkpEnv -> FilePath
bkp_filename BkpEnv
env)) Int
1 Int
1)
let fc :: FinderCache
fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
Module
mod <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder FinderCache
fc HomeUnit
home_unit ModuleName
mod_name ModLocation
location
[ModuleName]
extra_sig_imports <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> HscSource -> ModuleName -> IO [ModuleName]
findExtraSigImports HscEnv
hsc_env HscSource
HsigFile ModuleName
mod_name
let ms :: ModSummary
ms = ModSummary {
ms_mod :: Module
ms_mod = Module
mod,
ms_hsc_src :: HscSource
ms_hsc_src = HscSource
HsigFile,
ms_location :: ModLocation
ms_location = ModLocation
location,
ms_hs_hash :: Fingerprint
ms_hs_hash = Fingerprint
src_hash,
ms_obj_date :: Maybe UTCTime
ms_obj_date = forall a. Maybe a
Nothing,
ms_dyn_obj_date :: Maybe UTCTime
ms_dyn_obj_date = forall a. Maybe a
Nothing,
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_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_srcimps = [],
ms_textual_imps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_textual_imps = ((,) PkgQual
NoPkgQual 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]
extra_sig_imports,
ms_ghc_prim_import :: Bool
ms_ghc_prim_import = Bool
False,
ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = forall a. a -> Maybe a
Just (HsParsedModule {
hpm_module :: Located (HsModule GhcPs)
hpm_module = forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsModule {
hsmodExt :: XCModule GhcPs
hsmodExt = XModulePs {
hsmodAnn :: EpAnn AnnsModule
hsmodAnn = forall a. EpAnn a
noAnn,
hsmodLayout :: LayoutInfo GhcPs
hsmodLayout = forall pass. LayoutInfo pass
NoLayoutInfo,
hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs))
hsmodDeprecMessage = forall a. Maybe a
Nothing,
hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
hsmodHaddockModHeader = forall a. Maybe a
Nothing
},
hsmodName :: Maybe (XRec GhcPs ModuleName)
hsmodName = forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) ModuleName
mod_name),
hsmodExports :: Maybe (XRec GhcPs [LIE GhcPs])
hsmodExports = forall a. Maybe a
Nothing,
hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [],
hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = []
}),
hpm_src_files :: [FilePath]
hpm_src_files = []
}),
ms_hspp_file :: FilePath
ms_hspp_file = FilePath
"",
ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dflags,
ms_hspp_buf :: Maybe StringBuffer
ms_hspp_buf = forall a. Maybe a
Nothing
}
let nodes :: [NodeKey]
nodes = [ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mn IsBootInterface
NotBoot) (forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit)) | ModuleName
mn <- [ModuleName]
extra_sig_imports ]
forall (m :: * -> *) a. Monad m => a -> m a
return ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
nodes ModSummary
ms)
summariseDecl :: PackageName
-> HscSource
-> Located ModuleName
-> Located (HsModule GhcPs)
-> [NodeKey]
-> BkpM ModuleGraphNode
summariseDecl :: PackageName
-> HscSource
-> GenLocated SrcSpan ModuleName
-> Located (HsModule GhcPs)
-> [NodeKey]
-> BkpM ModuleGraphNode
summariseDecl PackageName
pn HscSource
hsc_src (L SrcSpan
_ ModuleName
modname) Located (HsModule GhcPs)
hsmod [NodeKey]
home_keys = [NodeKey]
-> PackageName
-> HscSource
-> ModuleName
-> Located (HsModule GhcPs)
-> BkpM ModuleGraphNode
hsModuleToModSummary [NodeKey]
home_keys PackageName
pn HscSource
hsc_src ModuleName
modname Located (HsModule GhcPs)
hsmod
hsModuleToModSummary :: [NodeKey]
-> PackageName
-> HscSource
-> ModuleName
-> Located (HsModule GhcPs)
-> BkpM ModuleGraphNode
hsModuleToModSummary :: [NodeKey]
-> PackageName
-> HscSource
-> ModuleName
-> Located (HsModule GhcPs)
-> BkpM ModuleGraphNode
hsModuleToModSummary [NodeKey]
home_keys PackageName
pn HscSource
hsc_src ModuleName
modname
Located (HsModule GhcPs)
hsmod = do
let imps :: [LImportDecl GhcPs]
imps = forall p. HsModule p -> [LImportDecl p]
hsmodImports (forall l e. GenLocated l e -> e
unLoc Located (HsModule GhcPs)
hsmod)
loc :: SrcSpan
loc = forall l e. GenLocated l e -> l
getLoc Located (HsModule GhcPs)
hsmod
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let PackageName FastString
unit_fs = PackageName
pn
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
fopts :: FinderOpts
fopts = DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags
let location0 :: ModLocation
location0 = FinderOpts -> ModuleName -> FilePath -> FilePath -> ModLocation
mkHomeModLocation2 FinderOpts
fopts ModuleName
modname
(FastString -> FilePath
unpackFS FastString
unit_fs FilePath -> FilePath -> FilePath
</>
ModuleName -> FilePath
moduleNameSlashes ModuleName
modname)
(case HscSource
hsc_src of
HscSource
HsigFile -> FilePath
"hsig"
HscSource
HsBootFile -> FilePath
"hs-boot"
HscSource
HsSrcFile -> FilePath
"hs")
let location :: ModLocation
location = case HscSource
hsc_src of
HscSource
HsBootFile -> ModLocation -> ModLocation
addBootSuffixLocnOut ModLocation
location0
HscSource
_ -> ModLocation
location0
Maybe UTCTime
hi_timestamp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
location)
Maybe UTCTime
hie_timestamp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
location)
let ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls, [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> IsBootInterface
ideclSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LImportDecl GhcPs]
imps
([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps, [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ghc_prim_import)
= forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
/= forall unit. GenModule unit -> ModuleName
moduleName Module
gHC_PRIM) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls
implicit_prelude :: Bool
implicit_prelude = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitPrelude DynFlags
dflags
implicit_imports :: [LImportDecl GhcPs]
implicit_imports = ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports ModuleName
modname SrcSpan
loc
Bool
implicit_prelude [LImportDecl GhcPs]
imps
rn_pkg_qual :: RawPkgQual -> PkgQual
rn_pkg_qual = UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
renameRawPkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) ModuleName
modname
convImport :: GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (PkgQual, GenLocated SrcSpan ModuleName)
convImport (L SrcSpanAnnA
_ ImportDecl GhcPs
i) = (RawPkgQual -> PkgQual
rn_pkg_qual (forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl GhcPs
i), forall a e. LocatedAn a e -> Located e
reLoc forall a b. (a -> b) -> a -> b
$ forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
i)
[ModuleName]
extra_sig_imports <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> HscSource -> ModuleName -> IO [ModuleName]
findExtraSigImports HscEnv
hsc_env HscSource
hsc_src ModuleName
modname
let normal_imports :: [(PkgQual, GenLocated SrcSpan ModuleName)]
normal_imports = forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (PkgQual, GenLocated SrcSpan ModuleName)
convImport ([LImportDecl GhcPs]
implicit_imports forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps)
([ModuleName]
implicit_sigs, [GenInstantiatedUnit UnitId]
inst_deps) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> IO ([ModuleName], [GenInstantiatedUnit UnitId])
implicitRequirementsShallow HscEnv
hsc_env [(PkgQual, GenLocated SrcSpan ModuleName)]
normal_imports
Module
this_mod <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
let fc :: FinderCache
fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder FinderCache
fc HomeUnit
home_unit ModuleName
modname ModLocation
location
let ms :: ModSummary
ms = ModSummary {
ms_mod :: Module
ms_mod = Module
this_mod,
ms_hsc_src :: HscSource
ms_hsc_src = HscSource
hsc_src,
ms_location :: ModLocation
ms_location = ModLocation
location,
ms_hspp_file :: FilePath
ms_hspp_file = (case DynFlags -> Maybe FilePath
hiDir DynFlags
dflags of
Maybe FilePath
Nothing -> FilePath
""
Just FilePath
d -> FilePath
d) FilePath -> FilePath -> FilePath
</> FilePath
".." FilePath -> FilePath -> FilePath
</> ModuleName -> FilePath
moduleNameSlashes ModuleName
modname FilePath -> FilePath -> FilePath
<.> FilePath
"hi",
ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dflags,
ms_hspp_buf :: Maybe StringBuffer
ms_hspp_buf = forall a. Maybe a
Nothing,
ms_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_srcimps = forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (PkgQual, GenLocated SrcSpan ModuleName)
convImport [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls,
ms_ghc_prim_import :: Bool
ms_ghc_prim_import = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ghc_prim_import),
ms_textual_imps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_textual_imps = [(PkgQual, GenLocated SrcSpan ModuleName)]
normal_imports
forall a. [a] -> [a] -> [a]
++ ((,) PkgQual
NoPkgQual 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]
extra_sig_imports)
forall a. [a] -> [a] -> [a]
++ ((,) PkgQual
NoPkgQual 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_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = forall a. a -> Maybe a
Just (HsParsedModule {
hpm_module :: Located (HsModule GhcPs)
hpm_module = Located (HsModule GhcPs)
hsmod,
hpm_src_files :: [FilePath]
hpm_src_files = []
}),
ms_hs_hash :: Fingerprint
ms_hs_hash = Fingerprint
fingerprint0,
ms_obj_date :: Maybe UTCTime
ms_obj_date = forall a. Maybe a
Nothing,
ms_dyn_obj_date :: Maybe UTCTime
ms_dyn_obj_date = forall a. Maybe a
Nothing,
ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp,
ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
}
let inst_nodes :: [NodeKey]
inst_nodes = forall a b. (a -> b) -> [a] -> [b]
map GenInstantiatedUnit UnitId -> NodeKey
NodeKey_Unit [GenInstantiatedUnit UnitId]
inst_deps
mod_nodes :: [NodeKey]
mod_nodes =
[NodeKey
k | NodeKey
k <- [ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
IsBoot) (Module -> UnitId
moduleUnitId Module
this_mod))], IsBootInterface
NotBoot forall a. Eq a => a -> a -> Bool
== ModSummary -> IsBootInterface
isBootSummary ModSummary
ms, NodeKey
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NodeKey]
home_keys ] forall a. [a] -> [a] -> [a]
++
[NodeKey
k | (PkgQual
_, GenWithIsBoot (GenLocated SrcSpan ModuleName)
mnwib) <- ModSummary
-> [(PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
msDeps ModSummary
ms, let k :: NodeKey
k = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc GenWithIsBoot (GenLocated SrcSpan ModuleName)
mnwib) (Module -> UnitId
moduleUnitId Module
this_mod)), NodeKey
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NodeKey]
home_keys]
forall (m :: * -> *) a. Monad m => a -> m a
return ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode ([NodeKey]
mod_nodes forall a. [a] -> [a] -> [a]
++ [NodeKey]
inst_nodes) ModSummary
ms)
newUnitId :: UnitId -> Maybe FastString -> UnitId
newUnitId :: UnitId -> Maybe FastString -> UnitId
newUnitId UnitId
uid Maybe FastString
mhash = case Maybe FastString
mhash of
Maybe FastString
Nothing -> UnitId
uid
Just FastString
hash -> FastString -> UnitId
UnitId ([FastString] -> FastString
concatFS [UnitId -> FastString
unitIdFS UnitId
uid, FilePath -> FastString
fsLit FilePath
"+", FastString
hash])