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