{-# LANGUAGE CPP #-}
{-# 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

#include "HsVersions.h"

import GHC.Prelude

-- In a separate module because it hooks into the parser.
import GHC.Driver.Backpack.Syntax
import GHC.Driver.Config
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.Parser
import GHC.Parser.Header
import GHC.Parser.Lexer
import GHC.Parser.Annotation
import GHC.Parser.Errors.Ppr

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.SourceText
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.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.State
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

-- | Entry point to compile a Backpack file.
doBackpack :: [FilePath] -> Ghc ()
doBackpack :: [FilePath] -> Ghc ()
doBackpack [FilePath
src_filename] = do
    Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger

    -- Apply options from file to dflags
    DynFlags
dflags0 <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let dflags1 :: DynFlags
dflags1 = DynFlags
dflags0
    [Located FilePath]
src_opts <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO [Located FilePath]
getOptionsFromFile DynFlags
dflags1 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 (\HscEnv
hsc_env -> HscEnv
hsc_env {hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags})
    -- Cribbed from: preprocessFile / GHC.Driver.Pipeline
    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
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> [Warn] -> IO ()
handleFlagWarnings Logger
logger DynFlags
dflags [Warn]
warns
    -- TODO: Preprocessing not implemented

    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 -- TODO: not great
    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 => ErrorMessages -> io a
throwErrors (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError (PState -> Bag PsError
getErrorMessages 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.
            HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
            let bkp :: [LHsUnit HsComponentId]
bkp = UnitState
-> PackageNameMap HsComponentId
-> [LHsUnit PackageName]
-> [LHsUnit HsComponentId]
renameHsUnits (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 (IndefUnitId
cid, [(ModuleName, Module)]
insts) = LHsUnit HsComponentId -> (IndefUnitId, [(ModuleName, Module)])
computeUnitId LHsUnit HsComponentId
lunit
                        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, Module)]
insts
                            then if IndefUnitId
cid forall a. Eq a => a -> a -> Bool
== forall unit. unit -> Indefinite unit
Indefinite (FastString -> UnitId
UnitId (FilePath -> FastString
fsLit FilePath
"main"))
                                    then LHsUnit HsComponentId -> IOEnv BkpEnv ()
compileExe LHsUnit HsComponentId
lunit
                                    else IndefUnitId -> [(ModuleName, Module)] -> IOEnv BkpEnv ()
compileUnit IndefUnitId
cid []
                            else IndefUnitId -> [(ModuleName, Module)] -> IOEnv BkpEnv ()
typecheckUnit IndefUnitId
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 -> (IndefUnitId, [(ModuleName, Module)])
computeUnitId :: LHsUnit HsComponentId -> (IndefUnitId, [(ModuleName, Module)])
computeUnitId (L SrcSpan
_ HsUnit HsComponentId
unit) = (IndefUnitId
cid, [ (ModuleName
r, forall u. ModuleName -> GenModule (GenUnit u)
mkHoleModule ModuleName
r) | ModuleName
r <- [ModuleName]
reqs ])
  where
    cid :: IndefUnitId
cid = HsComponentId -> IndefUnitId
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) Maybe (Located HsModule)
_) = forall a. Uniquable a => a -> UniqDSet a
unitUniqDSet ModuleName
modname
    get_reqs (DeclD HscSource
HsSrcFile GenLocated SrcSpan ModuleName
_ Maybe (Located HsModule)
_) = forall a. UniqDSet a
emptyUniqDSet
    get_reqs (DeclD HscSource
HsBootFile GenLocated SrcSpan ModuleName
_ Maybe (Located HsModule)
_) = 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)

-- | 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
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)

-- | Create a temporary Session to do some sort of type checking or
-- compilation.
withBkpSession :: IndefUnitId
               -> [(ModuleName, Module)]
               -> [(Unit, ModRenaming)]
               -> SessionType   -- what kind of session are we doing
               -> BkpM a        -- actual action to run
               -> BkpM a
withBkpSession :: forall a.
IndefUnitId
-> [(ModuleName, Module)]
-> [(Unit, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
withBkpSession IndefUnitId
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 (forall unit. Indefinite unit -> unit
indefUnit IndefUnitId
cid)
        is_primary :: Bool
is_primary = Bool
False
        uid_str :: FilePath
uid_str = FastString -> FilePath
unpackFS (forall u.
IsUnitId u =>
Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> FastString
mkInstantiatedUnitHash IndefUnitId
cid [(ModuleName, Module)]
insts)
        cid_str :: FilePath
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) -> 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
                 -- Special case when package is definite
                 , 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 = HscEnv
hsc_env
            { hsc_dflags :: DynFlags
hsc_dflags   = UnitState -> DynFlags -> DynFlags
mk_temp_dflags (HscEnv -> UnitState
hsc_units HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_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
            , homeUnitInstantiations_ :: [(ModuleName, Module)]
homeUnitInstantiations_ = [(ModuleName, Module)]
insts
                                     -- if we don't have any instantiation, don't
                                     -- fill `homeUnitInstanceOfId` as it makes no
                                     -- sense (we're not instantiating anything)
            , 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 (forall unit. Indefinite unit -> unit
indefUnit IndefUnitId
cid)
            , homeUnitId_ :: UnitId
homeUnitId_ = case SessionType
session_type of
                SessionType
TcSession -> IndefUnitId -> Maybe FastString -> UnitId
newUnitId IndefUnitId
cid forall a. Maybe a
Nothing
                -- No hash passed if no instances
                SessionType
_ | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, Module)]
insts -> IndefUnitId -> Maybe FastString -> UnitId
newUnitId IndefUnitId
cid forall a. Maybe a
Nothing
                  | Bool
otherwise  -> IndefUnitId -> Maybe FastString -> UnitId
newUnitId IndefUnitId
cid (forall a. a -> Maybe a
Just (forall u.
IsUnitId u =>
Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> FastString
mkInstantiatedUnitHash IndefUnitId
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 :: EnumSet GeneralFlag
generalFlags = case SessionType
session_type of
                -- Make sure to write interfaces when we are type-checking
                -- indefinite packages.
                SessionType
TcSession
                  | DynFlags -> Backend
backend DynFlags
dflags forall a. Eq a => a -> a -> Bool
/= Backend
NoBackend
                  -> 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 :: 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)
            -- Unset output-file for non exe builds
            , 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
            -- Clear the import path so we don't accidentally grab anything
            , importPaths :: [FilePath]
importPaths = []
            -- Synthesize the flags
            , 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
                    (FilePath -> SDoc
text FilePath
"-unit-id" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Unit
uid SDoc -> SDoc -> SDoc
<+> 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
      -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
      forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags DynFlags
dflags -- calls initUnits
      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.
IndefUnitId
-> [(ModuleName, Module)]
-> [(Unit, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
withBkpSession (forall unit. unit -> Indefinite unit
Indefinite (FastString -> UnitId
UnitId (FilePath -> FastString
fsLit FilePath
"main"))) [] [(Unit, ModRenaming)]
deps SessionType
ExeSession BkpM a
do_this

getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId)
getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId)
getSource IndefUnitId
cid = do
    BkpEnv
bkp_env <- BkpM BkpEnv
getBkpEnv
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup IndefUnitId
cid (BkpEnv -> Map IndefUnitId (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 IndefUnitId
cid)
        Just LHsUnit HsComponentId
lunit -> forall (m :: * -> *) a. Monad m => a -> m a
return LHsUnit HsComponentId
lunit

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

compileUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM ()
compileUnit :: IndefUnitId -> [(ModuleName, Module)] -> IOEnv BkpEnv ()
compileUnit IndefUnitId
cid [(ModuleName, Module)]
insts = do
    -- Let everyone know we're building this unit
    Unit -> IOEnv BkpEnv ()
msgUnitId (forall u.
IsUnitId u =>
Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u
mkVirtUnit IndefUnitId
cid [(ModuleName, Module)]
insts)
    LHsUnit HsComponentId
lunit <- IndefUnitId -> BkpM (LHsUnit HsComponentId)
getSource IndefUnitId
cid
    SessionType
-> IndefUnitId
-> [(ModuleName, Module)]
-> LHsUnit HsComponentId
-> IOEnv BkpEnv ()
buildUnit SessionType
CompSession IndefUnitId
cid [(ModuleName, Module)]
insts LHsUnit HsComponentId
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 = 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 -> IndefUnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
buildUnit :: SessionType
-> IndefUnitId
-> [(ModuleName, Module)]
-> LHsUnit HsComponentId
-> IOEnv BkpEnv ()
buildUnit SessionType
session IndefUnitId
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 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
    -- The compilation dependencies are just the appropriately filled
    -- in unit IDs which must be compiled before we can compile.
    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 (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!!
    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)

    -- IMPROVE IT
    let deps :: [Unit]
deps = forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> Unit -> Unit
improveUnit (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
  IndefUnitId PackageId PackageName UnitId ModuleName Module
conf <- forall a.
IndefUnitId
-> [(ModuleName, Module)]
-> [(Unit, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
withBkpSession IndefUnitId
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 <- HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph (forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
lunit)

        Messager
msg <- BkpM Messager
mkBackpackMsg
        SuccessFlag
ok <- forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' 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. 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)
            -- Export everything!
            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 ]

        -- Compile relevant only
        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
hm_linkable)
                      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 UTCTime
_ Module
_ [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     = HscEnv -> UnitState
hsc_units HscEnv
hsc_env

        let compat_fs :: FastString
compat_fs = UnitId -> FastString
unitIdFS (forall unit. Indefinite unit -> unit
indefUnit IndefUnitId
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 {
            -- Stub data
            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 :: IndefUnitId
unitInstanceOf = IndefUnitId
cid,
            unitInstantiations :: [(ModuleName, Module)]
unitInstantiations = [(ModuleName, Module)]
insts,
            -- Slight inefficiency here haha
            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 = [], -- TODO: doc only
            unitDepends :: [UnitId]
unitDepends = case SessionType
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
_ -> 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,
            -- nope
            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
  IndefUnitId PackageId PackageName UnitId ModuleName Module
-> m ()
addUnit GenericUnitInfo
  IndefUnitId 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
        -- no renaming necessary
    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 <- HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph (forall l e. GenLocated l e -> e
unLoc LHsUnit HsComponentId
lunit)
        Messager
msg <- BkpM Messager
mkBackpackMsg
        SuccessFlag
ok <- forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' 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))

-- | Register a new virtual unit database containing a single unit
addUnit :: GhcMonad m => UnitInfo -> m ()
addUnit :: forall (m :: * -> *).
GhcMonad m =>
GenericUnitInfo
  IndefUnitId PackageId PackageName UnitId ModuleName Module
-> m ()
addUnit GenericUnitInfo
  IndefUnitId 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
    [UnitDatabase UnitId]
newdbs <- case HscEnv -> Maybe [UnitDatabase UnitId]
hsc_unit_dbs HscEnv
hsc_env of
        Maybe [UnitDatabase UnitId]
Nothing  -> forall a. 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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo
  IndefUnitId PackageId PackageName UnitId ModuleName Module
u)) forall a. [a] -> [a] -> [a]
++ FilePath
")"
               , unitDatabaseUnits :: [GenericUnitInfo
   IndefUnitId PackageId PackageName UnitId ModuleName Module]
unitDatabaseUnits = [GenericUnitInfo
  IndefUnitId 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]) -- added at the end because ordering matters
    ([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]
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags0 (forall a. a -> Maybe a
Just [UnitDatabase UnitId]
newdbs)

    -- update platform constants
    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 = UnitEnv
          { ue_platform :: Platform
ue_platform  = DynFlags -> Platform
targetPlatform DynFlags
dflags
          , ue_namever :: GhcNameVersion
ue_namever   = DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags
          , ue_home_unit :: HomeUnit
ue_home_unit = HomeUnit
home_unit
          , ue_units :: UnitState
ue_units     = UnitState
unit_state
          }
    forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env
        { hsc_unit_dbs :: Maybe [UnitDatabase UnitId]
hsc_unit_dbs = forall a. a -> Maybe a
Just [UnitDatabase UnitId]
dbs
        , hsc_dflags :: DynFlags
hsc_dflags   = DynFlags
dflags
        , 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 = HscEnv -> UnitState
hsc_units HscEnv
hsc_env
    (Int, Int) -> Unit -> IOEnv BkpEnv ()
msgInclude (Int
i, Int
n) Unit
uid
    -- Check if we've compiled it already
    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
        IndefUnitId PackageId PackageName UnitId ModuleName Module)
lookupUnit UnitState
pkgs Unit
uid of
        Maybe
  (GenericUnitInfo
     IndefUnitId PackageId PackageName UnitId ModuleName Module)
Nothing -> forall a. BkpM a -> BkpM a
innerBkpM forall a b. (a -> b) -> a -> b
$ IndefUnitId -> [(ModuleName, Module)] -> IOEnv BkpEnv ()
compileUnit (forall unit. GenInstantiatedUnit unit -> Indefinite unit
instUnitInstanceOf GenInstantiatedUnit UnitId
i) (forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit UnitId
i)
        Just GenericUnitInfo
  IndefUnitId PackageId PackageName UnitId ModuleName Module
_  -> 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 IndefUnitId (LHsUnit HsComponentId)
bkp_table :: Map IndefUnitId (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 :: 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

-- | Get the current 'BkpEnv'.
getBkpEnv :: BkpM BkpEnv
getBkpEnv :: BkpM BkpEnv
getBkpEnv = 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 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.
    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

-- | 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
    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' (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
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
    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. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
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 =
  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 IndefUnitId (LHsUnit HsComponentId)
bkp_table = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(HsComponentId -> IndefUnitId
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

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

-- | Print a compilation progress message, but with indentation according
-- to @level@ (for nested compilation).
backpackProgressMsg :: Int -> Logger -> DynFlags -> SDoc -> IO ()
backpackProgressMsg :: Int -> Logger -> DynFlags -> SDoc -> IO ()
backpackProgressMsg Int
level Logger
logger DynFlags
dflags SDoc
msg =
    Logger -> DynFlags -> SDoc -> IO ()
compilationProgressMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text (forall a. Int -> a -> [a]
replicate (Int
level forall a. Num a => a -> a -> a
* Int
2) Char
' ') -- TODO: use GHC.Utils.Ppr.RStr
                                      SDoc -> SDoc -> SDoc
<> 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
    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 = HscEnv -> UnitState
hsc_units HscEnv
hsc_env
          showMsg :: SDoc -> SDoc -> IO ()
showMsg SDoc
msg SDoc
reason =
            Int -> Logger -> DynFlags -> SDoc -> IO ()
backpackProgressMsg Int
level Logger
logger DynFlags
dflags 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 SDoc -> SDoc -> SDoc
<>
                SDoc
msg SDoc -> SDoc -> SDoc
<> DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp) ModuleGraphNode
node
                    SDoc -> SDoc -> SDoc
<> SDoc
reason
      in case ModuleGraphNode
node of
        InstantiationNode GenInstantiatedUnit UnitId
_ ->
          case RecompileRequired
recomp of
            RecompileRequired
MustCompile -> SDoc -> SDoc -> IO ()
showMsg (FilePath -> SDoc
text FilePath
"Instantiating ") SDoc
empty
            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 (FilePath -> SDoc
text FilePath
"Skipping  ") SDoc
empty
              | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            RecompBecause FilePath
reason -> SDoc -> SDoc -> IO ()
showMsg (FilePath -> SDoc
text FilePath
"Instantiating ") (FilePath -> SDoc
text FilePath
" [" SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
reason SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"]")
        ModuleNode ExtendedModSummary
_ ->
          case RecompileRequired
recomp of
            RecompileRequired
MustCompile -> SDoc -> SDoc -> IO ()
showMsg (FilePath -> SDoc
text FilePath
"Compiling ") SDoc
empty
            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 (FilePath -> SDoc
text FilePath
"Skipping  ") SDoc
empty
              | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            RecompBecause FilePath
reason -> SDoc -> SDoc -> IO ()
showMsg (FilePath -> SDoc
text FilePath
"Compiling ") (FilePath -> SDoc
text FilePath
" [" SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
reason SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"]")

-- | '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 =
    PrintUnqualified -> Depth -> PprStyle
mkUserStyle
        (QueryQualifyName
-> QueryQualifyModule -> QueryQualifyPackage -> PrintUnqualified
QueryQualify QueryQualifyName
neverQualifyNames
                      QueryQualifyModule
alwaysQualifyModules
                      QueryQualifyPackage
neverQualifyPackages) Depth
AllTheWay

-- | Message when we initially process a Backpack unit.
msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
msgTopPackage :: (Int, Int) -> HsComponentId -> IOEnv BkpEnv ()
msgTopPackage (Int
i,Int
n) (HsComponentId (PackageName FastString
fs_pn) IndefUnitId
_) = do
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    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 -> DynFlags -> SDoc -> IO ()
backpackProgressMsg Int
level Logger
logger DynFlags
dflags
        forall a b. (a -> b) -> a -> b
$ (Int, Int) -> SDoc
showModuleIndex (Int
i, Int
n) SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"Processing " SDoc -> SDoc -> SDoc
<> FastString -> SDoc
ftext FastString
fs_pn

-- | Message when we instantiate a Backpack unit.
msgUnitId :: Unit -> BkpM ()
msgUnitId :: Unit -> IOEnv BkpEnv ()
msgUnitId Unit
pk = do
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    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 = 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 -> DynFlags -> SDoc -> IO ()
backpackProgressMsg Int
level Logger
logger DynFlags
dflags
        forall a b. (a -> b) -> a -> b
$ UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state
        forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text FilePath
"Instantiating "
           SDoc -> SDoc -> SDoc
<> PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
backpackStyle (forall a. Outputable a => a -> SDoc
ppr Unit
pk)

-- | Message when we include a Backpack unit.
msgInclude :: (Int,Int) -> Unit -> BkpM ()
msgInclude :: (Int, Int) -> Unit -> IOEnv BkpEnv ()
msgInclude (Int
i,Int
n) Unit
uid = do
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    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 = 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 -> DynFlags -> SDoc -> IO ()
backpackProgressMsg Int
level Logger
logger DynFlags
dflags
        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) SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"Including "
            SDoc -> SDoc -> SDoc
<> PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
backpackStyle (forall a. Outputable a => a -> SDoc
ppr Unit
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 -> IndefUnitId -> HsComponentId
HsComponentId PackageName
pn (forall unit. unit -> Indefinite unit
Indefinite (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 IndefUnitId
lookupPackageName UnitState
pkgstate PackageName
pn of
                    Maybe IndefUnitId
Nothing -> forall a. HasCallStack => FilePath -> a
error FilePath
"no package name"
                    Just IndefUnitId
cid -> PackageName -> IndefUnitId -> HsComponentId
HsComponentId PackageName
pn IndefUnitId
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 Maybe (Located HsModule)
c) = forall n.
HscSource
-> GenLocated SrcSpan ModuleName
-> Maybe (Located HsModule)
-> HsUnitDecl n
DeclD HscSource
a GenLocated SrcSpan ModuleName
b Maybe (Located HsModule)
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 =>
Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u
mkVirtUnit (HsComponentId -> IndefUnitId
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



{-
************************************************************************
*                                                                      *
                        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 :: HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph 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

    --  1. Create a HsSrcFile/HsigFile summary for every
    --  explicitly mentioned module/signature.
    let get_decl :: GenLocated SrcSpan (HsUnitDecl HsComponentId)
-> IOEnv BkpEnv (Maybe ExtendedModSummary)
get_decl (L SrcSpan
_ (DeclD HscSource
hsc_src GenLocated SrcSpan ModuleName
lmodname Maybe (Located HsModule)
mb_hsmod)) =
          forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` PackageName
-> HscSource
-> GenLocated SrcSpan ModuleName
-> Maybe (Located HsModule)
-> BkpM ExtendedModSummary
summariseDecl PackageName
pn HscSource
hsc_src GenLocated SrcSpan ModuleName
lmodname Maybe (Located HsModule)
mb_hsmod
        get_decl GenLocated SrcSpan (HsUnitDecl HsComponentId)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    [ExtendedModSummary]
nodes <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan (HsUnitDecl HsComponentId)
-> IOEnv BkpEnv (Maybe ExtendedModSummary)
get_decl [GenLocated SrcSpan (HsUnitDecl HsComponentId)]
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 :: Set ModuleName
hsig_set = forall a. Ord a => [a] -> Set a
Set.fromList
          [ ModSummary -> ModuleName
ms_mod_name ModSummary
ms
          | ExtendedModSummary { emsModSummary :: ExtendedModSummary -> ModSummary
emsModSummary = ModSummary
ms } <- [ExtendedModSummary]
nodes
          , ModSummary -> HscSource
ms_hsc_src ModSummary
ms forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
          ]
    [ExtendedModSummary]
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 b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ExtendedModSummary
extendModSummaryNoDeps) forall a b. (a -> b) -> a -> b
$ PackageName -> ModuleName -> BkpM ModSummary
summariseRequirement PackageName
pn ModuleName
mod_name
            -- Using extendModSummaryNoDeps here is okay because we're making a leaf node
            -- representing a signature that can't depend on any other unit.

    -- 3. Return the kaboodle
    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
$
      (ExtendedModSummary -> ModuleGraphNode
ModuleNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ExtendedModSummary]
nodes forall a. [a] -> [a] -> [a]
++ [ExtendedModSummary]
req_nodes)) forall a. [a] -> [a] -> [a]
++ UnitState -> [ModuleGraphNode]
instantiationNodes (HscEnv -> UnitState
hsc_units HscEnv
hsc_env)

summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
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 PackageName FastString
pn_fs = PackageName
pn
    ModLocation
location <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> FilePath -> FilePath -> IO ModLocation
mkHomeModLocation2 DynFlags
dflags 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
    UTCTime
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationUTCTime (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)

    Module
mod <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env ModuleName
mod_name ModLocation
location

    [(Maybe FastString, GenLocated SrcSpan 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 [(Maybe FastString, GenLocated SrcSpan ModuleName)]
findExtraSigImports HscEnv
hsc_env HscSource
HsigFile ModuleName
mod_name

    forall (m :: * -> *) a. Monad m => a -> m a
return 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_date :: UTCTime
ms_hs_date = UTCTime
time,
        ms_obj_date :: Maybe UTCTime
ms_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 :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_srcimps = [],
        ms_textual_imps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_textual_imps = [(Maybe FastString, GenLocated SrcSpan ModuleName)]
extra_sig_imports,
        ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = forall a. a -> Maybe a
Just (HsParsedModule {
                hpm_module :: Located HsModule
hpm_module = forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsModule {
                        hsmodAnn :: EpAnn AnnsModule
hsmodAnn = forall a. EpAnn a
noAnn,
                        hsmodLayout :: LayoutInfo
hsmodLayout = LayoutInfo
NoLayoutInfo,
                        hsmodName :: Maybe (GenLocated (SrcAnn AnnListItem) 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 (LocatedL [LIE GhcPs])
hsmodExports = forall a. Maybe a
Nothing,
                        hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [],
                        hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = [],
                        hsmodDeprecMessage :: Maybe (LocatedP WarningTxt)
hsmodDeprecMessage = forall a. Maybe a
Nothing,
                        hsmodHaddockModHeader :: Maybe LHsDocString
hsmodHaddockModHeader = forall a. Maybe a
Nothing
                    }),
                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 = forall a. Maybe a
Nothing
        }

summariseDecl :: PackageName
              -> HscSource
              -> Located ModuleName
              -> Maybe (Located HsModule)
              -> BkpM ExtendedModSummary
summariseDecl :: PackageName
-> HscSource
-> GenLocated SrcSpan ModuleName
-> Maybe (Located HsModule)
-> BkpM ExtendedModSummary
summariseDecl PackageName
pn HscSource
hsc_src (L SrcSpan
_ ModuleName
modname) (Just Located HsModule
hsmod) = PackageName
-> HscSource
-> ModuleName
-> Located HsModule
-> BkpM ExtendedModSummary
hsModuleToModSummary PackageName
pn HscSource
hsc_src ModuleName
modname Located HsModule
hsmod
summariseDecl PackageName
_pn HscSource
hsc_src lmodname :: GenLocated SrcSpan ModuleName
lmodname@(L SrcSpan
loc ModuleName
modname) Maybe (Located HsModule)
Nothing
    = do HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
         -- TODO: this looks for modules in the wrong place
         Maybe (Either ErrorMessages ExtendedModSummary)
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModNodeMap ExtendedModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
summariseModule HscEnv
hsc_env
                         forall a. ModNodeMap a
emptyModNodeMap -- GHC API recomp not supported
                         (HscSource -> IsBootInterface
hscSourceToIsBoot HscSource
hsc_src)
                         GenLocated SrcSpan ModuleName
lmodname
                         Bool
True -- Target lets you disallow, but not here
                         forall a. Maybe a
Nothing -- GHC API buffer support not supported
                         [] -- No exclusions
         case Maybe (Either ErrorMessages ExtendedModSummary)
r of
            Maybe (Either ErrorMessages ExtendedModSummary)
Nothing -> forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope DecoratedSDoc -> io a
throwOneError (SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc (FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
modname SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"was not found"))
            Just (Left ErrorMessages
err) -> forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
err
            Just (Right ExtendedModSummary
summary) -> forall (m :: * -> *) a. Monad m => a -> m a
return ExtendedModSummary
summary

-- | 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 :: PackageName
                     -> HscSource
                     -> ModuleName
                     -> Located HsModule
                     -> BkpM ExtendedModSummary
hsModuleToModSummary :: PackageName
-> HscSource
-> ModuleName
-> Located HsModule
-> BkpM ExtendedModSummary
hsModuleToModSummary PackageName
pn HscSource
hsc_src ModuleName
modname
                     Located HsModule
hsmod = do
    let imps :: [LImportDecl GhcPs]
imps = HsModule -> [LImportDecl GhcPs]
hsmodImports (forall l e. GenLocated l e -> e
unLoc Located HsModule
hsmod)
        loc :: SrcSpan
loc  = forall l e. GenLocated l e -> l
getLoc Located HsModule
hsmod
    HscEnv
hsc_env <- 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 FastString
unit_fs = PackageName
pn
        dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    -- 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!
    ModLocation
location0 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> FilePath -> FilePath -> IO ModLocation
mkHomeModLocation2 DynFlags
dflags 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 :: ModLocation
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
    BkpEnv
env <- BkpM BkpEnv
getBkpEnv
    UTCTime
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationUTCTime (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)

    -- Also copied from 'getImports'
    let ([GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
src_idecls, [GenLocated (SrcAnn AnnListItem) (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

             -- GHC.Prim doesn't exist physically, so don't go looking for it.
        ordinary_imps :: [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
ordinary_imps = forall a. (a -> Bool) -> [a] -> [a]
filter ((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 (SrcAnn AnnListItem) (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
        convImport :: GenLocated l (ImportDecl pass)
-> (Maybe FastString, GenLocated SrcSpan ModuleName)
convImport (L l
_ ImportDecl pass
i) = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StringLiteral -> FastString
sl_fs (forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl pass
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 pass
i)

    [(Maybe FastString, GenLocated SrcSpan 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 [(Maybe FastString, GenLocated SrcSpan ModuleName)]
findExtraSigImports HscEnv
hsc_env HscSource
hsc_src ModuleName
modname

    let normal_imports :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
normal_imports = forall a b. (a -> b) -> [a] -> [b]
map forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (Maybe FastString, GenLocated SrcSpan ModuleName)
convImport ([LImportDecl GhcPs]
implicit_imports forall a. [a] -> [a] -> [a]
++ [GenLocated (SrcAnn AnnListItem) (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
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> IO ([ModuleName], [GenInstantiatedUnit UnitId])
implicitRequirementsShallow HscEnv
hsc_env [(Maybe FastString, GenLocated SrcSpan ModuleName)]
normal_imports

    -- So that Finder can find it, even though it doesn't exist...
    Module
this_mod <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env ModuleName
modname ModLocation
location
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExtendedModSummary
      { emsModSummary :: ModSummary
emsModSummary =
          ModSummary {
            ms_mod :: Module
ms_mod = Module
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 :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_srcimps = forall a b. (a -> b) -> [a] -> [b]
map forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (Maybe FastString, GenLocated SrcSpan ModuleName)
convImport [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
src_idecls,
            ms_textual_imps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_textual_imps = [(Maybe FastString, GenLocated SrcSpan ModuleName)]
normal_imports
                           -- We have to do something special here:
                           -- due to merging, requirements may end up with
                           -- extra imports
                           forall a. [a] -> [a] -> [a]
++ [(Maybe FastString, GenLocated SrcSpan ModuleName)]
extra_sig_imports
                           forall a. [a] -> [a] -> [a]
++ ((,) forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Located e
noLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
implicit_sigs),
            -- This is our hack to get the parse tree to the right spot
            ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = forall a. a -> Maybe a
Just (HsParsedModule {
                    hpm_module :: Located HsModule
hpm_module = Located HsModule
hsmod,
                    hpm_src_files :: [FilePath]
hpm_src_files = [] -- TODO if we preprocessed it
                }),
            ms_hs_date :: UTCTime
ms_hs_date = UTCTime
time,
            ms_obj_date :: Maybe UTCTime
ms_obj_date = 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
          }
      , emsInstantiatedUnits :: [GenInstantiatedUnit UnitId]
emsInstantiatedUnits = [GenInstantiatedUnit UnitId]
inst_deps
      }

-- | Create a new, externally provided hashed unit id from
-- a hash.
newUnitId :: IndefUnitId -> Maybe FastString -> UnitId
newUnitId :: IndefUnitId -> Maybe FastString -> UnitId
newUnitId IndefUnitId
uid Maybe FastString
mhash = case Maybe FastString
mhash of
   Maybe FastString
Nothing   -> forall unit. Indefinite unit -> unit
indefUnit IndefUnitId
uid
   Just FastString
hash -> FastString -> UnitId
UnitId (UnitId -> FastString
unitIdFS (forall unit. Indefinite unit -> unit
indefUnit IndefUnitId
uid) FastString -> FastString -> FastString
`appendFS` FilePath -> FastString
mkFastString FilePath
"+" FastString -> FastString -> FastString
`appendFS` FastString
hash)