{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}

-- | 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 DriverBkp (doBackpack) where

#include "HsVersions.h"

import GhcPrelude

-- In a separate module because it hooks into the parser.
import BkpSyn

import GHC hiding (Failed, Succeeded)
import Packages
import Parser
import Lexer
import GhcMonad
import DynFlags
import TcRnMonad
import TcRnDriver
import Module
import HscTypes
import StringBuffer
import FastString
import ErrUtils
import SrcLoc
import HscMain
import UniqFM
import UniqDFM
import Outputable
import Maybes
import HeaderInfo
import MkIface
import GhcMake
import UniqDSet
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import Finder
import Util

import qualified GHC.LanguageExtensions as LangExt

import Panic
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

-- | Entry point to compile a Backpack file.
doBackpack :: [FilePath] -> Ghc ()
doBackpack :: [FilePath] -> Ghc ()
doBackpack [FilePath
src_filename] = do
    -- Apply options from file to dflags
    DynFlags
dflags0 <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let dflags1 :: DynFlags
dflags1 = DynFlags
dflags0
    [Located FilePath]
src_opts <- IO [Located FilePath] -> Ghc [Located FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Located FilePath] -> Ghc [Located FilePath])
-> IO [Located FilePath] -> Ghc [Located FilePath]
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) <- IO (DynFlags, [Located FilePath], [Warn])
-> Ghc (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located FilePath], [Warn])
 -> Ghc (DynFlags, [Located FilePath], [Warn]))
-> IO (DynFlags, [Located FilePath], [Warn])
-> Ghc (DynFlags, [Located FilePath], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located FilePath] -> IO (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFilePragma DynFlags
dflags1 [Located FilePath]
src_opts
    (HscEnv -> HscEnv) -> Ghc ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\HscEnv
hsc_env -> HscEnv
hsc_env {hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags})
    -- Cribbed from: preprocessFile / DriverPipeline
    IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Located FilePath] -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> [Located FilePath] -> m ()
checkProcessArgsResult DynFlags
dflags [Located FilePath]
unhandled_flags
    IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
dflags [Warn]
warns
    -- TODO: Preprocessing not implemented

    StringBuffer
buf <- IO StringBuffer -> Ghc StringBuffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StringBuffer -> Ghc StringBuffer)
-> IO StringBuffer -> Ghc StringBuffer
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 P [LHsUnit PackageName]
-> PState -> ParseResult [LHsUnit PackageName]
forall a. P a -> PState -> ParseResult a
unP P [LHsUnit PackageName]
parseBackpack (DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState DynFlags
dflags StringBuffer
buf RealSrcLoc
loc) of
        PFailed PState
pst -> ErrorMessages -> Ghc ()
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors (PState -> DynFlags -> ErrorMessages
getErrorMessages PState
pst DynFlags
dflags)
        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.
            let bkp :: [LHsUnit HsComponentId]
bkp = DynFlags
-> PackageNameMap HsComponentId
-> [LHsUnit PackageName]
-> [LHsUnit HsComponentId]
renameHsUnits DynFlags
dflags ([LHsUnit PackageName] -> PackageNameMap HsComponentId
packageNameMap [LHsUnit PackageName]
pkgname_bkp) [LHsUnit PackageName]
pkgname_bkp
            FilePath -> [LHsUnit HsComponentId] -> BkpM () -> Ghc ()
forall a. FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
initBkpM FilePath
src_filename [LHsUnit HsComponentId]
bkp (BkpM () -> Ghc ()) -> BkpM () -> Ghc ()
forall a b. (a -> b) -> a -> b
$
                [(Int, LHsUnit HsComponentId)]
-> ((Int, LHsUnit HsComponentId) -> BkpM ()) -> BkpM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [LHsUnit HsComponentId] -> [(Int, LHsUnit HsComponentId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [LHsUnit HsComponentId]
bkp) (((Int, LHsUnit HsComponentId) -> BkpM ()) -> BkpM ())
-> ((Int, LHsUnit HsComponentId) -> BkpM ()) -> BkpM ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, LHsUnit HsComponentId
lunit) -> do
                    let comp_name :: SrcSpanLess (Located HsComponentId)
comp_name = Located HsComponentId -> SrcSpanLess (Located HsComponentId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (HsUnit HsComponentId -> Located HsComponentId
forall n. HsUnit n -> Located n
hsunitName (LHsUnit HsComponentId -> SrcSpanLess (LHsUnit HsComponentId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsUnit HsComponentId
lunit))
                    (Int, Int) -> HsComponentId -> BkpM ()
msgTopPackage (Int
i,[LHsUnit HsComponentId] -> 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 (ComponentId
cid, [(ModuleName, Module)]
insts) = LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)])
computeUnitId LHsUnit HsComponentId
lunit
                        if [(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, Module)]
insts
                            then if ComponentId
cid ComponentId -> ComponentId -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> ComponentId
ComponentId (FilePath -> FastString
fsLit FilePath
"main")
                                    then LHsUnit HsComponentId -> BkpM ()
compileExe LHsUnit HsComponentId
lunit
                                    else ComponentId -> [(ModuleName, Module)] -> BkpM ()
compileUnit ComponentId
cid []
                            else ComponentId -> [(ModuleName, Module)] -> BkpM ()
typecheckUnit ComponentId
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 -> (ComponentId, [(ModuleName, Module)])
computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)])
computeUnitId (L SrcSpan
_ HsUnit HsComponentId
unit) = (ComponentId
cid, [ (ModuleName
r, ModuleName -> Module
mkHoleModule ModuleName
r) | ModuleName
r <- [ModuleName]
reqs ])
  where
    cid :: ComponentId
cid = HsComponentId -> ComponentId
hsComponentId (Located HsComponentId -> SrcSpanLess (Located HsComponentId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (HsUnit HsComponentId -> Located 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 ((LHsUnitDecl HsComponentId -> UniqDSet ModuleName)
-> [LHsUnitDecl HsComponentId] -> [UniqDSet ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (HsUnitDecl HsComponentId -> UniqDSet ModuleName
get_reqs (HsUnitDecl HsComponentId -> UniqDSet ModuleName)
-> (LHsUnitDecl HsComponentId -> HsUnitDecl HsComponentId)
-> LHsUnitDecl HsComponentId
-> UniqDSet ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsUnitDecl HsComponentId -> HsUnitDecl HsComponentId
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) (HsUnit HsComponentId -> [LHsUnitDecl HsComponentId]
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 GhcPs))
_) = ModuleName -> UniqDSet ModuleName
forall a. Uniquable a => a -> UniqDSet a
unitUniqDSet ModuleName
modname
    get_reqs (DeclD HscSource
HsSrcFile GenLocated SrcSpan ModuleName
_ Maybe (Located (HsModule GhcPs))
_) = UniqDSet ModuleName
forall a. UniqDSet a
emptyUniqDSet
    get_reqs (DeclD HscSource
HsBootFile GenLocated SrcSpan ModuleName
_ Maybe (Located (HsModule GhcPs))
_) = UniqDSet ModuleName
forall a. UniqDSet a
emptyUniqDSet
    get_reqs (IncludeD (IncludeDecl (L SrcSpan
_ HsUnitId HsComponentId
hsuid) Maybe [LRenaming]
_ Bool
_)) =
        UnitId -> UniqDSet ModuleName
unitIdFreeHoles (HsUnitId HsComponentId -> UnitId
convertHsUnitId 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
/= :: 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 :: ComponentId
               -> [(ModuleName, Module)]
               -> [(UnitId, ModRenaming)]
               -> SessionType   -- what kind of session are we doing
               -> BkpM a        -- actual action to run
               -> BkpM a
withBkpSession :: ComponentId
-> [(ModuleName, Module)]
-> [(UnitId, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
withBkpSession ComponentId
cid [(ModuleName, Module)]
insts [(UnitId, ModRenaming)]
deps SessionType
session_type BkpM a
do_this = do
    DynFlags
dflags <- IOEnv BkpEnv DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let (ComponentId FastString
cid_fs) = ComponentId
cid
        is_primary :: Bool
is_primary = Bool
False
        uid_str :: FilePath
uid_str = FastString -> FilePath
unpackFS (ComponentId -> [(ModuleName, Module)] -> FastString
hashUnitId ComponentId
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 ([(ModuleName, Module)] -> 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)
    (HscEnv -> HscEnv) -> BkpM a -> BkpM a
forall (m :: * -> *) a.
GhcMonad m =>
(HscEnv -> HscEnv) -> m a -> m a
withTempSession ((DynFlags -> DynFlags) -> HscEnv -> HscEnv
overHscDynFlags (\DynFlags
dflags ->
      -- 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]
      (case SessionType
session_type of
        -- Make sure to write interfaces when we are type-checking
        -- indefinite packages.
        SessionType
TcSession | DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
/= HscTarget
HscNothing
                  -> (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_set GeneralFlag
Opt_WriteInterface
                  | Bool
otherwise -> DynFlags -> DynFlags
forall a. a -> a
id
        SessionType
CompSession -> DynFlags -> DynFlags
forall a. a -> a
id
        SessionType
ExeSession -> DynFlags -> DynFlags
forall a. a -> a
id) (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
      DynFlags
dflags {
        hscTarget :: HscTarget
hscTarget   = case SessionType
session_type of
                        SessionType
TcSession -> HscTarget
HscNothing
                        SessionType
_ -> DynFlags -> HscTarget
hscTarget DynFlags
dflags,
        thisUnitIdInsts_ :: Maybe [(ModuleName, Module)]
thisUnitIdInsts_ = [(ModuleName, Module)] -> Maybe [(ModuleName, Module)]
forall a. a -> Maybe a
Just [(ModuleName, Module)]
insts,
        thisComponentId_ :: Maybe ComponentId
thisComponentId_ = ComponentId -> Maybe ComponentId
forall a. a -> Maybe a
Just ComponentId
cid,
        thisInstalledUnitId :: InstalledUnitId
thisInstalledUnitId =
            case SessionType
session_type of
                SessionType
TcSession -> ComponentId -> Maybe FastString -> InstalledUnitId
newInstalledUnitId ComponentId
cid Maybe FastString
forall a. Maybe a
Nothing
                -- No hash passed if no instances
                SessionType
_ | [(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, Module)]
insts -> ComponentId -> Maybe FastString -> InstalledUnitId
newInstalledUnitId ComponentId
cid Maybe FastString
forall a. Maybe a
Nothing
                  | Bool
otherwise  -> ComponentId -> Maybe FastString -> InstalledUnitId
newInstalledUnitId ComponentId
cid (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (ComponentId -> [(ModuleName, Module)] -> FastString
hashUnitId ComponentId
cid [(ModuleName, Module)]
insts)),
        -- Setup all of the output directories according to our hierarchy
        objectDir :: Maybe FilePath
objectDir   = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just ((DynFlags -> Maybe FilePath) -> FilePath
outdir DynFlags -> Maybe FilePath
objectDir),
        hiDir :: Maybe FilePath
hiDir       = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just ((DynFlags -> Maybe FilePath) -> FilePath
outdir DynFlags -> Maybe FilePath
hiDir),
        stubDir :: Maybe FilePath
stubDir     = FilePath -> Maybe FilePath
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  = if SessionType
session_type SessionType -> SessionType -> Bool
forall a. Eq a => a -> a -> Bool
== SessionType
ExeSession
                        then DynFlags -> Maybe FilePath
outputFile DynFlags
dflags
                        else Maybe FilePath
forall a. Maybe a
Nothing,
        -- Clear the import path so we don't accidentally grab anything
        importPaths :: [FilePath]
importPaths = [],
        -- Synthesized the flags
        packageFlags :: [PackageFlag]
packageFlags = DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags [PackageFlag] -> [PackageFlag] -> [PackageFlag]
forall a. [a] -> [a] -> [a]
++ ((UnitId, ModRenaming) -> PackageFlag)
-> [(UnitId, ModRenaming)] -> [PackageFlag]
forall a b. (a -> b) -> [a] -> [b]
map (\(UnitId
uid0, ModRenaming
rn) ->
          let uid :: UnitId
uid = DynFlags -> UnitId -> UnitId
unwireUnitId DynFlags
dflags (PackageConfigMap -> UnitId -> UnitId
improveUnitId (DynFlags -> PackageConfigMap
getPackageConfigMap DynFlags
dflags) (UnitId -> UnitId) -> UnitId -> UnitId
forall a b. (a -> b) -> a -> b
$ DynFlags -> ShHoleSubst -> UnitId -> UnitId
renameHoleUnitId DynFlags
dflags ([(ModuleName, Module)] -> ShHoleSubst
forall key elt. Uniquable key => [(key, elt)] -> UniqFM elt
listToUFM [(ModuleName, Module)]
insts) UnitId
uid0)
          in FilePath -> PackageArg -> ModRenaming -> PackageFlag
ExposePackage
            (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags
                (FilePath -> SDoc
text FilePath
"-unit-id" SDoc -> SDoc -> SDoc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid SDoc -> SDoc -> SDoc
<+> ModRenaming -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModRenaming
rn))
            (UnitId -> PackageArg
UnitIdArg UnitId
uid) ModRenaming
rn) [(UnitId, ModRenaming)]
deps
      } )) (BkpM a -> BkpM a) -> BkpM a -> BkpM a
forall a b. (a -> b) -> a -> b
$ do
        DynFlags
dflags <- IOEnv BkpEnv DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
        -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
        -- Calls initPackages
        [InstalledUnitId]
_ <- DynFlags -> IOEnv BkpEnv [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
dflags
        BkpM a
do_this

withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession [(UnitId, ModRenaming)]
deps BkpM a
do_this = do
    ComponentId
-> [(ModuleName, Module)]
-> [(UnitId, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
forall a.
ComponentId
-> [(ModuleName, Module)]
-> [(UnitId, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
withBkpSession (FastString -> ComponentId
ComponentId (FilePath -> FastString
fsLit FilePath
"main")) [] [(UnitId, ModRenaming)]
deps SessionType
ExeSession BkpM a
do_this

getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
getSource ComponentId
cid = do
    BkpEnv
bkp_env <- BkpM BkpEnv
getBkpEnv
    case ComponentId
-> Map ComponentId (LHsUnit HsComponentId)
-> Maybe (LHsUnit HsComponentId)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ComponentId
cid (BkpEnv -> Map ComponentId (LHsUnit HsComponentId)
bkp_table BkpEnv
bkp_env) of
        Maybe (LHsUnit HsComponentId)
Nothing -> FilePath -> SDoc -> BkpM (LHsUnit HsComponentId)
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"missing needed dependency" (ComponentId -> SDoc
forall a. Outputable a => a -> SDoc
ppr ComponentId
cid)
        Just LHsUnit HsComponentId
lunit -> LHsUnit HsComponentId -> BkpM (LHsUnit HsComponentId)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsUnit HsComponentId
lunit

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

compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
compileUnit ComponentId
cid [(ModuleName, Module)]
insts = do
    -- Let everyone know we're building this unit ID
    UnitId -> BkpM ()
msgUnitId (ComponentId -> [(ModuleName, Module)] -> UnitId
newUnitId ComponentId
cid [(ModuleName, Module)]
insts)
    LHsUnit HsComponentId
lunit <- ComponentId -> BkpM (LHsUnit HsComponentId)
getSource ComponentId
cid
    SessionType
-> ComponentId
-> [(ModuleName, Module)]
-> LHsUnit HsComponentId
-> BkpM ()
buildUnit SessionType
CompSession ComponentId
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 'UnitId' 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 InstalledUnitId.
hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
hsunitDeps :: Bool -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
hsunitDeps Bool
include_sigs HsUnit HsComponentId
unit = (LHsUnitDecl HsComponentId -> [(UnitId, ModRenaming)])
-> [LHsUnitDecl HsComponentId] -> [(UnitId, ModRenaming)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsUnitDecl HsComponentId -> [(UnitId, ModRenaming)]
forall l.
GenLocated l (HsUnitDecl HsComponentId) -> [(UnitId, ModRenaming)]
get_dep (HsUnit HsComponentId -> [LHsUnitDecl HsComponentId]
forall n. HsUnit n -> [LHsUnitDecl n]
hsunitBody HsUnit HsComponentId
unit)
  where
    get_dep :: GenLocated l (HsUnitDecl HsComponentId) -> [(UnitId, ModRenaming)]
get_dep (L l
_ (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 -> UnitId
convertHsUnitId 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 (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 l (HsUnitDecl HsComponentId)
_ = []

buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
buildUnit :: SessionType
-> ComponentId
-> [(ModuleName, Module)]
-> LHsUnit HsComponentId
-> BkpM ()
buildUnit SessionType
session ComponentId
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 :: [(UnitId, ModRenaming)]
deps_w_rns = Bool -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
hsunitDeps (SessionType
session SessionType -> SessionType -> Bool
forall a. Eq a => a -> a -> Bool
== SessionType
TcSession) (LHsUnit HsComponentId -> SrcSpanLess (LHsUnit HsComponentId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsUnit HsComponentId
lunit)
        raw_deps :: [UnitId]
raw_deps = ((UnitId, ModRenaming) -> UnitId)
-> [(UnitId, ModRenaming)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, ModRenaming) -> UnitId
forall a b. (a, b) -> a
fst [(UnitId, ModRenaming)]
deps_w_rns
    DynFlags
dflags <- IOEnv BkpEnv DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    -- The compilation dependencies are just the appropriately filled
    -- in unit IDs which must be compiled before we can compile.
    let hsubst :: ShHoleSubst
hsubst = [(ModuleName, Module)] -> ShHoleSubst
forall key elt. Uniquable key => [(key, elt)] -> UniqFM elt
listToUFM [(ModuleName, Module)]
insts
        deps0 :: [UnitId]
deps0 = (UnitId -> UnitId) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ShHoleSubst -> UnitId -> UnitId
renameHoleUnitId DynFlags
dflags ShHoleSubst
hsubst) [UnitId]
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 GhcMake!!
    [(Int, UnitId)] -> ((Int, UnitId) -> BkpM ()) -> BkpM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [UnitId] -> [(Int, UnitId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [UnitId]
deps0) (((Int, UnitId) -> BkpM ()) -> BkpM ())
-> ((Int, UnitId) -> BkpM ()) -> BkpM ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, UnitId
dep) ->
        case SessionType
session of
            SessionType
TcSession -> () -> BkpM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            SessionType
_ -> Int -> (Int, UnitId) -> BkpM ()
compileInclude ([UnitId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UnitId]
deps0) (Int
i, UnitId
dep)

    DynFlags
dflags <- IOEnv BkpEnv DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    -- IMPROVE IT
    let deps :: [UnitId]
deps = (UnitId -> UnitId) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (PackageConfigMap -> UnitId -> UnitId
improveUnitId (DynFlags -> PackageConfigMap
getPackageConfigMap DynFlags
dflags)) [UnitId]
deps0

    Maybe ExternalPackageState
mb_old_eps <- case SessionType
session of
                    SessionType
TcSession -> (ExternalPackageState -> Maybe ExternalPackageState)
-> IOEnv BkpEnv ExternalPackageState
-> IOEnv BkpEnv (Maybe ExternalPackageState)
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe ExternalPackageState
forall a. Maybe a
Nothing

    InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
conf <- ComponentId
-> [(ModuleName, Module)]
-> [(UnitId, ModRenaming)]
-> SessionType
-> BkpM
     (InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module)
-> BkpM
     (InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module)
forall a.
ComponentId
-> [(ModuleName, Module)]
-> [(UnitId, ModRenaming)]
-> SessionType
-> BkpM a
-> BkpM a
withBkpSession ComponentId
cid [(ModuleName, Module)]
insts [(UnitId, ModRenaming)]
deps_w_rns SessionType
session (BkpM
   (InstalledPackageInfo
      ComponentId
      SourcePackageId
      PackageName
      InstalledUnitId
      UnitId
      ModuleName
      Module)
 -> BkpM
      (InstalledPackageInfo
         ComponentId
         SourcePackageId
         PackageName
         InstalledUnitId
         UnitId
         ModuleName
         Module))
-> BkpM
     (InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module)
-> BkpM
     (InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module)
forall a b. (a -> b) -> a -> b
$ do

        DynFlags
dflags <- IOEnv BkpEnv DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ModuleGraph
mod_graph <- DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph DynFlags
dflags (LHsUnit HsComponentId -> SrcSpanLess (LHsUnit HsComponentId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsUnit HsComponentId
lunit)
        -- pprTrace "mod_graph" (ppr mod_graph) $ return ()

        Messager
msg <- BkpM Messager
mkBackpackMsg
        SuccessFlag
ok <- LoadHowMuch
-> Maybe Messager -> ModuleGraph -> IOEnv BkpEnv SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
LoadAllTargets (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
msg) ModuleGraph
mod_graph
        Bool -> BkpM () -> BkpM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SuccessFlag -> Bool
failed SuccessFlag
ok) (IO () -> BkpM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BkpM ()) -> IO () -> BkpM ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1))

        let hi_dir :: FilePath
hi_dir = FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust (FilePath -> FilePath
forall a. 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 -> (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 HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile ]

        -- Compile relevant only
        HscEnv
hsc_env <- IOEnv BkpEnv HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
        let home_mod_infos :: [HomeModInfo]
home_mod_infos = UniqDFM HomeModInfo -> [HomeModInfo]
forall elt. UniqDFM elt -> [elt]
eltsUDFM (HscEnv -> UniqDFM HomeModInfo
hsc_HPT HscEnv
hsc_env)
            linkables :: [Linkable]
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
hm_linkable)
                      ([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 :: Linkable -> [FilePath]
getOfiles (LM UTCTime
_ Module
_ [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 :: [FilePath]
obj_files = (Linkable -> [FilePath]) -> [Linkable] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Linkable -> [FilePath]
getOfiles [Linkable]
linkables

        let compat_fs :: FastString
compat_fs = (case ComponentId
cid of ComponentId FastString
fs -> FastString
fs)
            compat_pn :: PackageName
compat_pn = FastString -> PackageName
PackageName FastString
compat_fs

        InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> BkpM
     (InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module)
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageInfo :: forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
instunitid
-> compid
-> [(modulename, mod)]
-> srcpkgid
-> srcpkgname
-> Version
-> Maybe srcpkgname
-> FilePath
-> [instunitid]
-> [(instunitid, FilePath)]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> [(modulename, Maybe mod)]
-> [modulename]
-> Bool
-> Bool
-> Bool
-> InstalledPackageInfo
     compid srcpkgid srcpkgname instunitid unitid modulename mod
InstalledPackageInfo {
            -- Stub data
            abiHash :: FilePath
abiHash = FilePath
"",
            sourcePackageId :: SourcePackageId
sourcePackageId = FastString -> SourcePackageId
SourcePackageId FastString
compat_fs,
            packageName :: PackageName
packageName = PackageName
compat_pn,
            packageVersion :: Version
packageVersion = [Int] -> Version
makeVersion [Int
0],
            unitId :: InstalledUnitId
unitId = UnitId -> InstalledUnitId
toInstalledUnitId (DynFlags -> UnitId
thisPackage DynFlags
dflags),
            sourceLibName :: Maybe PackageName
sourceLibName = Maybe PackageName
forall a. Maybe a
Nothing,
            componentId :: ComponentId
componentId = ComponentId
cid,
            instantiatedWith :: [(ModuleName, Module)]
instantiatedWith = [(ModuleName, Module)]
insts,
            -- Slight inefficiency here haha
            exposedModules :: [(ModuleName, Maybe Module)]
exposedModules = ((ModuleName, Module) -> (ModuleName, Maybe Module))
-> [(ModuleName, Module)] -> [(ModuleName, Maybe Module)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
m,Module
n) -> (ModuleName
m,Module -> Maybe Module
forall a. a -> Maybe a
Just Module
n)) [(ModuleName, Module)]
mods,
            hiddenModules :: [ModuleName]
hiddenModules = [], -- TODO: doc only
            depends :: [InstalledUnitId]
depends = 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
_ -> (UnitId -> InstalledUnitId) -> [UnitId] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId -> InstalledUnitId
toInstalledUnitId (UnitId -> InstalledUnitId)
-> (UnitId -> UnitId) -> UnitId -> InstalledUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> UnitId -> UnitId
unwireUnitId DynFlags
dflags)
                                ([UnitId] -> [InstalledUnitId]) -> [UnitId] -> [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$ [UnitId]
deps [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [ Module -> UnitId
moduleUnitId Module
mod
                                          | (ModuleName
_, Module
mod) <- [(ModuleName, Module)]
insts
                                          , Bool -> Bool
not (Module -> Bool
isHoleModule Module
mod) ],
            abiDepends :: [(InstalledUnitId, FilePath)]
abiDepends = [],
            ldOptions :: [FilePath]
ldOptions = case SessionType
session of
                            SessionType
TcSession -> []
                            SessionType
_ -> [FilePath]
obj_files,
            importDirs :: [FilePath]
importDirs = [ FilePath
hi_dir ],
            exposed :: Bool
exposed = Bool
False,
            indefinite :: Bool
indefinite = case SessionType
session of
                            SessionType
TcSession -> Bool
True
                            SessionType
_ -> Bool
False,
            -- nope
            hsLibraries :: [FilePath]
hsLibraries = [],
            extraLibraries :: [FilePath]
extraLibraries = [],
            extraGHCiLibraries :: [FilePath]
extraGHCiLibraries = [],
            libraryDynDirs :: [FilePath]
libraryDynDirs = [],
            libraryDirs :: [FilePath]
libraryDirs = [],
            frameworks :: [FilePath]
frameworks = [],
            frameworkDirs :: [FilePath]
frameworkDirs = [],
            ccOptions :: [FilePath]
ccOptions = [],
            includes :: [FilePath]
includes = [],
            includeDirs :: [FilePath]
includeDirs = [],
            haddockInterfaces :: [FilePath]
haddockInterfaces = [],
            haddockHTMLs :: [FilePath]
haddockHTMLs = [],
            trusted :: Bool
trusted = Bool
False
            }


    InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> BkpM ()
forall (m :: * -> *).
GhcMonad m =>
InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> m ()
addPackage InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
conf
    case Maybe ExternalPackageState
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 (m :: * -> *) a. Monad m => a -> m a
return ()

compileExe :: LHsUnit HsComponentId -> BkpM ()
compileExe :: LHsUnit HsComponentId -> BkpM ()
compileExe LHsUnit HsComponentId
lunit = do
    UnitId -> BkpM ()
msgUnitId UnitId
mainUnitId
    let deps_w_rns :: [(UnitId, ModRenaming)]
deps_w_rns = Bool -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
hsunitDeps Bool
False (LHsUnit HsComponentId -> SrcSpanLess (LHsUnit HsComponentId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsUnit HsComponentId
lunit)
        deps :: [UnitId]
deps = ((UnitId, ModRenaming) -> UnitId)
-> [(UnitId, ModRenaming)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, ModRenaming) -> UnitId
forall a b. (a, b) -> a
fst [(UnitId, ModRenaming)]
deps_w_rns
        -- no renaming necessary
    [(Int, UnitId)] -> ((Int, UnitId) -> BkpM ()) -> BkpM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [UnitId] -> [(Int, UnitId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [UnitId]
deps) (((Int, UnitId) -> BkpM ()) -> BkpM ())
-> ((Int, UnitId) -> BkpM ()) -> BkpM ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, UnitId
dep) ->
        Int -> (Int, UnitId) -> BkpM ()
compileInclude ([UnitId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UnitId]
deps) (Int
i, UnitId
dep)
    [(UnitId, ModRenaming)] -> BkpM () -> BkpM ()
forall a. [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession [(UnitId, ModRenaming)]
deps_w_rns (BkpM () -> BkpM ()) -> BkpM () -> BkpM ()
forall a b. (a -> b) -> a -> b
$ do
        DynFlags
dflags <- IOEnv BkpEnv DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ModuleGraph
mod_graph <- DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph DynFlags
dflags (LHsUnit HsComponentId -> SrcSpanLess (LHsUnit HsComponentId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsUnit HsComponentId
lunit)
        Messager
msg <- BkpM Messager
mkBackpackMsg
        SuccessFlag
ok <- LoadHowMuch
-> Maybe Messager -> ModuleGraph -> IOEnv BkpEnv SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
LoadAllTargets (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
msg) ModuleGraph
mod_graph
        Bool -> BkpM () -> BkpM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SuccessFlag -> Bool
failed SuccessFlag
ok) (IO () -> BkpM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BkpM ()) -> IO () -> BkpM ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1))

addPackage :: GhcMonad m => PackageConfig -> m ()
addPackage :: InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> m ()
addPackage InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
pkg = do
    DynFlags
dflags0 <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
    case DynFlags
-> Maybe
     [(FilePath,
       [InstalledPackageInfo
          ComponentId
          SourcePackageId
          PackageName
          InstalledUnitId
          UnitId
          ModuleName
          Module])]
pkgDatabase DynFlags
dflags0 of
        Maybe
  [(FilePath,
    [InstalledPackageInfo
       ComponentId
       SourcePackageId
       PackageName
       InstalledUnitId
       UnitId
       ModuleName
       Module])]
Nothing -> FilePath -> m ()
forall a. FilePath -> a
panic FilePath
"addPackage: called too early"
        Just [(FilePath,
  [InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module])]
pkgs -> do let dflags :: DynFlags
dflags = DynFlags
dflags0 { pkgDatabase :: Maybe
  [(FilePath,
    [InstalledPackageInfo
       ComponentId
       SourcePackageId
       PackageName
       InstalledUnitId
       UnitId
       ModuleName
       Module])]
pkgDatabase =
                            [(FilePath,
  [InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module])]
-> Maybe
     [(FilePath,
       [InstalledPackageInfo
          ComponentId
          SourcePackageId
          PackageName
          InstalledUnitId
          UnitId
          ModuleName
          Module])]
forall a. a -> Maybe a
Just ([(FilePath,
  [InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module])]
pkgs [(FilePath,
  [InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module])]
-> [(FilePath,
     [InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module])]
-> [(FilePath,
     [InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module])]
forall a. [a] -> [a] -> [a]
++ [(FilePath
"(in memory " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags0 (InstalledUnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> InstalledUnitId
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> instunitid
unitId InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
pkg)) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")", [InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
pkg])]) }
                        [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags
                        -- By this time, the global ref has probably already
                        -- been forced, in which case doing this isn't actually
                        -- going to do you any good.
                        -- dflags <- GHC.getSessionDynFlags
                        -- liftIO $ setUnsafeGlobalDynFlags dflags
                        () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Precondition: UnitId is NOT InstalledUnitId
compileInclude :: Int -> (Int, UnitId) -> BkpM ()
compileInclude :: Int -> (Int, UnitId) -> BkpM ()
compileInclude Int
n (Int
i, UnitId
uid) = do
    HscEnv
hsc_env <- IOEnv BkpEnv HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    (Int, Int) -> UnitId -> BkpM ()
msgInclude (Int
i, Int
n) UnitId
uid
    -- Check if we've compiled it already
    case DynFlags
-> UnitId
-> Maybe
     (InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module)
lookupPackage DynFlags
dflags UnitId
uid of
        Maybe
  (InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module)
Nothing -> do
            case UnitId -> (InstalledUnitId, Maybe IndefUnitId)
splitUnitIdInsts UnitId
uid of
                (InstalledUnitId
_, Just IndefUnitId
indef) ->
                    BkpM () -> BkpM ()
forall a. BkpM a -> BkpM a
innerBkpM (BkpM () -> BkpM ()) -> BkpM () -> BkpM ()
forall a b. (a -> b) -> a -> b
$ ComponentId -> [(ModuleName, Module)] -> BkpM ()
compileUnit (IndefUnitId -> ComponentId
indefUnitIdComponentId IndefUnitId
indef)
                                            (IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
indef)
                (InstalledUnitId, Maybe IndefUnitId)
_ -> () -> BkpM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
_ -> () -> BkpM ()
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 ComponentId (LHsUnit HsComponentId)
bkp_table :: Map ComponentId (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 (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 GhcMonad BkpM where
    getSession :: IOEnv BkpEnv HscEnv
getSession = do
        Session IORef HscEnv
s <- (BkpEnv -> Session) -> BkpM BkpEnv -> IOEnv BkpEnv Session
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
        IORef HscEnv -> IOEnv BkpEnv HscEnv
forall a env. IORef a -> IOEnv env a
readMutVar IORef HscEnv
s
    setSession :: HscEnv -> BkpM ()
setSession HscEnv
hsc_env = do
        Session IORef HscEnv
s <- (BkpEnv -> Session) -> BkpM BkpEnv -> IOEnv BkpEnv Session
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
        IORef HscEnv -> HscEnv -> BkpM ()
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 = 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` BkpM BkpEnv
getBkpEnv

-- | Apply a function on 'DynFlags' on an 'HscEnv'
overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
overHscDynFlags DynFlags -> DynFlags
f HscEnv
hsc_env = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = DynFlags -> DynFlags
f (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) }

-- | Run a 'BkpM' computation, with the nesting level bumped one.
innerBkpM :: BkpM a -> BkpM a
innerBkpM :: BkpM a -> BkpM a
innerBkpM BkpM a
do_this = do
    -- 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 :: Int
bkp_level = BkpEnv -> Int
bkp_level BkpEnv
env Int -> Int -> Int
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_ :: (ExternalPackageState -> ExternalPackageState) -> m ()
updateEpsGhc_ ExternalPackageState -> ExternalPackageState
f = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef ExternalPackageState
-> (ExternalPackageState -> (ExternalPackageState, ())) -> IO ()
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 :: m ExternalPackageState
getEpsGhc = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    IO ExternalPackageState -> m ExternalPackageState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> m ExternalPackageState)
-> IO ExternalPackageState -> m ExternalPackageState
forall a b. (a -> b) -> a -> b
$ IORef ExternalPackageState -> IO ExternalPackageState
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 :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
initBkpM FilePath
file [LHsUnit HsComponentId]
bkp BkpM a
m = do
    (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 :: Session
-> FilePath
-> Map ComponentId (LHsUnit HsComponentId)
-> Int
-> BkpEnv
BkpEnv {
                    bkp_session :: Session
bkp_session = Session
session,
                    bkp_table :: Map ComponentId (LHsUnit HsComponentId)
bkp_table = [(ComponentId, LHsUnit HsComponentId)]
-> Map ComponentId (LHsUnit HsComponentId)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(HsComponentId -> ComponentId
hsComponentId (Located HsComponentId -> SrcSpanLess (Located HsComponentId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (HsUnit HsComponentId -> Located HsComponentId
forall n. HsUnit n -> Located n
hsunitName (LHsUnit HsComponentId -> SrcSpanLess (LHsUnit HsComponentId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
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 -> DynFlags -> String -> IO ()
backpackProgressMsg :: Int -> DynFlags -> FilePath -> IO ()
backpackProgressMsg Int
level DynFlags
dflags FilePath
msg =
    DynFlags -> FilePath -> IO ()
compilationProgressMsg DynFlags
dflags (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' ' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
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
    Messager -> BkpM Messager
forall (m :: * -> *) a. Monad m => a -> m a
return (Messager -> BkpM Messager) -> Messager -> BkpM Messager
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
recomp ModSummary
mod_summary ->
      let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
          showMsg :: FilePath -> FilePath -> IO ()
showMsg FilePath
msg FilePath
reason =
            Int -> DynFlags -> FilePath -> IO ()
backpackProgressMsg Int
level DynFlags
dflags (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                (Int, Int) -> FilePath
showModuleIndex (Int, Int)
mod_index FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                FilePath
msg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ DynFlags -> HscTarget -> Bool -> ModSummary -> FilePath
showModMsg DynFlags
dflags (DynFlags -> HscTarget
hscTarget DynFlags
dflags)
                                  (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp) ModSummary
mod_summary
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
reason
      in case RecompileRequired
recomp of
            RecompileRequired
MustCompile -> FilePath -> FilePath -> IO ()
showMsg FilePath
"Compiling " FilePath
""
            RecompileRequired
UpToDate
                | DynFlags -> Int
verbosity (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 -> FilePath -> FilePath -> IO ()
showMsg FilePath
"Skipping  " FilePath
""
                | Bool
otherwise -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            RecompBecause FilePath
reason -> FilePath -> FilePath -> IO ()
showMsg FilePath
"Compiling " (FilePath
" [" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
reason FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ 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 :: DynFlags -> PprStyle
backpackStyle :: DynFlags -> PprStyle
backpackStyle DynFlags
dflags =
    DynFlags -> PrintUnqualified -> Depth -> PprStyle
mkUserStyle DynFlags
dflags
        (QueryQualifyName
-> (Module -> Bool) -> QueryQualifyPackage -> PrintUnqualified
QueryQualify QueryQualifyName
neverQualifyNames
                      Module -> Bool
alwaysQualifyModules
                      QueryQualifyPackage
neverQualifyPackages) 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) ComponentId
_) = do
    DynFlags
dflags <- IOEnv BkpEnv DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Int
level <- BkpM Int
getBkpLevel
    IO () -> BkpM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BkpM ()) -> (FilePath -> IO ()) -> FilePath -> BkpM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DynFlags -> FilePath -> IO ()
backpackProgressMsg Int
level DynFlags
dflags
        (FilePath -> BkpM ()) -> FilePath -> BkpM ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> FilePath
showModuleIndex (Int
i, Int
n) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Processing " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FastString -> FilePath
unpackFS FastString
fs_pn

-- | Message when we instantiate a Backpack unit.
msgUnitId :: UnitId -> BkpM ()
msgUnitId :: UnitId -> BkpM ()
msgUnitId UnitId
pk = do
    DynFlags
dflags <- IOEnv BkpEnv DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Int
level <- BkpM Int
getBkpLevel
    IO () -> BkpM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BkpM ()) -> (FilePath -> IO ()) -> FilePath -> BkpM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DynFlags -> FilePath -> IO ()
backpackProgressMsg Int
level DynFlags
dflags
        (FilePath -> BkpM ()) -> FilePath -> BkpM ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Instantiating " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> PprStyle -> FilePath
renderWithStyle DynFlags
dflags (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
pk)
                                (DynFlags -> PprStyle
backpackStyle DynFlags
dflags)

-- | Message when we include a Backpack unit.
msgInclude :: (Int,Int) -> UnitId -> BkpM ()
msgInclude :: (Int, Int) -> UnitId -> BkpM ()
msgInclude (Int
i,Int
n) UnitId
uid = do
    DynFlags
dflags <- IOEnv BkpEnv DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Int
level <- BkpM Int
getBkpLevel
    IO () -> BkpM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BkpM ()) -> (FilePath -> IO ()) -> FilePath -> BkpM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DynFlags -> FilePath -> IO ()
backpackProgressMsg Int
level DynFlags
dflags
        (FilePath -> BkpM ()) -> FilePath -> BkpM ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> FilePath
showModuleIndex (Int
i, Int
n) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Including " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
          DynFlags -> SDoc -> PprStyle -> FilePath
renderWithStyle DynFlags
dflags (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid) (DynFlags -> PprStyle
backpackStyle DynFlags
dflags)

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

type PackageNameMap a = Map 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 -> ComponentId -> HsComponentId
HsComponentId PackageName
pn (FastString -> ComponentId
ComponentId FastString
fs))

packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
packageNameMap [LHsUnit PackageName]
units = [(PackageName, HsComponentId)] -> PackageNameMap HsComponentId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((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 :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
renameHsUnits :: DynFlags
-> PackageNameMap HsComponentId
-> [LHsUnit PackageName]
-> [LHsUnit HsComponentId]
renameHsUnits DynFlags
dflags 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 (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 PackageName -> PackageNameMap HsComponentId -> Maybe HsComponentId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pn PackageNameMap HsComponentId
m of
            Maybe HsComponentId
Nothing ->
                case DynFlags -> PackageName -> Maybe ComponentId
lookupPackageName DynFlags
dflags PackageName
pn of
                    Maybe ComponentId
Nothing -> FilePath -> HsComponentId
forall a. HasCallStack => FilePath -> a
error FilePath
"no package name"
                    Just ComponentId
cid -> PackageName -> ComponentId -> HsComponentId
HsComponentId PackageName
pn ComponentId
cid
            Just HsComponentId
hscid -> HsComponentId
hscid

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

convertHsUnitId :: HsUnitId HsComponentId -> UnitId
convertHsUnitId :: HsUnitId HsComponentId -> UnitId
convertHsUnitId (HsUnitId (L SrcSpan
_ HsComponentId
hscid) [LHsModuleSubst HsComponentId]
subst)
    = ComponentId -> [(ModuleName, Module)] -> UnitId
newUnitId (HsComponentId -> ComponentId
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 a. HasSrcSpan a => a -> SrcSpanLess a
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
mkHoleModule ModuleName
modname
convertHsModuleId (HsModuleId (L SrcSpan
_ HsUnitId HsComponentId
hsuid) (L SrcSpan
_ ModuleName
modname)) = UnitId -> ModuleName -> Module
mkModule (HsUnitId HsComponentId -> UnitId
convertHsUnitId HsUnitId HsComponentId
hsuid) ModuleName
modname



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

-- | This is our version of GhcMake.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 GhcMake for now, it's more trouble
-- than it's worth for inline modules.
hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
hsunitModuleGraph DynFlags
dflags HsUnit HsComponentId
unit = do
    let decls :: [LHsUnitDecl HsComponentId]
decls = HsUnit HsComponentId -> [LHsUnitDecl HsComponentId]
forall n. HsUnit n -> [LHsUnitDecl n]
hsunitBody HsUnit HsComponentId
unit
        pn :: PackageName
pn = HsComponentId -> PackageName
hsPackageName (Located HsComponentId -> SrcSpanLess (Located HsComponentId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (HsUnit HsComponentId -> Located HsComponentId
forall n. HsUnit n -> Located n
hsunitName HsUnit HsComponentId
unit))

    --  1. Create a HsSrcFile/HsigFile summary for every
    --  explicitly mentioned module/signature.
    let get_decl :: GenLocated l (HsUnitDecl n) -> IOEnv BkpEnv (Maybe ModSummary)
get_decl (L l
_ (DeclD HscSource
hsc_src GenLocated SrcSpan ModuleName
lmodname Maybe (Located (HsModule GhcPs))
mb_hsmod)) = do
          ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just (ModSummary -> Maybe ModSummary)
-> IOEnv BkpEnv ModSummary -> IOEnv BkpEnv (Maybe ModSummary)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` PackageName
-> HscSource
-> GenLocated SrcSpan ModuleName
-> Maybe (Located (HsModule GhcPs))
-> IOEnv BkpEnv ModSummary
summariseDecl PackageName
pn HscSource
hsc_src GenLocated SrcSpan ModuleName
lmodname Maybe (Located (HsModule GhcPs))
mb_hsmod
        get_decl GenLocated l (HsUnitDecl n)
_ = Maybe ModSummary -> IOEnv BkpEnv (Maybe ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModSummary
forall a. Maybe a
Nothing
    [ModSummary]
nodes <- [Maybe ModSummary] -> [ModSummary]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ModSummary] -> [ModSummary])
-> IOEnv BkpEnv [Maybe ModSummary] -> IOEnv BkpEnv [ModSummary]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (LHsUnitDecl HsComponentId -> IOEnv BkpEnv (Maybe ModSummary))
-> [LHsUnitDecl HsComponentId] -> IOEnv BkpEnv [Maybe ModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsUnitDecl HsComponentId -> IOEnv BkpEnv (Maybe ModSummary)
forall l n.
GenLocated l (HsUnitDecl n) -> IOEnv BkpEnv (Maybe ModSummary)
get_decl [LHsUnitDecl 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 node_map :: Map (ModuleName, Bool) ModSummary
node_map = [((ModuleName, Bool), ModSummary)]
-> Map (ModuleName, Bool) ModSummary
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ ((ModSummary -> ModuleName
ms_mod_name ModSummary
n, ModSummary -> HscSource
ms_hsc_src ModSummary
n HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile), ModSummary
n)
                                | ModSummary
n <- [ModSummary]
nodes ]
    [ModSummary]
req_nodes <- ([Maybe ModSummary] -> [ModSummary])
-> IOEnv BkpEnv [Maybe ModSummary] -> IOEnv BkpEnv [ModSummary]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe ModSummary] -> [ModSummary]
forall a. [Maybe a] -> [a]
catMaybes (IOEnv BkpEnv [Maybe ModSummary] -> IOEnv BkpEnv [ModSummary])
-> (((ModuleName, Module) -> IOEnv BkpEnv (Maybe ModSummary))
    -> IOEnv BkpEnv [Maybe ModSummary])
-> ((ModuleName, Module) -> IOEnv BkpEnv (Maybe ModSummary))
-> IOEnv BkpEnv [ModSummary]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ModuleName, Module)]
-> ((ModuleName, Module) -> IOEnv BkpEnv (Maybe ModSummary))
-> IOEnv BkpEnv [Maybe ModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (DynFlags -> [(ModuleName, Module)]
thisUnitIdInsts DynFlags
dflags) (((ModuleName, Module) -> IOEnv BkpEnv (Maybe ModSummary))
 -> IOEnv BkpEnv [ModSummary])
-> ((ModuleName, Module) -> IOEnv BkpEnv (Maybe ModSummary))
-> IOEnv BkpEnv [ModSummary]
forall a b. (a -> b) -> a -> b
$ \(ModuleName
mod_name, Module
_) ->
        let has_local :: Bool
has_local = (ModuleName, Bool) -> Map (ModuleName, Bool) ModSummary -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (ModuleName
mod_name, Bool
True) Map (ModuleName, Bool) ModSummary
node_map
        in if Bool
has_local
            then Maybe ModSummary -> IOEnv BkpEnv (Maybe ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModSummary
forall a. Maybe a
Nothing
            else (ModSummary -> Maybe ModSummary)
-> IOEnv BkpEnv ModSummary -> IOEnv BkpEnv (Maybe ModSummary)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just (IOEnv BkpEnv ModSummary -> IOEnv BkpEnv (Maybe ModSummary))
-> IOEnv BkpEnv ModSummary -> IOEnv BkpEnv (Maybe ModSummary)
forall a b. (a -> b) -> a -> b
$ PackageName -> ModuleName -> IOEnv BkpEnv ModSummary
summariseRequirement PackageName
pn ModuleName
mod_name

    -- 3. Return the kaboodle
    ModuleGraph -> BkpM ModuleGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleGraph -> BkpM ModuleGraph)
-> ModuleGraph -> BkpM ModuleGraph
forall a b. (a -> b) -> a -> b
$ [ModSummary] -> ModuleGraph
mkModuleGraph ([ModSummary] -> ModuleGraph) -> [ModSummary] -> ModuleGraph
forall a b. (a -> b) -> a -> b
$ [ModSummary]
nodes [ModSummary] -> [ModSummary] -> [ModSummary]
forall a. [a] -> [a] -> [a]
++ [ModSummary]
req_nodes

summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
summariseRequirement :: PackageName -> ModuleName -> IOEnv BkpEnv ModSummary
summariseRequirement PackageName
pn ModuleName
mod_name = do
    HscEnv
hsc_env <- IOEnv BkpEnv HscEnv
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 <- IO ModLocation -> IOEnv BkpEnv ModLocation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModLocation -> IOEnv BkpEnv ModLocation)
-> IO ModLocation -> IOEnv BkpEnv ModLocation
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 <- IO UTCTime -> IOEnv BkpEnv UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> IOEnv BkpEnv UTCTime)
-> IO UTCTime -> IOEnv BkpEnv UTCTime
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationUTCTime (BkpEnv -> FilePath
bkp_filename BkpEnv
env)
    Maybe UTCTime
hi_timestamp <- IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime))
-> IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
location)
    Maybe UTCTime
hie_timestamp <- IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime))
-> IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime)
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 <- IO Module -> IOEnv BkpEnv Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> IOEnv BkpEnv Module)
-> IO Module -> IOEnv BkpEnv Module
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 <- IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> IOEnv BkpEnv [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
 -> IOEnv
      BkpEnv [(Maybe FastString, GenLocated SrcSpan ModuleName)])
-> IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> IOEnv BkpEnv [(Maybe FastString, GenLocated SrcSpan ModuleName)]
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

    ModSummary -> IOEnv BkpEnv ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary :: Module
-> HscSource
-> ModLocation
-> UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> Maybe HsParsedModule
-> FilePath
-> DynFlags
-> Maybe StringBuffer
-> ModSummary
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 = 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 :: [(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 = HsParsedModule -> Maybe HsParsedModule
forall a. a -> Maybe a
Just (HsParsedModule :: Located (HsModule GhcPs) -> [FilePath] -> ApiAnns -> HsParsedModule
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 :: forall pass.
Maybe (GenLocated SrcSpan ModuleName)
-> Maybe (Located [LIE pass])
-> [LImportDecl pass]
-> [LHsDecl pass]
-> Maybe (Located WarningTxt)
-> Maybe LHsDocString
-> HsModule pass
HsModule {
                        hsmodName :: Maybe (GenLocated SrcSpan ModuleName)
hsmodName = GenLocated SrcSpan ModuleName
-> Maybe (GenLocated SrcSpan ModuleName)
forall a. a -> Maybe a
Just (SrcSpan -> ModuleName -> GenLocated SrcSpan ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc ModuleName
mod_name),
                        hsmodExports :: Maybe (Located [LIE GhcPs])
hsmodExports = Maybe (Located [LIE GhcPs])
forall a. Maybe a
Nothing,
                        hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [],
                        hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = [],
                        hsmodDeprecMessage :: Maybe (Located WarningTxt)
hsmodDeprecMessage = Maybe (Located WarningTxt)
forall a. Maybe a
Nothing,
                        hsmodHaddockModHeader :: Maybe LHsDocString
hsmodHaddockModHeader = Maybe LHsDocString
forall a. Maybe a
Nothing
                    }),
                hpm_src_files :: [FilePath]
hpm_src_files = [],
                hpm_annotations :: ApiAnns
hpm_annotations = (Map ApiAnnKey [SrcSpan]
forall k a. Map k a
Map.empty, Map SrcSpan [Located AnnotationComment]
forall k a. Map k a
Map.empty)
            }),
        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
        }

summariseDecl :: PackageName
              -> HscSource
              -> Located ModuleName
              -> Maybe (Located (HsModule GhcPs))
              -> BkpM ModSummary
summariseDecl :: PackageName
-> HscSource
-> GenLocated SrcSpan ModuleName
-> Maybe (Located (HsModule GhcPs))
-> IOEnv BkpEnv ModSummary
summariseDecl PackageName
pn HscSource
hsc_src (L SrcSpan
_ ModuleName
modname) (Just Located (HsModule GhcPs)
hsmod) = PackageName
-> HscSource
-> ModuleName
-> Located (HsModule GhcPs)
-> IOEnv BkpEnv ModSummary
hsModuleToModSummary PackageName
pn HscSource
hsc_src ModuleName
modname Located (HsModule GhcPs)
hsmod
summariseDecl PackageName
_pn HscSource
hsc_src lmodname :: GenLocated SrcSpan ModuleName
lmodname@(L SrcSpan
loc ModuleName
modname) Maybe (Located (HsModule GhcPs))
Nothing
    = do HscEnv
hsc_env <- IOEnv BkpEnv HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
         let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
         -- TODO: this looks for modules in the wrong place
         Maybe (Either ErrorMessages ModSummary)
r <- IO (Maybe (Either ErrorMessages ModSummary))
-> IOEnv BkpEnv (Maybe (Either ErrorMessages ModSummary))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Either ErrorMessages ModSummary))
 -> IOEnv BkpEnv (Maybe (Either ErrorMessages ModSummary)))
-> IO (Maybe (Either ErrorMessages ModSummary))
-> IOEnv BkpEnv (Maybe (Either ErrorMessages ModSummary))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> NodeMap ModSummary
-> IsBoot
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ModSummary))
summariseModule HscEnv
hsc_env
                         NodeMap ModSummary
forall k a. Map k a
Map.empty -- GHC API recomp not supported
                         (HscSource -> IsBoot
hscSourceToIsBoot HscSource
hsc_src)
                         GenLocated SrcSpan ModuleName
lmodname
                         Bool
True -- Target lets you disallow, but not here
                         Maybe (StringBuffer, UTCTime)
forall a. Maybe a
Nothing -- GHC API buffer support not supported
                         [] -- No exclusions
         case Maybe (Either ErrorMessages ModSummary)
r of
            Maybe (Either ErrorMessages ModSummary)
Nothing -> ErrMsg -> IOEnv BkpEnv ModSummary
forall (io :: * -> *) a. MonadIO io => ErrMsg -> io a
throwOneError (DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
loc (FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
modname SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"was not found"))
            Just (Left ErrorMessages
err) -> ErrorMessages -> IOEnv BkpEnv ModSummary
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
err
            Just (Right ModSummary
summary) -> ModSummary -> IOEnv BkpEnv ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
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 GhcPs)
                     -> BkpM ModSummary
hsModuleToModSummary :: PackageName
-> HscSource
-> ModuleName
-> Located (HsModule GhcPs)
-> IOEnv BkpEnv ModSummary
hsModuleToModSummary PackageName
pn HscSource
hsc_src ModuleName
modname
                     Located (HsModule GhcPs)
hsmod = do
    let imps :: [LImportDecl GhcPs]
imps = HsModule GhcPs -> [LImportDecl GhcPs]
forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports (Located (HsModule GhcPs) -> SrcSpanLess (Located (HsModule GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (HsModule GhcPs)
hsmod)
        loc :: SrcSpan
loc  = Located (HsModule GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located (HsModule GhcPs)
hsmod
    HscEnv
hsc_env <- IOEnv BkpEnv HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    -- Sort of the same deal as in DriverPipeline'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 <- IO ModLocation -> IOEnv BkpEnv ModLocation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModLocation -> IOEnv BkpEnv ModLocation)
-> IO ModLocation -> IOEnv BkpEnv ModLocation
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 GhcMake
    BkpEnv
env <- BkpM BkpEnv
getBkpEnv
    UTCTime
time <- IO UTCTime -> IOEnv BkpEnv UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> IOEnv BkpEnv UTCTime)
-> IO UTCTime -> IOEnv BkpEnv UTCTime
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationUTCTime (BkpEnv -> FilePath
bkp_filename BkpEnv
env)
    Maybe UTCTime
hi_timestamp <- IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime))
-> IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
location)
    Maybe UTCTime
hie_timestamp <- IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime))
-> IO (Maybe UTCTime) -> IOEnv BkpEnv (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
location)

    -- Also copied from 'getImports'
    let ([LImportDecl GhcPs]
src_idecls, [LImportDecl GhcPs]
ord_idecls) = (LImportDecl GhcPs -> Bool)
-> [LImportDecl GhcPs]
-> ([LImportDecl GhcPs], [LImportDecl GhcPs])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (ImportDecl GhcPs -> Bool
forall pass. ImportDecl pass -> Bool
ideclSource(ImportDecl GhcPs -> Bool)
-> (LImportDecl GhcPs -> ImportDecl GhcPs)
-> LImportDecl GhcPs
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LImportDecl GhcPs -> ImportDecl GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LImportDecl GhcPs]
imps

             -- GHC.Prim doesn't exist physically, so don't go looking for it.
        ordinary_imps :: [LImportDecl GhcPs]
ordinary_imps = (LImportDecl GhcPs -> Bool)
-> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> ModuleName
moduleName Module
gHC_PRIM) (ModuleName -> Bool)
-> (LImportDecl GhcPs -> ModuleName) -> LImportDecl GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (GenLocated SrcSpan ModuleName -> ModuleName)
-> (LImportDecl GhcPs -> GenLocated SrcSpan ModuleName)
-> LImportDecl GhcPs
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> GenLocated SrcSpan ModuleName
forall pass. ImportDecl pass -> GenLocated SrcSpan ModuleName
ideclName (ImportDecl GhcPs -> GenLocated SrcSpan ModuleName)
-> (LImportDecl GhcPs -> ImportDecl GhcPs)
-> LImportDecl GhcPs
-> GenLocated SrcSpan ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcPs -> ImportDecl GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc)
                               [LImportDecl 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) = ((StringLiteral -> FastString)
-> Maybe StringLiteral -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StringLiteral -> FastString
sl_fs (ImportDecl pass -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl pass
i), ImportDecl pass -> GenLocated SrcSpan ModuleName
forall pass. ImportDecl pass -> GenLocated SrcSpan ModuleName
ideclName ImportDecl pass
i)

    [(Maybe FastString, GenLocated SrcSpan ModuleName)]
extra_sig_imports <- IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> IOEnv BkpEnv [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
 -> IOEnv
      BkpEnv [(Maybe FastString, GenLocated SrcSpan ModuleName)])
-> IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> IOEnv BkpEnv [(Maybe FastString, GenLocated SrcSpan ModuleName)]
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 = (LImportDecl GhcPs
 -> (Maybe FastString, GenLocated SrcSpan ModuleName))
-> [LImportDecl GhcPs]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map LImportDecl GhcPs
-> (Maybe FastString, GenLocated SrcSpan ModuleName)
forall l pass.
GenLocated l (ImportDecl pass)
-> (Maybe FastString, GenLocated SrcSpan ModuleName)
convImport ([LImportDecl GhcPs]
implicit_imports [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
ordinary_imps)
    [(Maybe FastString, GenLocated SrcSpan ModuleName)]
required_by_imports <- IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> IOEnv BkpEnv [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
 -> IOEnv
      BkpEnv [(Maybe FastString, GenLocated SrcSpan ModuleName)])
-> IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> IOEnv BkpEnv [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
implicitRequirements 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 <- IO Module -> IOEnv BkpEnv Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> IOEnv BkpEnv Module)
-> IO Module -> IOEnv BkpEnv Module
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env ModuleName
modname ModLocation
location
    ModSummary -> IOEnv BkpEnv ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary :: Module
-> HscSource
-> ModLocation
-> UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> Maybe HsParsedModule
-> FilePath
-> DynFlags
-> Maybe StringBuffer
-> ModSummary
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 :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_srcimps = (LImportDecl GhcPs
 -> (Maybe FastString, GenLocated SrcSpan ModuleName))
-> [LImportDecl GhcPs]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map LImportDecl GhcPs
-> (Maybe FastString, GenLocated SrcSpan ModuleName)
forall l pass.
GenLocated l (ImportDecl pass)
-> (Maybe FastString, GenLocated SrcSpan ModuleName)
convImport [LImportDecl 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
                           [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++ [(Maybe FastString, GenLocated SrcSpan ModuleName)]
extra_sig_imports
                           [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++ [(Maybe FastString, GenLocated SrcSpan ModuleName)]
required_by_imports,
            -- 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 :: Located (HsModule GhcPs) -> [FilePath] -> ApiAnns -> HsParsedModule
HsParsedModule {
                    hpm_module :: Located (HsModule GhcPs)
hpm_module = Located (HsModule GhcPs)
hsmod,
                    hpm_src_files :: [FilePath]
hpm_src_files = [], -- TODO if we preprocessed it
                    hpm_annotations :: ApiAnns
hpm_annotations = (Map ApiAnnKey [SrcSpan]
forall k a. Map k a
Map.empty, Map SrcSpan [Located AnnotationComment]
forall k a. Map k a
Map.empty) -- BOGUS
                }),
            ms_hs_date :: UTCTime
ms_hs_date = UTCTime
time,
            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_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp,
            ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
        }

-- | Create a new, externally provided hashed unit id from
-- a hash.
newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
newInstalledUnitId (ComponentId FastString
cid_fs) (Just FastString
fs)
    = FastString -> InstalledUnitId
InstalledUnitId (FastString
cid_fs FastString -> FastString -> FastString
`appendFS` FilePath -> FastString
mkFastString FilePath
"+" FastString -> FastString -> FastString
`appendFS` FastString
fs)
newInstalledUnitId (ComponentId FastString
cid_fs) Maybe FastString
Nothing
    = FastString -> InstalledUnitId
InstalledUnitId FastString
cid_fs