{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}


-- | This is the driver for the 'ghc --backpack' mode, which
-- is a reimplementation of the "package manager" bits of
-- Backpack directly in GHC.  The basic method of operation
-- is to compile packages and then directly insert them into
-- GHC's in memory database.
--
-- The compilation products of this mode aren't really suitable
-- for Cabal, because GHC makes up component IDs for the things
-- it builds and doesn't serialize out the database contents.
-- But it's still handy for constructing tests.

module GHC.Driver.Backpack (doBackpack) where

import GHC.Prelude

import GHC.Driver.Backend
-- In a separate module because it hooks into the parser.
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

-- for the unification
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
import GHC.Types.Error (mkUnknownDiagnostic)

-- | Entry point to compile a Backpack file.
doBackpack :: [FilePath] -> Ghc ()
doBackpack :: [FilePath] -> Ghc ()
doBackpack [FilePath
src_filename] = do
    -- Apply options from file to dflags
    dflags0 <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let dflags1 = DynFlags
dflags0
    let parser_opts1 = DynFlags -> ParserOpts
initParserOpts DynFlags
dflags1
    (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 src_filename
    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
    modifySession (hscSetFlags dflags)
    logger <- getLogger -- Get the logger after having set the session flags,
                        -- so that logger options are correctly set.
                        -- Not doing so caused #20396.
    -- Cribbed from: preprocessFile / GHC.Driver.Pipeline
    liftIO $ checkProcessArgsResult unhandled_flags
    let print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags
    liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcPsMessage <$> p_warns)
    liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcDriverMessage <$> warns)
    -- TODO: Preprocessing not implemented

    buf <- liftIO $ hGetStringBuffer src_filename
    let loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
src_filename) Int
1 Int
1 -- TODO: not great
    case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of
        PFailed PState
pst -> Messages GhcMessage -> Ghc ()
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
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
            -- OK, so we have an LHsUnit PackageName, but we want an
            -- LHsUnit HsComponentId.  So let's rename it.
            hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
            let bkp = UnitState
-> PackageNameMap HsComponentId
-> [LHsUnit PackageName]
-> [LHsUnit HsComponentId]
renameHsUnits (HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env) ([LHsUnit PackageName] -> PackageNameMap HsComponentId
bkpPackageNameMap [LHsUnit PackageName]
pkgname_bkp) [LHsUnit PackageName]
pkgname_bkp
            initBkpM src_filename bkp $
                forM_ (zip [1..] bkp) $ \(Int
i, LHsUnit HsComponentId
lunit) -> do
                    let comp_name :: HsComponentId
comp_name = GenLocated SrcSpan HsComponentId -> HsComponentId
forall l e. GenLocated l e -> e
unLoc (HsUnit HsComponentId -> GenLocated SrcSpan HsComponentId
forall n. HsUnit n -> Located n
hsunitName (LHsUnit HsComponentId -> HsUnit HsComponentId
forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
lunit))
                    (Int, Int) -> HsComponentId -> BkpM ()
msgTopPackage (Int
i,[LHsUnit HsComponentId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsUnit HsComponentId]
bkp) HsComponentId
comp_name
                    BkpM () -> BkpM ()
forall a. BkpM a -> BkpM a
innerBkpM (BkpM () -> BkpM ()) -> BkpM () -> BkpM ()
forall a b. (a -> b) -> a -> b
$ do
                        let (UnitId
cid, [(ModuleName, Module)]
insts) = LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)])
computeUnitId LHsUnit HsComponentId
lunit
                        if [(ModuleName, Module)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, Module)]
insts
                            then if UnitId
cid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> UnitId
UnitId (FilePath -> FastString
fsLit FilePath
"main")
                                    then LHsUnit HsComponentId -> BkpM ()
compileExe LHsUnit HsComponentId
lunit
                                    else UnitId -> [(ModuleName, Module)] -> BkpM ()
compileUnit UnitId
cid []
                            else UnitId -> [(ModuleName, Module)] -> BkpM ()
typecheckUnit UnitId
cid [(ModuleName, Module)]
insts
doBackpack [FilePath]
_ =
    GhcException -> Ghc ()
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, ModuleName -> Module
forall u. ModuleName -> GenModule (GenUnit u)
mkHoleModule ModuleName
r) | ModuleName
r <- [ModuleName]
reqs ])
  where
    cid :: UnitId
cid = HsComponentId -> UnitId
hsComponentId (GenLocated SrcSpan HsComponentId -> HsComponentId
forall l e. GenLocated l e -> e
unLoc (HsUnit HsComponentId -> GenLocated SrcSpan HsComponentId
forall n. HsUnit n -> Located n
hsunitName HsUnit HsComponentId
unit))
    reqs :: [ModuleName]
reqs = UniqDSet ModuleName -> [ModuleName]
forall a. UniqDSet a -> [a]
uniqDSetToList ([UniqDSet ModuleName] -> UniqDSet ModuleName
forall a. [UniqDSet a] -> UniqDSet a
unionManyUniqDSets ((GenLocated SrcSpan (HsUnitDecl HsComponentId)
 -> UniqDSet ModuleName)
-> [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
-> [UniqDSet ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (HsUnitDecl HsComponentId -> UniqDSet ModuleName
get_reqs (HsUnitDecl HsComponentId -> UniqDSet ModuleName)
-> (GenLocated SrcSpan (HsUnitDecl HsComponentId)
    -> HsUnitDecl HsComponentId)
-> GenLocated SrcSpan (HsUnitDecl HsComponentId)
-> UniqDSet ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan (HsUnitDecl HsComponentId)
-> HsUnitDecl HsComponentId
forall l e. GenLocated l e -> e
unLoc) (HsUnit HsComponentId
-> [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
forall n. HsUnit n -> [LHsUnitDecl n]
hsunitBody HsUnit HsComponentId
unit)))
    get_reqs :: HsUnitDecl HsComponentId -> UniqDSet ModuleName
get_reqs (DeclD HscSource
HsSrcFile Located ModuleName
_ Located (HsModule GhcPs)
_) = UniqDSet ModuleName
forall a. UniqDSet a
emptyUniqDSet
    get_reqs (DeclD HscSource
HsBootFile Located ModuleName
_ Located (HsModule GhcPs)
_) = UniqDSet ModuleName
forall a. UniqDSet a
emptyUniqDSet
    get_reqs (DeclD HscSource
HsigFile (L SrcSpan
_ ModuleName
modname) Located (HsModule GhcPs)
_) = ModuleName -> UniqDSet ModuleName
forall a. Uniquable a => a -> UniqDSet a
unitUniqDSet ModuleName
modname
    get_reqs (IncludeD (IncludeDecl (L SrcSpan
_ HsUnitId HsComponentId
hsuid) Maybe [LRenaming]
_ Bool
_)) =
        Unit -> UniqDSet ModuleName
forall u. GenUnit u -> UniqDSet ModuleName
unitFreeModuleHoles (HsUnitId HsComponentId -> Unit
convertHsComponentId HsUnitId HsComponentId
hsuid)

-- | Tiny enum for all types of Backpack operations we may do.
data SessionType
    -- | A compilation operation which will result in a
    -- runnable executable being produced.
    = ExeSession
    -- | A type-checking operation which produces only
    -- interface files, no object files.
    | TcSession
    -- | A compilation operation which produces both
    -- interface files and object files.
    | CompSession
    deriving (SessionType -> SessionType -> Bool
(SessionType -> SessionType -> Bool)
-> (SessionType -> SessionType -> Bool) -> Eq SessionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SessionType -> SessionType -> Bool
== :: SessionType -> SessionType -> Bool
$c/= :: SessionType -> SessionType -> Bool
/= :: SessionType -> SessionType -> Bool
Eq)

-- | Create a temporary Session to do some sort of type checking or
-- compilation.
withBkpSession :: UnitId
               -> [(ModuleName, Module)]
               -> [(Unit, ModRenaming)]
               -> SessionType   -- what kind of session are we doing
               -> BkpM a        -- actual action to run
               -> 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
    dflags <- IOEnv BkpEnv DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let cid_fs = UnitId -> FastString
forall u. IsUnitId u => u -> FastString
unitFS UnitId
cid
        is_primary = Bool
False
        uid_str = FastString -> FilePath
unpackFS (UnitId -> [(ModuleName, Module)] -> FastString
forall u.
IsUnitId u =>
u -> [(ModuleName, GenModule (GenUnit u))] -> FastString
mkInstantiatedUnitHash UnitId
cid [(ModuleName, Module)]
insts)
        cid_str = FastString -> FilePath
unpackFS FastString
cid_fs
        -- There are multiple units in a single Backpack file, so we
        -- need to separate out the results in those cases.  Right now,
        -- we follow this hierarchy:
        --      $outputdir/$compid          --> typecheck results
        --      $outputdir/$compid/$unitid  --> compile results
        key_base DynFlags -> Maybe FilePath
p | Just FilePath
f <- DynFlags -> Maybe FilePath
p DynFlags
dflags = FilePath
f
                   | Bool
otherwise          = FilePath
"."
        sub_comp FilePath
p | Bool
is_primary = FilePath
p
                   | Bool
otherwise = FilePath
p FilePath -> FilePath -> FilePath
</> FilePath
cid_str
        outdir DynFlags -> Maybe FilePath
p | SessionType
CompSession <- SessionType
session_type
                 -- Special case when package is definite
                 , Bool -> Bool
not ([(ModuleName, Module)] -> Bool
forall a. [a] -> Bool
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
hsc_env =
          (DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags (\DynFlags
dflags -> UnitState -> DynFlags -> DynFlags
mk_temp_dflags (HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env) DynFlags
dflags) HscEnv
hsc_env
        mk_temp_dflags UnitState
unit_state DynFlags
dflags = DynFlags
dflags
            { backend = case session_type of
                            SessionType
TcSession -> Backend
noBackend
                            SessionType
_         -> DynFlags -> Backend
backend DynFlags
dflags
            , ghcLink = case session_type of
                            SessionType
TcSession -> GhcLink
NoLink
                            SessionType
_         -> DynFlags -> GhcLink
ghcLink DynFlags
dflags
            , homeUnitInstantiations_ = insts
                                     -- if we don't have any instantiation, don't
                                     -- fill `homeUnitInstanceOfId` as it makes no
                                     -- sense (we're not instantiating anything)
            , homeUnitInstanceOf_   = if null insts then Nothing else Just cid
            , homeUnitId_ = case session_type of
                SessionType
TcSession -> UnitId -> Maybe FastString -> UnitId
newUnitId UnitId
cid Maybe FastString
forall a. Maybe a
Nothing
                -- No hash passed if no instances
                SessionType
_ | [(ModuleName, Module)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, Module)]
insts -> UnitId -> Maybe FastString -> UnitId
newUnitId UnitId
cid Maybe FastString
forall a. Maybe a
Nothing
                  | Bool
otherwise  -> UnitId -> Maybe FastString -> UnitId
newUnitId UnitId
cid (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (UnitId -> [(ModuleName, Module)] -> FastString
forall u.
IsUnitId u =>
u -> [(ModuleName, GenModule (GenUnit u))] -> FastString
mkInstantiatedUnitHash UnitId
cid [(ModuleName, Module)]
insts))


            -- If we're type-checking an indefinite package, we want to
            -- turn on interface writing.  However, if the user also
            -- explicitly passed in `-fno-code`, we DON'T want to write
            -- interfaces unless the user also asked for `-fwrite-interface`.
            -- See Note [-fno-code mode]
            , generalFlags = case session_type of
                -- Make sure to write interfaces when we are type-checking
                -- indefinite packages.
                SessionType
TcSession
                  | Backend -> Bool
backendSupportsInterfaceWriting (Backend -> Bool) -> Backend -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Backend
backend DynFlags
dflags
                  -> GeneralFlag -> EnumSet GeneralFlag -> EnumSet GeneralFlag
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

            -- Setup all of the output directories according to our hierarchy
            , objectDir   = Just (outdir objectDir)
            , hiDir       = Just (outdir hiDir)
            , stubDir     = Just (outdir stubDir)
            -- Unset output-file for non exe builds
            , outputFile_ = case session_type of
                SessionType
ExeSession -> DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags
                SessionType
_          -> Maybe FilePath
forall a. Maybe a
Nothing
            , dynOutputFile_ = case session_type of
                SessionType
ExeSession -> DynFlags -> Maybe FilePath
dynOutputFile_ DynFlags
dflags
                SessionType
_          -> Maybe FilePath
forall a. Maybe a
Nothing
            -- Clear the import path so we don't accidentally grab anything
            , importPaths = []
            -- Synthesize the flags
            , packageFlags = packageFlags dflags ++ map (\(Unit
uid0, ModRenaming
rn) ->
              let uid :: Unit
uid = UnitState -> Unit -> Unit
unwireUnit UnitState
unit_state
                        (Unit -> Unit) -> Unit -> Unit
forall a b. (a -> b) -> a -> b
$ UnitState -> Unit -> Unit
improveUnit UnitState
unit_state
                        (Unit -> Unit) -> Unit -> Unit
forall a b. (a -> b) -> a -> b
$ UnitState -> ShHoleSubst -> Unit -> Unit
renameHoleUnit UnitState
unit_state ([(ModuleName, Module)] -> ShHoleSubst
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
                    (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"-unit-id" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
uid SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModRenaming -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModRenaming
rn))
                (Unit -> PackageArg
UnitIdArg Unit
uid) ModRenaming
rn) deps
            }
    withTempSession mk_temp_env $ do
      dflags <- getSessionDynFlags
      -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
      setSessionDynFlags dflags -- calls initUnits
      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 =
    UnitId
-> [(ModuleName, Module)]
-> [(Unit, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
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
    bkp_env <- BkpM BkpEnv
getBkpEnv
    case Map.lookup cid (bkp_table bkp_env) of
        Maybe (LHsUnit HsComponentId)
Nothing -> FilePath -> SDoc -> BkpM (LHsUnit HsComponentId)
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"missing needed dependency" (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
cid)
        Just LHsUnit HsComponentId
lunit -> LHsUnit HsComponentId -> BkpM (LHsUnit HsComponentId)
forall a. a -> IOEnv BkpEnv a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsUnit HsComponentId
lunit

typecheckUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
typecheckUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
typecheckUnit UnitId
cid [(ModuleName, Module)]
insts = do
    lunit <- UnitId -> BkpM (LHsUnit HsComponentId)
getSource UnitId
cid
    buildUnit TcSession cid insts lunit

compileUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
compileUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
compileUnit UnitId
cid [(ModuleName, Module)]
insts = do
    -- Let everyone know we're building this unit
    Unit -> BkpM ()
msgUnitId (UnitId -> [(ModuleName, Module)] -> Unit
forall u.
IsUnitId u =>
u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u
mkVirtUnit UnitId
cid [(ModuleName, Module)]
insts)
    lunit <- UnitId -> BkpM (LHsUnit HsComponentId)
getSource UnitId
cid
    buildUnit CompSession cid insts lunit

-- | Compute the dependencies with instantiations of a syntactic
-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a
-- unit file, return the 'Unit' corresponding to @p[A=<A>]@.
-- The @include_sigs@ parameter controls whether or not we also
-- include @dependency signature@ declarations in this calculation.
--
-- Invariant: this NEVER returns UnitId.
hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(Unit, ModRenaming)]
hsunitDeps :: Bool -> HsUnit HsComponentId -> [(Unit, ModRenaming)]
hsunitDeps Bool
include_sigs HsUnit HsComponentId
unit = (GenLocated SrcSpan (HsUnitDecl HsComponentId)
 -> [(Unit, ModRenaming)])
-> [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
-> [(Unit, ModRenaming)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenLocated SrcSpan (HsUnitDecl HsComponentId)
-> [(Unit, ModRenaming)]
get_dep (HsUnit HsComponentId
-> [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
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, Maybe [LRenaming] -> ModRenaming
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 ((GenLocated l Renaming -> (ModuleName, ModuleName))
-> [GenLocated l Renaming] -> [(ModuleName, ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated l Renaming -> (ModuleName, ModuleName)
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 (Located 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
-> BkpM ()
buildUnit SessionType
session UnitId
cid [(ModuleName, Module)]
insts LHsUnit HsComponentId
lunit = do
    -- NB: include signature dependencies ONLY when typechecking.
    -- If we're compiling, it's not necessary to recursively
    -- compile a signature since it isn't going to produce
    -- any object files.
    let deps_w_rns :: [(Unit, ModRenaming)]
deps_w_rns = Bool -> HsUnit HsComponentId -> [(Unit, ModRenaming)]
hsunitDeps (SessionType
session SessionType -> SessionType -> Bool
forall a. Eq a => a -> a -> Bool
== SessionType
TcSession) (LHsUnit HsComponentId -> HsUnit HsComponentId
forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
lunit)
        raw_deps :: [Unit]
raw_deps = ((Unit, ModRenaming) -> Unit) -> [(Unit, ModRenaming)] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map (Unit, ModRenaming) -> Unit
forall a b. (a, b) -> a
fst [(Unit, ModRenaming)]
deps_w_rns
    hsc_env <- IOEnv BkpEnv HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    -- The compilation dependencies are just the appropriately filled
    -- in unit IDs which must be compiled before we can compile.
    let hsubst = [(ModuleName, Module)] -> ShHoleSubst
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(ModuleName, Module)]
insts
        deps0 = (Unit -> Unit) -> [Unit] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> ShHoleSubst -> Unit -> Unit
renameHoleUnit (HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env) ShHoleSubst
hsubst) [Unit]
raw_deps

    -- Build dependencies OR make sure they make sense. BUT NOTE,
    -- we can only check the ones that are fully filled; the rest
    -- we have to defer until we've typechecked our local signature.
    -- TODO: work this into GHC.Driver.Make!!
    forM_ (zip [1..] deps0) $ \(Int
i, Unit
dep) ->
        case SessionType
session of
            SessionType
TcSession -> () -> BkpM ()
forall a. a -> IOEnv BkpEnv a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            SessionType
_ -> Int -> (Int, Unit) -> BkpM ()
compileInclude ([Unit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Unit]
deps0) (Int
i, Unit
dep)

    -- IMPROVE IT
    let deps = (Unit -> Unit) -> [Unit] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> Unit -> Unit
improveUnit (HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env)) [Unit]
deps0

    mb_old_eps <- case session of
                    SessionType
TcSession -> (ExternalPackageState -> Maybe ExternalPackageState)
-> IOEnv BkpEnv ExternalPackageState
-> IOEnv BkpEnv (Maybe ExternalPackageState)
forall a b. (a -> b) -> IOEnv BkpEnv a -> IOEnv BkpEnv b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExternalPackageState -> Maybe ExternalPackageState
forall a. a -> Maybe a
Just IOEnv BkpEnv ExternalPackageState
forall (m :: * -> *). GhcMonad m => m ExternalPackageState
getEpsGhc
                    SessionType
_ -> Maybe ExternalPackageState
-> IOEnv BkpEnv (Maybe ExternalPackageState)
forall a. a -> IOEnv BkpEnv a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ExternalPackageState
forall a. Maybe a
Nothing

    conf <- withBkpSession cid insts deps_w_rns session $ do

        dflags <- getDynFlags
        mod_graph <- hsunitModuleGraph False (unLoc lunit)

        msg <- mkBackpackMsg
        ok <- load' noIfaceCache LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph
        when (failed ok) (liftIO $ exitWith (ExitFailure 1))

        let hi_dir = FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust (FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
panic FilePath
"hiDir Backpack") (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe FilePath
hiDir DynFlags
dflags
            export_mod ModSummary
ms = (ModSummary -> ModuleName
ms_mod_name ModSummary
ms, ModSummary -> Module
ms_mod ModSummary
ms)
            -- Export everything!
            mods = [ ModSummary -> (ModuleName, Module)
export_mod ModSummary
ms | ModSummary
ms <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph
                                   , ModSummary -> HscSource
ms_hsc_src ModSummary
ms HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile ]

        -- Compile relevant only
        hsc_env <- getSession
        let home_mod_infos = UniqDFM ModuleName HomeModInfo -> [HomeModInfo]
forall {k} (key :: k) elt. UniqDFM key elt -> [elt]
eltsUDFM (HscEnv -> UniqDFM ModuleName HomeModInfo
hsc_HPT HscEnv
hsc_env)
            linkables = (HomeModInfo -> Linkable) -> [HomeModInfo] -> [Linkable]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe Linkable -> Linkable
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"bkp link" (Maybe Linkable -> Linkable)
-> (HomeModInfo -> Maybe Linkable) -> HomeModInfo -> Linkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> Maybe Linkable
homeModInfoObject)
                      ([HomeModInfo] -> [Linkable])
-> ([HomeModInfo] -> [HomeModInfo]) -> [HomeModInfo] -> [Linkable]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HomeModInfo -> Bool) -> [HomeModInfo] -> [HomeModInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
==HscSource
HsSrcFile) (HscSource -> Bool)
-> (HomeModInfo -> HscSource) -> HomeModInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface_ 'ModIfaceFinal -> HscSource
forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_src (ModIface_ 'ModIfaceFinal -> HscSource)
-> (HomeModInfo -> ModIface_ 'ModIfaceFinal)
-> HomeModInfo
-> HscSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface)
                      ([HomeModInfo] -> [Linkable]) -> [HomeModInfo] -> [Linkable]
forall a b. (a -> b) -> a -> b
$ [HomeModInfo]
home_mod_infos
            getOfiles LM{ linkableUnlinked :: Linkable -> [Unlinked]
linkableUnlinked = [Unlinked]
us } = (Unlinked -> FilePath) -> [Unlinked] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Unlinked -> FilePath
nameOfObject ((Unlinked -> Bool) -> [Unlinked] -> [Unlinked]
forall a. (a -> Bool) -> [a] -> [a]
filter Unlinked -> Bool
isObject [Unlinked]
us)
            obj_files = (Linkable -> [FilePath]) -> [Linkable] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Linkable -> [FilePath]
getOfiles [Linkable]
linkables
            state     = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env

        let compat_fs = UnitId -> FastString
unitIdFS UnitId
cid
            compat_pn = FastString -> PackageName
PackageName FastString
compat_fs
            unit_id   = GenHomeUnit UnitId -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId (HscEnv -> GenHomeUnit UnitId
hsc_home_unit HscEnv
hsc_env)

        return GenericUnitInfo {
            -- Stub data
            unitAbiHash = "",
            unitPackageId = PackageId compat_fs,
            unitPackageName = compat_pn,
            unitPackageVersion = makeVersion [],
            unitId = unit_id,
            unitComponentName = Nothing,
            unitInstanceOf = cid,
            unitInstantiations = insts,
            -- Slight inefficiency here haha
            unitExposedModules = map (\(ModuleName
m,Module
n) -> (ModuleName
m,Module -> Maybe Module
forall a. a -> Maybe a
Just Module
n)) mods,
            unitHiddenModules = [], -- TODO: doc only
            unitDepends = case session of
                        -- Technically, we should state that we depend
                        -- on all the indefinite libraries we used to
                        -- typecheck this.  However, this field isn't
                        -- really used for anything, so we leave it
                        -- blank for now.
                        SessionType
TcSession -> []
                        SessionType
_ -> (Unit -> UnitId) -> [Unit] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (Unit -> UnitId
toUnitId (Unit -> UnitId) -> (Unit -> Unit) -> Unit -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitState -> Unit -> Unit
unwireUnit UnitState
state)
                                ([Unit] -> [UnitId]) -> [Unit] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ [Unit]
deps [Unit] -> [Unit] -> [Unit]
forall a. [a] -> [a] -> [a]
++ [ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod
                                          | (ModuleName
_, Module
mod) <- [(ModuleName, Module)]
insts
                                          , Bool -> Bool
not (Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
mod) ],
            unitAbiDepends = [],
            unitLinkerOptions = case session of
                                 SessionType
TcSession -> []
                                 SessionType
_ -> (FilePath -> ShortText) -> [FilePath] -> [ShortText]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> ShortText
ST.pack ([FilePath] -> [ShortText]) -> [FilePath] -> [ShortText]
forall a b. (a -> b) -> a -> b
$ [FilePath]
obj_files,
            unitImportDirs = [ ST.pack $ hi_dir ],
            unitIsExposed = False,
            unitIsIndefinite = case session of
                                 SessionType
TcSession -> Bool
True
                                 SessionType
_ -> Bool
False,
            -- nope
            unitLibraries = [],
            unitExtDepLibsSys = [],
            unitExtDepLibsGhc = [],
            unitLibraryDynDirs = [],
            unitLibraryDirs = [],
            unitExtDepFrameworks = [],
            unitExtDepFrameworkDirs = [],
            unitCcOptions = [],
            unitIncludes = [],
            unitIncludeDirs = [],
            unitHaddockInterfaces = [],
            unitHaddockHTMLs = [],
            unitIsTrusted = False
            }


    addUnit conf
    case mb_old_eps of
        Just ExternalPackageState
old_eps -> (ExternalPackageState -> ExternalPackageState) -> BkpM ()
forall (m :: * -> *).
GhcMonad m =>
(ExternalPackageState -> ExternalPackageState) -> m ()
updateEpsGhc_ (ExternalPackageState
-> ExternalPackageState -> ExternalPackageState
forall a b. a -> b -> a
const ExternalPackageState
old_eps)
        Maybe ExternalPackageState
_ -> () -> BkpM ()
forall a. a -> IOEnv BkpEnv a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

compileExe :: LHsUnit HsComponentId -> BkpM ()
compileExe :: LHsUnit HsComponentId -> BkpM ()
compileExe LHsUnit HsComponentId
lunit = do
    Unit -> BkpM ()
msgUnitId Unit
mainUnit
    let deps_w_rns :: [(Unit, ModRenaming)]
deps_w_rns = Bool -> HsUnit HsComponentId -> [(Unit, ModRenaming)]
hsunitDeps Bool
False (LHsUnit HsComponentId -> HsUnit HsComponentId
forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
lunit)
        deps :: [Unit]
deps = ((Unit, ModRenaming) -> Unit) -> [(Unit, ModRenaming)] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map (Unit, ModRenaming) -> Unit
forall a b. (a, b) -> a
fst [(Unit, ModRenaming)]
deps_w_rns
        -- no renaming necessary
    [(Int, Unit)] -> ((Int, Unit) -> BkpM ()) -> BkpM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Unit] -> [(Int, Unit)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Unit]
deps) (((Int, Unit) -> BkpM ()) -> BkpM ())
-> ((Int, Unit) -> BkpM ()) -> BkpM ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, Unit
dep) ->
        Int -> (Int, Unit) -> BkpM ()
compileInclude ([Unit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Unit]
deps) (Int
i, Unit
dep)
    [(Unit, ModRenaming)] -> BkpM () -> BkpM ()
forall a. [(Unit, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession [(Unit, ModRenaming)]
deps_w_rns (BkpM () -> BkpM ()) -> BkpM () -> BkpM ()
forall a b. (a -> b) -> a -> b
$ do
        mod_graph <- Bool -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph Bool
True (LHsUnit HsComponentId -> HsUnit HsComponentId
forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
lunit)
        msg <- mkBackpackMsg
        ok <- load' noIfaceCache LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph
        when (failed ok) (liftIO $ exitWith (ExitFailure 1))

-- | Register a new virtual unit database containing a single unit
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
    hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    logger <- getLogger
    let dflags0 = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let old_unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
    newdbs <- case ue_unit_dbs old_unit_env of
        Maybe [UnitDatabase UnitId]
Nothing  -> FilePath -> m [UnitDatabase UnitId]
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 " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags0 (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenericUnitInfo PackageId PackageName UnitId ModuleName Module
-> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo PackageId PackageName UnitId ModuleName Module
u)) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"
               , unitDatabaseUnits :: [GenericUnitInfo PackageId PackageName UnitId ModuleName Module]
unitDatabaseUnits = [GenericUnitInfo PackageId PackageName UnitId ModuleName Module
u]
               }
         in [UnitDatabase UnitId] -> m [UnitDatabase UnitId]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([UnitDatabase UnitId]
dbs [UnitDatabase UnitId]
-> [UnitDatabase UnitId] -> [UnitDatabase UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitDatabase UnitId
newdb]) -- added at the end because ordering matters
    (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)

    -- update platform constants
    dflags <- liftIO $ updatePlatformConstants dflags0 mconstants

    let unit_env = UnitState -> UnitEnv -> UnitEnv
ue_setUnits UnitState
unit_state (UnitEnv -> UnitEnv) -> UnitEnv -> UnitEnv
forall a b. (a -> b) -> a -> b
$ Maybe [UnitDatabase UnitId] -> UnitEnv -> UnitEnv
ue_setUnitDbs ([UnitDatabase UnitId] -> Maybe [UnitDatabase UnitId]
forall a. a -> Maybe a
Just [UnitDatabase UnitId]
dbs) (UnitEnv -> UnitEnv) -> UnitEnv -> UnitEnv
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 = GenHomeUnit UnitId -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId GenHomeUnit UnitId
home_unit

          , ue_home_unit_graph :: HomeUnitGraph
ue_home_unit_graph =
                UnitId -> HomeUnitEnv -> HomeUnitGraph
forall v. UnitId -> v -> UnitEnvGraph v
unitEnv_singleton
                    (GenHomeUnit UnitId -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId GenHomeUnit UnitId
home_unit)
                    (DynFlags
-> UniqDFM ModuleName HomeModInfo
-> Maybe (GenHomeUnit UnitId)
-> HomeUnitEnv
mkHomeUnitEnv DynFlags
dflags (HasDebugCallStack => UnitEnv -> UniqDFM ModuleName HomeModInfo
UnitEnv -> UniqDFM ModuleName HomeModInfo
ue_hpt UnitEnv
old_unit_env) (GenHomeUnit UnitId -> Maybe (GenHomeUnit UnitId)
forall a. a -> Maybe a
Just GenHomeUnit UnitId
home_unit))
          , ue_eps :: ExternalUnitCache
ue_eps       = UnitEnv -> ExternalUnitCache
ue_eps UnitEnv
old_unit_env
          }
    setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }

compileInclude :: Int -> (Int, Unit) -> BkpM ()
compileInclude :: Int -> (Int, Unit) -> BkpM ()
compileInclude Int
n (Int
i, Unit
uid) = do
    hsc_env <- IOEnv BkpEnv HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    let pkgs = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
    msgInclude (i, n) uid
    -- Check if we've compiled it already
    case uid of
      Unit
HoleUnit   -> () -> BkpM ()
forall a. a -> IOEnv BkpEnv a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      RealUnit Definite UnitId
_ -> () -> BkpM ()
forall a. a -> IOEnv BkpEnv a
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 -> BkpM () -> BkpM ()
forall a. BkpM a -> BkpM a
innerBkpM (BkpM () -> BkpM ()) -> BkpM () -> BkpM ()
forall a b. (a -> b) -> a -> b
$ UnitId -> [(ModuleName, Module)] -> BkpM ()
compileUnit (GenInstantiatedUnit UnitId -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf GenInstantiatedUnit UnitId
i) (GenInstantiatedUnit UnitId -> [(ModuleName, Module)]
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit UnitId
i)
        Just GenericUnitInfo PackageId PackageName UnitId ModuleName Module
_  -> () -> BkpM ()
forall a. a -> IOEnv BkpEnv a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- ----------------------------------------------------------------------------
-- Backpack monad

-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
-- beyond the 'Session', c.f. 'BkpEnv'.
type BkpM = IOEnv BkpEnv

-- | Backpack environment.  NB: this has a 'Session' and not an 'HscEnv',
-- because we are going to update the 'HscEnv' as we go.
data BkpEnv
    = BkpEnv {
        -- | The session
        BkpEnv -> Session
bkp_session :: Session,
        -- | The filename of the bkp file we're compiling
        BkpEnv -> FilePath
bkp_filename :: FilePath,
        -- | Table of source units which we know how to compile
        BkpEnv -> Map UnitId (LHsUnit HsComponentId)
bkp_table :: Map UnitId (LHsUnit HsComponentId),
        -- | When a package we are compiling includes another package
        -- which has not been compiled, we bump the level and compile
        -- that.
        BkpEnv -> Int
bkp_level :: Int
    }

-- Blah, to get rid of the default instance for IOEnv
-- TODO: just make a proper new monad for BkpM, rather than use IOEnv
instance {-# OVERLAPPING #-} HasDynFlags BkpM where
    getDynFlags :: IOEnv BkpEnv DynFlags
getDynFlags = (HscEnv -> DynFlags)
-> IOEnv BkpEnv HscEnv -> IOEnv BkpEnv DynFlags
forall a b. (a -> b) -> IOEnv BkpEnv a -> IOEnv BkpEnv b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HscEnv -> DynFlags
hsc_dflags IOEnv BkpEnv HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
instance {-# OVERLAPPING #-} HasLogger BkpM where
    getLogger :: BkpM Logger
getLogger = (HscEnv -> Logger) -> IOEnv BkpEnv HscEnv -> BkpM Logger
forall a b. (a -> b) -> IOEnv BkpEnv a -> IOEnv BkpEnv b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HscEnv -> Logger
hsc_logger IOEnv BkpEnv HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession


instance GhcMonad BkpM where
    getSession :: IOEnv BkpEnv HscEnv
getSession = do
        Session s <- (BkpEnv -> Session) -> BkpM BkpEnv -> IOEnv BkpEnv Session
forall a b. (a -> b) -> IOEnv BkpEnv a -> IOEnv BkpEnv b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BkpEnv -> Session
bkp_session BkpM BkpEnv
forall env. IOEnv env env
getEnv
        readMutVar s
    setSession :: HscEnv -> BkpM ()
setSession HscEnv
hsc_env = do
        Session s <- (BkpEnv -> Session) -> BkpM BkpEnv -> IOEnv BkpEnv Session
forall a b. (a -> b) -> IOEnv BkpEnv a -> IOEnv BkpEnv b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BkpEnv -> Session
bkp_session BkpM BkpEnv
forall env. IOEnv env env
getEnv
        writeMutVar s hsc_env

-- | Get the current 'BkpEnv'.
getBkpEnv :: BkpM BkpEnv
getBkpEnv :: BkpM BkpEnv
getBkpEnv = BkpM BkpEnv
forall env. IOEnv env env
getEnv

-- | Get the nesting level, when recursively compiling modules.
getBkpLevel :: BkpM Int
getBkpLevel :: BkpM Int
getBkpLevel = BkpEnv -> Int
bkp_level (BkpEnv -> Int) -> BkpM BkpEnv -> BkpM Int
forall a b. (a -> b) -> IOEnv BkpEnv a -> IOEnv BkpEnv b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` BkpM BkpEnv
getBkpEnv

-- | Run a 'BkpM' computation, with the nesting level bumped one.
innerBkpM :: BkpM a -> BkpM a
innerBkpM :: forall a. BkpM a -> BkpM a
innerBkpM BkpM a
do_this =
    -- NB: withTempSession mutates, so we don't have to worry
    -- about bkp_session being stale.
    (BkpEnv -> BkpEnv) -> BkpM a -> BkpM a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\BkpEnv
env -> BkpEnv
env { bkp_level = bkp_level env + 1 }) BkpM a
do_this

-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
updateEpsGhc_ :: forall (m :: * -> *).
GhcMonad m =>
(ExternalPackageState -> ExternalPackageState) -> m ()
updateEpsGhc_ ExternalPackageState -> ExternalPackageState
f = do
    hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    liftIO $ atomicModifyIORef' (euc_eps (ue_eps (hsc_unit_env hsc_env))) (\ExternalPackageState
x -> (ExternalPackageState -> ExternalPackageState
f ExternalPackageState
x, ()))

-- | Get the EPS from a 'GhcMonad'.
getEpsGhc :: GhcMonad m => m ExternalPackageState
getEpsGhc :: forall (m :: * -> *). GhcMonad m => m ExternalPackageState
getEpsGhc = do
    hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    liftIO $ hscEPS hsc_env

-- | Run 'BkpM' in 'Ghc'.
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 =
  (Session -> IO a) -> Ghc a
forall a. (Session -> IO a) -> Ghc a
reifyGhc ((Session -> IO a) -> Ghc a) -> (Session -> IO a) -> Ghc a
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 = [(UnitId, LHsUnit HsComponentId)]
-> Map UnitId (LHsUnit HsComponentId)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(HsComponentId -> UnitId
hsComponentId (GenLocated SrcSpan HsComponentId -> HsComponentId
forall l e. GenLocated l e -> e
unLoc (HsUnit HsComponentId -> GenLocated SrcSpan HsComponentId
forall n. HsUnit n -> Located n
hsunitName (LHsUnit HsComponentId -> HsUnit HsComponentId
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
      }
    BkpEnv -> BkpM a -> IO a
forall env a. env -> IOEnv env a -> IO a
runIOEnv BkpEnv
env BkpM a
m

-- ----------------------------------------------------------------------------
-- Messaging

-- | Print a compilation progress message, but with indentation according
-- to @level@ (for nested compilation).
backpackProgressMsg :: Int -> Logger -> SDoc -> IO ()
backpackProgressMsg :: Int -> Logger -> SDoc -> IO ()
backpackProgressMsg Int
level Logger
logger SDoc
msg =
    Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' ') -- TODO: use GHC.Utils.Ppr.RStr
                                    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
msg

-- | Creates a 'Messager' for Backpack compilation; this is basically
-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
-- handles indentation.
mkBackpackMsg :: BkpM Messager
mkBackpackMsg :: BkpM Messager
mkBackpackMsg = do
    level <- BkpM Int
getBkpLevel
    return $ \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
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 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                (Int, Int) -> SDoc
showModuleIndex (Int, Int)
mod_index SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                SDoc
msg SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp) ModuleGraphNode
node
                    SDoc -> SDoc -> SDoc
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) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 -> SDoc -> SDoc -> IO ()
showMsg (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Skipping  ") SDoc
forall doc. IsOutput doc => doc
empty
              | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            NeedsRecompile CompileReason
reason0 -> SDoc -> SDoc -> IO ()
showMsg (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Instantiating ") (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ case CompileReason
reason0 of
              CompileReason
MustCompile -> SDoc
forall doc. IsOutput doc => doc
empty
              RecompBecause RecompReason
reason -> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
" [" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state (RecompReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecompReason
reason) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
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) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 -> SDoc -> SDoc -> IO ()
showMsg (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Skipping  ") SDoc
forall doc. IsOutput doc => doc
empty
              | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            NeedsRecompile CompileReason
reason0 -> SDoc -> SDoc -> IO ()
showMsg (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Compiling ") (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ case CompileReason
reason0 of
              CompileReason
MustCompile -> SDoc
forall doc. IsOutput doc => doc
empty
              RecompBecause RecompReason
reason -> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
" [" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state (RecompReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecompReason
reason) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"]"
        LinkNode [NodeKey]
_ UnitId
_ -> SDoc -> SDoc -> IO ()
showMsg (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Linking ")  SDoc
forall doc. IsOutput doc => doc
empty

-- | 'PprStyle' for Backpack messages; here we usually want the module to
-- be qualified (so we can tell how it was instantiated.) But we try not
-- to qualify packages so we can use simple names for them.
backpackStyle :: PprStyle
backpackStyle :: PprStyle
backpackStyle =
    NamePprCtx -> Depth -> PprStyle
mkUserStyle
        (QueryQualifyName
-> (Module -> Bool)
-> QueryQualifyPackage
-> QueryPromotionTick
-> NamePprCtx
QueryQualify QueryQualifyName
neverQualifyNames
                      Module -> Bool
alwaysQualifyModules
                      QueryQualifyPackage
neverQualifyPackages
                      QueryPromotionTick
alwaysPrintPromTick)
        Depth
AllTheWay

-- | Message when we initially process a Backpack unit.
msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
msgTopPackage :: (Int, Int) -> HsComponentId -> BkpM ()
msgTopPackage (Int
i,Int
n) (HsComponentId (PackageName FastString
fs_pn) UnitId
_) = do
    logger <- BkpM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    level <- getBkpLevel
    liftIO . backpackProgressMsg level logger
        $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn

-- | Message when we instantiate a Backpack unit.
msgUnitId :: Unit -> BkpM ()
msgUnitId :: Unit -> BkpM ()
msgUnitId Unit
pk = do
    logger <- BkpM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    hsc_env <- getSession
    level <- getBkpLevel
    let state = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
    liftIO . backpackProgressMsg level logger
        $ pprWithUnitState state
        $ text "Instantiating "
           <> withPprStyle backpackStyle (ppr pk)

-- | Message when we include a Backpack unit.
msgInclude :: (Int,Int) -> Unit -> BkpM ()
msgInclude :: (Int, Int) -> Unit -> BkpM ()
msgInclude (Int
i,Int
n) Unit
uid = do
    logger <- BkpM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    hsc_env <- getSession
    level <- getBkpLevel
    let state = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
    liftIO . backpackProgressMsg level logger
        $ pprWithUnitState state
        $ showModuleIndex (i, n) <> text "Including "
            <> withPprStyle backpackStyle (ppr uid)

-- ----------------------------------------------------------------------------
-- Conversion from PackageName to HsComponentId

type PackageNameMap a = UniqFM PackageName a

-- For now, something really simple, since we're not actually going
-- to use this for anything
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 = [(PackageName, HsComponentId)] -> PackageNameMap HsComponentId
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM ((LHsUnit PackageName -> (PackageName, HsComponentId))
-> [LHsUnit PackageName] -> [(PackageName, HsComponentId)]
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 = (LHsUnit PackageName -> LHsUnit HsComponentId)
-> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
forall a b. (a -> b) -> [a] -> [b]
map ((HsUnit PackageName -> HsUnit HsComponentId)
-> LHsUnit PackageName -> LHsUnit HsComponentId
forall a b.
(a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b
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 PackageNameMap HsComponentId -> PackageName -> Maybe HsComponentId
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 -> FilePath -> HsComponentId
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 :: GenLocated SrcSpan HsComponentId
hsunitName = (PackageName -> HsComponentId)
-> GenLocated SrcSpan PackageName
-> GenLocated SrcSpan HsComponentId
forall a b.
(a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageName -> HsComponentId
renamePackageName (HsUnit PackageName -> GenLocated SrcSpan PackageName
forall n. HsUnit n -> Located n
hsunitName HsUnit PackageName
u),
            hsunitBody :: [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
hsunitBody = (GenLocated SrcSpan (HsUnitDecl PackageName)
 -> GenLocated SrcSpan (HsUnitDecl HsComponentId))
-> [GenLocated SrcSpan (HsUnitDecl PackageName)]
-> [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
forall a b. (a -> b) -> [a] -> [b]
map ((HsUnitDecl PackageName -> HsUnitDecl HsComponentId)
-> GenLocated SrcSpan (HsUnitDecl PackageName)
-> GenLocated SrcSpan (HsUnitDecl HsComponentId)
forall a b.
(a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsUnitDecl PackageName -> HsUnitDecl HsComponentId
renameHsUnitDecl) (HsUnit PackageName -> [GenLocated SrcSpan (HsUnitDecl PackageName)]
forall n. HsUnit n -> [LHsUnitDecl n]
hsunitBody HsUnit PackageName
u)
        }

    renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
    renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
renameHsUnitDecl (DeclD HscSource
a Located ModuleName
b Located (HsModule GhcPs)
c) = HscSource
-> Located ModuleName
-> Located (HsModule GhcPs)
-> HsUnitDecl HsComponentId
forall n.
HscSource
-> Located ModuleName -> Located (HsModule GhcPs) -> HsUnitDecl n
DeclD HscSource
a Located ModuleName
b Located (HsModule GhcPs)
c
    renameHsUnitDecl (IncludeD IncludeDecl PackageName
idecl) =
        IncludeDecl HsComponentId -> HsUnitDecl HsComponentId
forall n. IncludeDecl n -> HsUnitDecl n
IncludeD IncludeDecl {
            idUnitId :: GenLocated SrcSpan (HsUnitId HsComponentId)
idUnitId = (HsUnitId PackageName -> HsUnitId HsComponentId)
-> GenLocated SrcSpan (HsUnitId PackageName)
-> GenLocated SrcSpan (HsUnitId HsComponentId)
forall a b.
(a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsUnitId PackageName -> HsUnitId HsComponentId
renameHsUnitId (IncludeDecl PackageName
-> GenLocated SrcSpan (HsUnitId PackageName)
forall n. IncludeDecl n -> LHsUnitId n
idUnitId IncludeDecl PackageName
idecl),
            idModRenaming :: Maybe [LRenaming]
idModRenaming = IncludeDecl PackageName -> Maybe [LRenaming]
forall n. IncludeDecl n -> Maybe [LRenaming]
idModRenaming IncludeDecl PackageName
idecl,
            idSignatureInclude :: Bool
idSignatureInclude = IncludeDecl PackageName -> Bool
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)
        = GenLocated SrcSpan HsComponentId
-> [LHsModuleSubst HsComponentId] -> HsUnitId HsComponentId
forall n. Located n -> [LHsModuleSubst n] -> HsUnitId n
HsUnitId ((PackageName -> HsComponentId)
-> GenLocated SrcSpan PackageName
-> GenLocated SrcSpan HsComponentId
forall a b.
(a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageName -> HsComponentId
renamePackageName GenLocated SrcSpan PackageName
ln) ((LHsModuleSubst PackageName -> LHsModuleSubst HsComponentId)
-> [LHsModuleSubst PackageName] -> [LHsModuleSubst HsComponentId]
forall a b. (a -> b) -> [a] -> [b]
map ((HsModuleSubst PackageName -> HsModuleSubst HsComponentId)
-> LHsModuleSubst PackageName -> LHsModuleSubst HsComponentId
forall a b.
(a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b
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 (Located ModuleName
lk, LHsModuleId PackageName
lm)
        = (Located ModuleName
lk, (HsModuleId PackageName -> HsModuleId HsComponentId)
-> LHsModuleId PackageName
-> GenLocated SrcSpan (HsModuleId HsComponentId)
forall a b.
(a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b
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 Located ModuleName
lm) = Located ModuleName -> HsModuleId HsComponentId
forall n. Located ModuleName -> HsModuleId n
HsModuleVar Located ModuleName
lm
    renameHsModuleId (HsModuleId GenLocated SrcSpan (HsUnitId PackageName)
luid Located ModuleName
lm) = GenLocated SrcSpan (HsUnitId HsComponentId)
-> Located ModuleName -> HsModuleId HsComponentId
forall n. LHsUnitId n -> Located ModuleName -> HsModuleId n
HsModuleId ((HsUnitId PackageName -> HsUnitId HsComponentId)
-> GenLocated SrcSpan (HsUnitId PackageName)
-> GenLocated SrcSpan (HsUnitId HsComponentId)
forall a b.
(a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsUnitId PackageName -> HsUnitId HsComponentId
renameHsUnitId GenLocated SrcSpan (HsUnitId PackageName)
luid) Located ModuleName
lm

convertHsComponentId :: HsUnitId HsComponentId -> Unit
convertHsComponentId :: HsUnitId HsComponentId -> Unit
convertHsComponentId (HsUnitId (L SrcSpan
_ HsComponentId
hscid) [LHsModuleSubst HsComponentId]
subst)
    = UnitId -> [(ModuleName, Module)] -> Unit
forall u.
IsUnitId u =>
u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u
mkVirtUnit (HsComponentId -> UnitId
hsComponentId HsComponentId
hscid) ((LHsModuleSubst HsComponentId -> (ModuleName, Module))
-> [LHsModuleSubst HsComponentId] -> [(ModuleName, Module)]
forall a b. (a -> b) -> [a] -> [b]
map (HsModuleSubst HsComponentId -> (ModuleName, Module)
convertHsModuleSubst (HsModuleSubst HsComponentId -> (ModuleName, Module))
-> (LHsModuleSubst HsComponentId -> HsModuleSubst HsComponentId)
-> LHsModuleSubst HsComponentId
-> (ModuleName, Module)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsModuleSubst HsComponentId -> HsModuleSubst HsComponentId
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)) = ModuleName -> Module
forall u. ModuleName -> GenModule (GenUnit u)
mkHoleModule ModuleName
modname
convertHsModuleId (HsModuleId (L SrcSpan
_ HsUnitId HsComponentId
hsuid) (L SrcSpan
_ ModuleName
modname)) = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (HsUnitId HsComponentId -> Unit
convertHsComponentId HsUnitId HsComponentId
hsuid) ModuleName
modname



{-
************************************************************************
*                                                                      *
                        Module graph construction
*                                                                      *
************************************************************************
-}

-- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications:
--
--  1. Every module is required to be mentioned, so we don't do any funny
--     business with targets or recursively grabbing dependencies.  (We
--     could support this in principle).
--  2. We support inline modules, whose summary we have to synthesize ourself.
--
-- We don't bother trying to support GHC.Driver.Make for now, it's more trouble
-- than it's worth for inline modules.
hsunitModuleGraph :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph Bool
do_link HsUnit HsComponentId
unit = do
    hsc_env <- IOEnv BkpEnv HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

    let decls = HsUnit HsComponentId
-> [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
forall n. HsUnit n -> [LHsUnitDecl n]
hsunitBody HsUnit HsComponentId
unit
        pn = HsComponentId -> PackageName
hsPackageName (GenLocated SrcSpan HsComponentId -> HsComponentId
forall l e. GenLocated l e -> e
unLoc (HsUnit HsComponentId -> GenLocated SrcSpan HsComponentId
forall n. HsUnit n -> Located n
hsunitName HsUnit HsComponentId
unit))
        home_unit = HscEnv -> GenHomeUnit UnitId
hsc_home_unit HscEnv
hsc_env

        sig_keys = (((ModuleName, Module) -> NodeKey)
 -> [(ModuleName, Module)] -> [NodeKey])
-> [(ModuleName, Module)]
-> ((ModuleName, Module) -> NodeKey)
-> [NodeKey]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ModuleName, Module) -> NodeKey)
-> [(ModuleName, Module)] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map (GenHomeUnit UnitId -> [(ModuleName, Module)]
forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations GenHomeUnit UnitId
home_unit) (((ModuleName, Module) -> NodeKey) -> [NodeKey])
-> ((ModuleName, Module) -> NodeKey) -> [NodeKey]
forall a b. (a -> b) -> a -> b
$ \(ModuleName
mod_name, Module
_) -> ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mod_name IsBootInterface
NotBoot) (GenHomeUnit UnitId -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId GenHomeUnit UnitId
home_unit))
        keys = [ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid ModuleNameWithIsBoot
gwib (GenHomeUnit UnitId -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId GenHomeUnit UnitId
home_unit)) | (DeclD HscSource
hsc_src Located ModuleName
lmodname Located (HsModule GhcPs)
_) <- (GenLocated SrcSpan (HsUnitDecl HsComponentId)
 -> HsUnitDecl HsComponentId)
-> [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
-> [HsUnitDecl HsComponentId]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan (HsUnitDecl HsComponentId)
-> HsUnitDecl HsComponentId
forall l e. GenLocated l e -> e
unLoc [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
decls, let gwib :: ModuleNameWithIsBoot
gwib = ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (Located ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc Located ModuleName
lmodname) (HscSource -> IsBootInterface
hscSourceToIsBoot HscSource
hsc_src) ]

    --  1. Create a HsSrcFile/HsigFile summary for every
    --  explicitly mentioned module/signature.
    let get_decl (L SrcSpan
_ (DeclD HscSource
hsc_src Located ModuleName
lmodname Located (HsModule GhcPs)
hsmod)) =
          ModuleGraphNode -> Maybe ModuleGraphNode
forall a. a -> Maybe a
Just (ModuleGraphNode -> Maybe ModuleGraphNode)
-> IOEnv BkpEnv ModuleGraphNode
-> IOEnv BkpEnv (Maybe ModuleGraphNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> HscSource
-> Located ModuleName
-> Located (HsModule GhcPs)
-> [NodeKey]
-> IOEnv BkpEnv ModuleGraphNode
summariseDecl PackageName
pn HscSource
hsc_src Located ModuleName
lmodname Located (HsModule GhcPs)
hsmod ([NodeKey]
keys [NodeKey] -> [NodeKey] -> [NodeKey]
forall a. [a] -> [a] -> [a]
++ [NodeKey]
sig_keys)
        get_decl GenLocated SrcSpan (HsUnitDecl HsComponentId)
_ = Maybe ModuleGraphNode -> IOEnv BkpEnv (Maybe ModuleGraphNode)
forall a. a -> IOEnv BkpEnv a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleGraphNode
forall a. Maybe a
Nothing
    nodes <- mapMaybeM get_decl decls

    --  2. For each hole which does not already have an hsig file,
    --  create an "empty" hsig file to induce compilation for the
    --  requirement.
    let hsig_set = [ModuleName] -> Set ModuleName
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 HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
          ]
    req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(ModuleName
mod_name, Module
_) ->
        if ModuleName -> Set ModuleName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ModuleName
mod_name Set ModuleName
hsig_set
            then Maybe ModuleGraphNode -> IOEnv BkpEnv (Maybe ModuleGraphNode)
forall a. a -> IOEnv BkpEnv a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleGraphNode
forall a. Maybe a
Nothing
            else (ModuleGraphNode -> Maybe ModuleGraphNode)
-> IOEnv BkpEnv ModuleGraphNode
-> IOEnv BkpEnv (Maybe ModuleGraphNode)
forall a b. (a -> b) -> IOEnv BkpEnv a -> IOEnv BkpEnv b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModuleGraphNode -> Maybe ModuleGraphNode
forall a. a -> Maybe a
Just (IOEnv BkpEnv ModuleGraphNode
 -> IOEnv BkpEnv (Maybe ModuleGraphNode))
-> IOEnv BkpEnv ModuleGraphNode
-> IOEnv BkpEnv (Maybe ModuleGraphNode)
forall a b. (a -> b) -> a -> b
$ PackageName -> ModuleName -> IOEnv BkpEnv ModuleGraphNode
summariseRequirement PackageName
pn ModuleName
mod_name

    let graph_nodes = [ModuleGraphNode]
nodes [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
req_nodes [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ (UnitId -> UnitState -> [ModuleGraphNode]
instantiationNodes (GenHomeUnit UnitId -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId (GenHomeUnit UnitId -> UnitId) -> GenHomeUnit UnitId -> UnitId
forall a b. (a -> b) -> a -> b
$ HscEnv -> GenHomeUnit UnitId
hsc_home_unit HscEnv
hsc_env) (HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env))
        key_nodes = (ModuleGraphNode -> NodeKey) -> [ModuleGraphNode] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey [ModuleGraphNode]
graph_nodes
        all_nodes = [ModuleGraphNode]
graph_nodes [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [[NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
key_nodes (GenHomeUnit UnitId -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId (GenHomeUnit UnitId -> UnitId) -> GenHomeUnit UnitId -> UnitId
forall a b. (a -> b) -> a -> b
$ HscEnv -> GenHomeUnit UnitId
hsc_home_unit HscEnv
hsc_env) | Bool
do_link]
    -- This error message is not very good but .bkp mode is just for testing so
    -- better to be direct rather than pretty.
    when
      (length key_nodes /= length (ordNub key_nodes))
      (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes))

    -- 3. Return the kaboodle
    return $ mkModuleGraph $ all_nodes


summariseRequirement :: PackageName -> ModuleName -> BkpM ModuleGraphNode
summariseRequirement :: PackageName -> ModuleName -> IOEnv BkpEnv ModuleGraphNode
summariseRequirement PackageName
pn ModuleName
mod_name = do
    hsc_env <- IOEnv BkpEnv HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    let dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let home_unit = HscEnv -> GenHomeUnit UnitId
hsc_home_unit HscEnv
hsc_env
    let fopts = DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags

    let PackageName pn_fs = pn
    let 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"

    env <- getBkpEnv
    src_hash <- liftIO $ getFileHash (bkp_filename env)
    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
    let loc = SrcLoc -> SrcSpan
srcLocSpan (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
mkFastString (BkpEnv -> FilePath
bkp_filename BkpEnv
env)) Int
1 Int
1)

    let fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
    mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location

    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name

    let 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 = Maybe UTCTime
forall a. Maybe a
Nothing,
        ms_dyn_obj_date :: Maybe UTCTime
ms_dyn_obj_date = Maybe UTCTime
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, Located ModuleName)]
ms_srcimps = [],
        ms_textual_imps :: [(PkgQual, Located ModuleName)]
ms_textual_imps = ((,) PkgQual
NoPkgQual (Located ModuleName -> (PkgQual, Located ModuleName))
-> (ModuleName -> Located ModuleName)
-> ModuleName
-> (PkgQual, Located ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Located ModuleName
forall e. e -> Located e
noLoc) (ModuleName -> (PkgQual, Located ModuleName))
-> [ModuleName] -> [(PkgQual, Located ModuleName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
extra_sig_imports,
        ms_ghc_prim_import :: Bool
ms_ghc_prim_import = Bool
False,
        ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = HsParsedModule -> Maybe HsParsedModule
forall a. a -> Maybe a
Just (HsParsedModule {
                hpm_module :: Located (HsModule GhcPs)
hpm_module = SrcSpan -> HsModule GhcPs -> Located (HsModule GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsModule {
                        hsmodExt :: XCModule GhcPs
hsmodExt = XModulePs {
                            hsmodAnn :: EpAnn AnnsModule
hsmodAnn = EpAnn AnnsModule
forall a. NoAnn a => a
noAnn,
                            hsmodLayout :: EpLayout
hsmodLayout = EpLayout
EpNoLayout,
                            hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs)
hsmodDeprecMessage = Maybe (LWarningTxt GhcPs)
Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
forall a. Maybe a
Nothing,
                            hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
hsmodHaddockModHeader = Maybe (LHsDoc GhcPs)
forall a. Maybe a
Nothing
                                             },
                        hsmodName :: Maybe (XRec GhcPs ModuleName)
hsmodName = GenLocated SrcSpanAnnA ModuleName
-> Maybe (GenLocated SrcSpanAnnA ModuleName)
forall a. a -> Maybe a
Just (SrcSpanAnnA -> ModuleName -> GenLocated SrcSpanAnnA ModuleName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) ModuleName
mod_name),
                        hsmodExports :: Maybe (XRec GhcPs [LIE GhcPs])
hsmodExports = Maybe (XRec GhcPs [LIE GhcPs])
Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
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
"", -- none, it came inline
        ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dflags,
        ms_hspp_buf :: Maybe StringBuffer
ms_hspp_buf = Maybe StringBuffer
forall a. Maybe a
Nothing
        }
    let nodes = [ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mn IsBootInterface
NotBoot) (GenHomeUnit UnitId -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId GenHomeUnit UnitId
home_unit)) | ModuleName
mn <- [ModuleName]
extra_sig_imports ]
    return (ModuleNode nodes ms)

summariseDecl :: PackageName
              -> HscSource
              -> Located ModuleName
              -> Located (HsModule GhcPs)
              -> [NodeKey]
              -> BkpM ModuleGraphNode
summariseDecl :: PackageName
-> HscSource
-> Located ModuleName
-> Located (HsModule GhcPs)
-> [NodeKey]
-> IOEnv BkpEnv 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)
-> IOEnv BkpEnv ModuleGraphNode
hsModuleToModSummary [NodeKey]
home_keys PackageName
pn HscSource
hsc_src ModuleName
modname Located (HsModule GhcPs)
hsmod

-- | Up until now, GHC has assumed a single compilation target per source file.
-- Backpack files with inline modules break this model, since a single file
-- may generate multiple output files.  How do we decide to name these files?
-- Should there only be one output file? This function our current heuristic,
-- which is we make a "fake" module and use that.
hsModuleToModSummary :: [NodeKey]
                     -> PackageName
                     -> HscSource
                     -> ModuleName
                     -> Located (HsModule GhcPs)
                     -> BkpM ModuleGraphNode
hsModuleToModSummary :: [NodeKey]
-> PackageName
-> HscSource
-> ModuleName
-> Located (HsModule GhcPs)
-> IOEnv BkpEnv ModuleGraphNode
hsModuleToModSummary [NodeKey]
home_keys PackageName
pn HscSource
hsc_src ModuleName
modname
                     Located (HsModule GhcPs)
hsmod = do
    let imps :: [LImportDecl GhcPs]
imps = HsModule GhcPs -> [LImportDecl GhcPs]
forall p. HsModule p -> [LImportDecl p]
hsmodImports (Located (HsModule GhcPs) -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc Located (HsModule GhcPs)
hsmod)
        loc :: SrcSpan
loc  = Located (HsModule GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located (HsModule GhcPs)
hsmod
    hsc_env <- IOEnv BkpEnv HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation
    -- Use the PACKAGE NAME to find the location
    let PackageName unit_fs = pn
        dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        fopts = DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags
    -- Unfortunately, we have to define a "fake" location in
    -- order to appease the various code which uses the file
    -- name to figure out where to put, e.g. object files.
    -- To add insult to injury, we don't even actually use
    -- these filenames to figure out where the hi files go.
    -- A travesty!
    let 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")
    -- DANGEROUS: bootifying can POISON the module finder cache
    let location = case HscSource
hsc_src of
                        HscSource
HsBootFile -> ModLocation -> ModLocation
addBootSuffixLocnOut ModLocation
location0
                        HscSource
_ -> ModLocation
location0
    -- This duplicates a pile of logic in GHC.Driver.Make
    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)

    -- Also copied from 'getImports'
    let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps

             -- GHC.Prim doesn't exist physically, so don't go looking for it.
        (ordinary_imps, ghc_prim_import)
          = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
              ord_idecls

        implicit_prelude = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitPrelude DynFlags
dflags
        implicit_imports = ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports ModuleName
modname SrcSpan
loc
                                         Bool
implicit_prelude [LImportDecl GhcPs]
imps

        rn_pkg_qual = UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
renameRawPkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) ModuleName
modname
        convImport (L SrcSpanAnnA
_ ImportDecl GhcPs
i) = (RawPkgQual -> PkgQual
rn_pkg_qual (ImportDecl GhcPs -> ImportDeclPkgQual GhcPs
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl GhcPs
i), GenLocated SrcSpanAnnA ModuleName -> Located ModuleName
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc (GenLocated SrcSpanAnnA ModuleName -> Located ModuleName)
-> GenLocated SrcSpanAnnA ModuleName -> Located ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
i)

    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname

    let normal_imports = (GenLocated SrcSpanAnnA (ImportDecl GhcPs)
 -> (PkgQual, Located ModuleName))
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(PkgQual, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (PkgQual, Located ModuleName)
convImport ([LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
implicit_imports [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps)
    (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports

    -- So that Finder can find it, even though it doesn't exist...
    this_mod <- liftIO $ do
      let home_unit = HscEnv -> GenHomeUnit UnitId
hsc_home_unit HscEnv
hsc_env
      let fc        = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
      addHomeModuleToFinder fc home_unit modname location
    let 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 = Maybe StringBuffer
forall a. Maybe a
Nothing,
            ms_srcimps :: [(PkgQual, Located ModuleName)]
ms_srcimps = (GenLocated SrcSpanAnnA (ImportDecl GhcPs)
 -> (PkgQual, Located ModuleName))
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(PkgQual, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (PkgQual, Located ModuleName)
convImport [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls,
            ms_ghc_prim_import :: Bool
ms_ghc_prim_import = Bool -> Bool
not ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ghc_prim_import),
            ms_textual_imps :: [(PkgQual, Located ModuleName)]
ms_textual_imps = [(PkgQual, Located ModuleName)]
normal_imports
                           -- We have to do something special here:
                           -- due to merging, requirements may end up with
                           -- extra imports
                           [(PkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
forall a. [a] -> [a] -> [a]
++ ((,) PkgQual
NoPkgQual (Located ModuleName -> (PkgQual, Located ModuleName))
-> (ModuleName -> Located ModuleName)
-> ModuleName
-> (PkgQual, Located ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Located ModuleName
forall e. e -> Located e
noLoc (ModuleName -> (PkgQual, Located ModuleName))
-> [ModuleName] -> [(PkgQual, Located ModuleName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
extra_sig_imports)
                           [(PkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
-> [(PkgQual, Located ModuleName)]
forall a. [a] -> [a] -> [a]
++ ((,) PkgQual
NoPkgQual (Located ModuleName -> (PkgQual, Located ModuleName))
-> (ModuleName -> Located ModuleName)
-> ModuleName
-> (PkgQual, Located ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Located ModuleName
forall e. e -> Located e
noLoc (ModuleName -> (PkgQual, Located ModuleName))
-> [ModuleName] -> [(PkgQual, Located ModuleName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
implicit_sigs),
            -- This is our hack to get the parse tree to the right spot
            ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = HsParsedModule -> Maybe HsParsedModule
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 = [] -- TODO if we preprocessed it
                }),
            -- Source hash = fingerprint0, so the recompilation tests do not recompile
            -- too much. In future, if necessary then could get the hash by just hashing the
            -- relevant part of the .bkp file.
            ms_hs_hash :: Fingerprint
ms_hs_hash = Fingerprint
fingerprint0,
            ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
forall a. Maybe a
Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
            ms_dyn_obj_date :: Maybe UTCTime
ms_dyn_obj_date = Maybe UTCTime
forall a. Maybe a
Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
            ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp,
            ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
          }

    -- Now, what are the dependencies.
    let inst_nodes = (GenInstantiatedUnit UnitId -> NodeKey)
-> [GenInstantiatedUnit UnitId] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map GenInstantiatedUnit UnitId -> NodeKey
NodeKey_Unit [GenInstantiatedUnit UnitId]
inst_deps
        mod_nodes  =
          -- hs-boot edge
          [NodeKey
k | NodeKey
k <- [ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
IsBoot)  (Module -> UnitId
moduleUnitId Module
this_mod))], IsBootInterface
NotBoot IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> IsBootInterface
isBootSummary ModSummary
ms,  NodeKey
k NodeKey -> [NodeKey] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NodeKey]
home_keys ] [NodeKey] -> [NodeKey] -> [NodeKey]
forall a. [a] -> [a] -> [a]
++
          -- Normal edges
          [NodeKey
k | (PkgQual
_, GenWithIsBoot (Located ModuleName)
mnwib) <- ModSummary -> [(PkgQual, GenWithIsBoot (Located ModuleName))]
msDeps ModSummary
ms, let k :: NodeKey
k = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid ((Located ModuleName -> ModuleName)
-> GenWithIsBoot (Located ModuleName) -> ModuleNameWithIsBoot
forall a b. (a -> b) -> GenWithIsBoot a -> GenWithIsBoot b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenWithIsBoot (Located ModuleName)
mnwib) (Module -> UnitId
moduleUnitId Module
this_mod)), NodeKey
k NodeKey -> [NodeKey] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NodeKey]
home_keys]


    return (ModuleNode (mod_nodes ++ inst_nodes) ms)

-- | Create a new, externally provided hashed unit id from
-- a hash.
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])