module GHC.Iface.Load (
tcLookupImported_maybe, importDecl,
checkWiredInTyCon, ifCheckWiredInThing,
loadModuleInterface, loadModuleInterfaces,
loadSrcInterface, loadSrcInterface_maybe,
loadInterfaceForName, loadInterfaceForModule,
loadInterface,
loadSysInterface, loadUserInterface, loadPluginInterface,
findAndReadIface, readIface, writeIface,
moduleFreeHolesPrecise,
needWiredInHomeIface, loadWiredInHomeIface,
pprModIfaceSimple,
ifaceStats, pprModIface, showIface,
module Iface_Errors
) where
import GHC.Prelude
import GHC.Platform.Profile
import GHC.IfaceToCore
( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst
, tcIfaceAnnotations, tcIfaceCompleteMatches )
import GHC.Driver.Config.Finder
import GHC.Driver.Env
import GHC.Driver.Errors.Types
import GHC.Driver.Session
import GHC.Driver.Hooks
import GHC.Driver.Plugins
import GHC.Iface.Syntax
import GHC.Iface.Ext.Fields
import GHC.Iface.Binary
import GHC.Iface.Rename
import GHC.Iface.Env
import GHC.Iface.Errors as Iface_Errors
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Utils.Binary ( BinData(..) )
import GHC.Utils.Error
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Logger
import GHC.Utils.Trace
import GHC.Settings.Constants
import GHC.Builtin.Names
import GHC.Builtin.Utils
import GHC.Builtin.PrimOps ( allThePrimOps, primOpFixity, primOpOcc )
import GHC.Core.Rules
import GHC.Core.TyCon
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Types.Id.Make ( seqId )
import GHC.Types.Annotations
import GHC.Types.Name
import GHC.Types.Name.Cache
import GHC.Types.Name.Env
import GHC.Types.Avail
import GHC.Types.Fixity
import GHC.Types.Fixity.Env
import GHC.Types.SourceError
import GHC.Types.SourceText
import GHC.Types.SourceFile
import GHC.Types.SafeHaskell
import GHC.Types.TypeEnv
import GHC.Types.Unique.DSet
import GHC.Types.SrcLoc
import GHC.Types.TyThing
import GHC.Types.PkgQual
import GHC.Unit.External
import GHC.Unit.Module
import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
import GHC.Unit.State
import GHC.Unit.Home
import GHC.Unit.Home.ModInfo
import GHC.Unit.Finder
import GHC.Unit.Env
import GHC.Data.Maybe
import Control.Monad
import Data.Map ( toList )
import System.FilePath
import System.Directory
import GHC.Driver.Env.KnotVars
tcLookupImported_maybe :: Name -> TcM (MaybeErr SDoc TyThing)
tcLookupImported_maybe name
= do { hsc_env <- getTopEnv
; mb_thing <- liftIO (lookupType hsc_env name)
; case mb_thing of
Just thing -> return (Succeeded thing)
Nothing -> tcImportDecl_maybe name }
tcImportDecl_maybe :: Name -> TcM (MaybeErr SDoc TyThing)
tcImportDecl_maybe name
| Just thing <- wiredInNameTyThing_maybe name
= do { when (needWiredInHomeIface thing)
(initIfaceTcRn (loadWiredInHomeIface name))
; return (Succeeded thing) }
| otherwise
= initIfaceTcRn (importDecl name)
importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing)
importDecl name
= assert (not (isWiredInName name)) $
do { logger <- getLogger
; liftIO $ trace_if logger nd_doc
; mb_iface <- assertPpr (isExternalName name) (ppr name) $
loadInterface nd_doc (nameModule name) ImportBySystem
; case mb_iface of {
Failed err_msg -> return (Failed err_msg) ;
Succeeded _ -> do
{ eps <- getEps
; case lookupTypeEnv (eps_PTE eps) name of
Just thing -> return $ Succeeded thing
Nothing -> let doc = whenPprDebug (found_things_msg eps $$ empty)
$$ not_found_msg
in return $ Failed doc
}}}
where
nd_doc = text "Need decl for" <+> ppr name
not_found_msg = hang (text "Can't find interface-file declaration for" <+>
pprNameSpace (nameNameSpace name) <+> ppr name)
2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",
text "Use -ddump-if-trace to get an idea of which file caused the error"])
found_things_msg eps =
hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon)
2 (vcat (map ppr $ filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps))
where
is_interesting thing = nameModule name == nameModule (getName thing)
checkWiredInTyCon :: TyCon -> TcM ()
checkWiredInTyCon tc
| not (isWiredInName tc_name)
= return ()
| otherwise
= do { mod <- getModule
; logger <- getLogger
; liftIO $ trace_if logger (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)
; assert (isExternalName tc_name )
when (mod /= nameModule tc_name)
(initIfaceTcRn (loadWiredInHomeIface tc_name))
}
where
tc_name = tyConName tc
ifCheckWiredInThing :: TyThing -> IfL ()
ifCheckWiredInThing thing
= do { mod <- getIfModule
; let name = getName thing
; assertPpr (isExternalName name) (ppr name) $
when (needWiredInHomeIface thing && mod /= nameModule name)
(loadWiredInHomeIface name) }
needWiredInHomeIface :: TyThing -> Bool
needWiredInHomeIface (ATyCon {}) = True
needWiredInHomeIface _ = False
loadSrcInterface :: SDoc
-> ModuleName
-> IsBootInterface
-> PkgQual
-> RnM ModIface
loadSrcInterface doc mod want_boot maybe_pkg
= do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg
; case res of
Failed err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)
Succeeded iface -> return iface }
loadSrcInterface_maybe :: SDoc
-> ModuleName
-> IsBootInterface
-> PkgQual
-> RnM (MaybeErr SDoc ModIface)
loadSrcInterface_maybe doc mod want_boot maybe_pkg
= do hsc_env <- getTopEnv
res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
case res of
Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
err -> return (Failed (cannotFindModule hsc_env mod err))
loadModuleInterface :: SDoc -> Module -> TcM ModIface
loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod)
loadModuleInterfaces :: SDoc -> [Module] -> TcM ()
loadModuleInterfaces doc mods
| null mods = return ()
| otherwise = initIfaceTcRn (mapM_ load mods)
where
load mod = loadSysInterface (doc <+> parens (ppr mod)) mod
loadInterfaceForName :: SDoc -> Name -> TcRn ModIface
loadInterfaceForName doc name
= do { when debugIsOn $
do { this_mod <- getModule
; massertPpr (not (nameIsLocalOrFrom this_mod name)) (ppr name <+> parens doc) }
; assertPpr (isExternalName name) (ppr name) $
initIfaceTcRn $ loadSysInterface doc (nameModule name) }
loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface
loadInterfaceForModule doc m
= do
when debugIsOn $ do
this_mod <- getModule
massertPpr (this_mod /= m) (ppr m <+> parens doc)
initIfaceTcRn $ loadSysInterface doc m
loadWiredInHomeIface :: Name -> IfM lcl ()
loadWiredInHomeIface name
= assert (isWiredInName name) $
do _ <- loadSysInterface doc (nameModule name); return ()
where
doc = text "Need home interface for wired-in thing" <+> ppr name
loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem
loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl ModIface
loadUserInterface is_boot doc mod_name
= loadInterfaceWithException doc mod_name (ImportByUser is_boot)
loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface
loadPluginInterface doc mod_name
= loadInterfaceWithException doc mod_name ImportByPlugin
loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
loadInterfaceWithException doc mod_name where_from
= do
dflags <- getDynFlags
let ctx = initSDocContext dflags defaultUserStyle
withException ctx (loadInterface doc mod_name where_from)
loadInterface :: SDoc -> Module -> WhereFrom
-> IfM lcl (MaybeErr SDoc ModIface)
loadInterface doc_str mod from
| isHoleModule mod
= do hsc_env <- getTopEnv
let home_unit = hsc_home_unit hsc_env
loadInterface doc_str (mkHomeModule home_unit (moduleName mod)) from
| otherwise
= do
logger <- getLogger
withTimingSilent logger (text "loading interface") (pure ()) $ do
{
(eps,hug) <- getEpsAndHug
; gbl_env <- getGblEnv
; liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> ppr from)
; hsc_env <- getTopEnv
; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)
; case lookupIfaceByModule hug (eps_PIT eps) mod of {
Just iface
-> return (Succeeded iface) ;
_ -> do {
; read_result <- case wantHiBootFile mhome_unit eps mod from of
Failed err -> return (Failed err)
Succeeded hi_boot_file -> do
hsc_env <- getTopEnv
liftIO $ computeInterface hsc_env doc_str hi_boot_file mod
; case read_result of {
Failed err -> do
{ let fake_iface = emptyFullModIface mod
; updateEps_ $ \eps ->
eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
; return (Failed err) } ;
Succeeded (iface, loc) ->
let
loc_doc = text loc
in
initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $
dontLeakTheHUG $ do
; massertPpr
((isOneShot (ghcMode (hsc_dflags hsc_env)))
|| moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env
|| mod == gHC_PRIM)
(text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod))
; ignore_prags <- goptM Opt_IgnoreInterfacePragmas
; new_eps_decls <- tcIfaceDecls ignore_prags (mi_decls iface)
; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
; let { final_iface = iface {
mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_insts in PIT",
mi_fam_insts = panic "No mi_fam_insts in PIT",
mi_rules = panic "No mi_rules in PIT",
mi_anns = panic "No mi_anns in PIT"
}
}
; let bad_boot = mi_boot iface == IsBoot
&& isJust (lookupKnotVars (if_rec_types gbl_env) mod)
; warnPprTrace bad_boot "loadInterface" (ppr mod) $
updateEps_ $ \ eps ->
if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface
then eps
else if bad_boot
then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls }
else
eps {
eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
eps_rule_base = extendRuleBaseList (eps_rule_base eps)
new_eps_rules,
eps_complete_matches
= eps_complete_matches eps ++ new_eps_complete_matches,
eps_inst_env = extendInstEnvList (eps_inst_env eps)
new_eps_insts,
eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
new_eps_fam_insts,
eps_ann_env = extendAnnEnvList (eps_ann_env eps)
new_eps_anns,
eps_mod_fam_inst_env
= let
fam_inst_env =
extendFamInstEnvList emptyFamInstEnv
new_eps_fam_insts
in
extendModuleEnv (eps_mod_fam_inst_env eps)
mod
fam_inst_env,
eps_stats = addEpsInStats (eps_stats eps)
(length new_eps_decls)
(length new_eps_insts)
(length new_eps_rules) }
;
res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface
; return (Succeeded res)
}}}}
dontLeakTheHUG :: IfL a -> IfL a
dontLeakTheHUG thing_inside = do
env <- getTopEnv
let
inOneShot =
isOneShot (ghcMode (hsc_dflags env))
cleanGblEnv gbl_env
| inOneShot = gbl_env
| otherwise = gbl_env { if_rec_types = emptyKnotVars }
cleanTopEnv hsc_env =
let
!maybe_type_vars | inOneShot = Just (hsc_type_env_vars env)
| otherwise = Nothing
old_unit_env = hsc_unit_env hsc_env
keepFor20509 hmi
| isHoleModule (mi_semantic_module (hm_iface hmi)) = True
| otherwise = False
pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }
!unit_env
= old_unit_env
{ ue_home_unit_graph = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_home_unit_graph old_unit_env
else unitEnv_map pruneHomeUnitEnv (ue_home_unit_graph old_unit_env)
}
in
hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets"
, hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph"
, hsc_IC = panic "cleanTopEnv: hsc_IC"
, hsc_type_env_vars = case maybe_type_vars of
Just vars -> vars
Nothing -> panic "cleanTopEnv: hsc_type_env_vars"
, hsc_unit_env = unit_env
}
updTopEnv cleanTopEnv $ updGblEnv cleanGblEnv $ do
!_ <- getTopEnv
!_ <- getGblEnv
thing_inside
is_external_sig :: Maybe HomeUnit -> ModIface -> Bool
is_external_sig mhome_unit iface =
mi_semantic_module iface /= mi_module iface &&
notHomeModuleMaybe mhome_unit (mi_module iface)
computeInterface
:: HscEnv
-> SDoc
-> IsBootInterface
-> Module
-> IO (MaybeErr SDoc (ModIface, FilePath))
computeInterface hsc_env doc_str hi_boot_file mod0 = do
massert (not (isHoleModule mod0))
let mhome_unit = hsc_home_unit_maybe hsc_env
let find_iface m = findAndReadIface hsc_env doc_str
m mod0 hi_boot_file
case getModuleInstantiation mod0 of
(imod, Just indef)
| Just home_unit <- mhome_unit
, isHomeUnitIndefinite home_unit ->
find_iface imod >>= \case
Succeeded (iface0, path) ->
rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case
Right x -> return (Succeeded (x, path))
Left errs -> throwErrors (GhcTcRnMessage <$> errs)
Failed err -> return (Failed err)
(mod, _) -> find_iface mod
moduleFreeHolesPrecise
:: SDoc -> Module
-> TcRnIf gbl lcl (MaybeErr SDoc (UniqDSet ModuleName))
moduleFreeHolesPrecise doc_str mod
| moduleIsDefinite mod = return (Succeeded emptyUniqDSet)
| otherwise =
case getModuleInstantiation mod of
(imod, Just indef) -> do
logger <- getLogger
let insts = instUnitInsts (moduleUnit indef)
liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+>
text "to compute precise free module holes")
(eps, hpt) <- getEpsAndHug
case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of
Just r -> return (Succeeded r)
Nothing -> readAndCache imod insts
(_, Nothing) -> return (Succeeded emptyUniqDSet)
where
tryEpsAndHpt eps hpt =
fmap mi_free_holes (lookupIfaceByModule hpt (eps_PIT eps) mod)
tryDepsCache eps imod insts =
case lookupInstalledModuleEnv (eps_free_holes eps) imod of
Just ifhs -> Just (renameFreeHoles ifhs insts)
_otherwise -> Nothing
readAndCache imod insts = do
hsc_env <- getTopEnv
mb_iface <- liftIO $ findAndReadIface hsc_env
(text "moduleFreeHolesPrecise" <+> doc_str)
imod mod NotBoot
case mb_iface of
Succeeded (iface, _) -> do
let ifhs = mi_free_holes iface
updateEps_ (\eps ->
eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs })
return (Succeeded (renameFreeHoles ifhs insts))
Failed err -> return (Failed err)
wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom
-> MaybeErr SDoc IsBootInterface
wantHiBootFile mhome_unit eps mod from
= case from of
ImportByUser usr_boot
| usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod
-> Failed (badSourceImport mod)
| otherwise -> Succeeded usr_boot
ImportByPlugin
-> Succeeded NotBoot
ImportBySystem
| notHomeModuleMaybe mhome_unit mod
-> Succeeded NotBoot
| otherwise
-> case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of
Just (GWIB { gwib_isBoot = is_boot }) ->
Succeeded is_boot
Nothing ->
Succeeded NotBoot
badSourceImport :: Module -> SDoc
badSourceImport mod
= hang (text "You cannot {-# SOURCE #-} import a module from another package")
2 (text "but" <+> quotes (ppr mod) <+> text "is from package"
<+> quotes (ppr (moduleUnit mod)))
addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
addDeclsToPTE pte things = extendNameEnvList pte things
findAndReadIface
:: HscEnv
-> SDoc
-> InstalledModule
-> Module
-> IsBootInterface
-> IO (MaybeErr SDoc (ModIface, FilePath))
findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
let profile = targetProfile dflags
unit_state = hsc_units hsc_env
fc = hsc_FC hsc_env
name_cache = hsc_NC hsc_env
mhome_unit = hsc_home_unit_maybe hsc_env
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env)
trace_if logger (sep [hsep [text "Reading",
if hi_boot_file == IsBoot
then text "[boot]"
else Outputable.empty,
text "interface for",
ppr mod <> semi],
nest 4 (text "reason:" <+> doc_str)])
if mod `installedModuleEq` gHC_PRIM
then do
let iface = case ghcPrimIfaceHook hooks of
Nothing -> ghcPrimIface
Just h -> h
return (Succeeded (iface, "<built in interface for GHC.Prim>"))
else do
let fopts = initFinderOpts dflags
mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod)
case mb_found of
InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do
case mhome_unit of
Just home_unit
| isHomeInstalledModule home_unit mod
, not (isOneShot (ghcMode dflags))
-> return (Failed (homeModError mod loc))
_ -> do
r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc)
case r of
Failed _
-> return r
Succeeded (iface,_fp)
-> do
r2 <- load_dynamic_too_maybe logger name_cache unit_state
(setDynamicNow dflags) wanted_mod
iface loc
case r2 of
Failed sdoc -> return (Failed sdoc)
Succeeded {} -> return r
err -> do
trace_if logger (text "...not found")
return $ Failed $ cannotFindInterface
unit_state
mhome_unit
profile
(Iface_Errors.mayShowLocations dflags)
(moduleName mod)
err
load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ())
load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod iface loc
| not (moduleIsDefinite (mi_module iface)) = return (Succeeded ())
| gopt Opt_BuildDynamicToo dflags = load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc
| otherwise = return (Succeeded ())
load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ())
load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc = do
read_file logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case
Succeeded (dynIface, _)
| mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface)
-> return (Succeeded ())
| otherwise ->
do return $ (Failed $ dynamicHashMismatchError wanted_mod loc)
Failed err ->
do return $ (Failed $ ((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err))
dynamicHashMismatchError :: Module -> ModLocation -> SDoc
dynamicHashMismatchError wanted_mod loc =
vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod)
, text "Normal interface file from" <+> text (ml_hi_file loc)
, text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc)
, text "You probably need to recompile" <+> quotes (ppr wanted_mod) ]
read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (ModIface, FilePath))
read_file logger name_cache unit_state dflags wanted_mod file_path = do
trace_if logger (text "readIFace" <+> text file_path)
let wanted_mod' =
case getModuleInstantiation wanted_mod of
(_, Nothing) -> wanted_mod
(_, Just indef_mod) ->
instModuleToModule unit_state
(uninstantiateInstantiatedModule indef_mod)
read_result <- readIface dflags name_cache wanted_mod' file_path
case read_result of
Failed err -> return (Failed (badIfaceFile file_path err))
Succeeded iface -> return (Succeeded (iface, file_path))
writeIface :: Logger -> Profile -> FilePath -> ModIface -> IO ()
writeIface logger profile hi_file_path new_iface
= do createDirectoryIfMissing True (takeDirectory hi_file_path)
let printer = TraceBinIFace (debugTraceMsg logger 3)
writeBinIface profile printer hi_file_path new_iface
readIface
:: DynFlags
-> NameCache
-> Module
-> FilePath
-> IO (MaybeErr SDoc ModIface)
readIface dflags name_cache wanted_mod file_path = do
let profile = targetProfile dflags
res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path
case res of
Right iface
| wanted_mod == actual_mod
-> return (Succeeded iface)
| otherwise -> return (Failed err)
where
actual_mod = mi_module iface
err = hiModuleNameMismatchWarn wanted_mod actual_mod
Left exn -> return (Failed (text (showException exn)))
ghcPrimIface :: ModIface
ghcPrimIface
= empty_iface {
mi_exports = ghcPrimExports,
mi_decls = [],
mi_fixities = fixities,
mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities },
mi_docs = Just ghcPrimDeclDocs
}
where
empty_iface = emptyFullModIface gHC_PRIM
fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)
: mapMaybe mkFixity allThePrimOps
mkFixity op = (,) (primOpOcc op) <$> primOpFixity op
ifaceStats :: ExternalPackageState -> SDoc
ifaceStats eps
= hcat [text "Renamer stats: ", msg]
where
stats = eps_stats eps
msg = vcat
[int (n_ifaces_in stats) <+> text "interfaces read",
hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
int (n_decls_in stats), text "read"],
hsep [ int (n_insts_out stats), text "instance decls imported, out of",
int (n_insts_in stats), text "read"],
hsep [ int (n_rules_out stats), text "rule decls imported, out of",
int (n_rules_in stats), text "read"]
]
showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO ()
showIface logger dflags unit_state name_cache filename = do
let profile = targetProfile dflags
printer = logMsg logger MCOutput noSrcSpan . withPprStyle defaultDumpStyle
iface <- readBinIface profile name_cache IgnoreHiWay (TraceBinIFace printer) filename
let
qualifyImportedNames mod _
| mod == mi_module iface = NameUnqual
| otherwise = NameNotInScope1
print_unqual = QueryQualify qualifyImportedNames
neverQualifyModules
neverQualifyPackages
logMsg logger MCDump noSrcSpan
$ withPprStyle (mkDumpStyle print_unqual)
$ pprModIface unit_state iface
pprModIfaceSimple :: UnitState -> ModIface -> SDoc
pprModIfaceSimple unit_state iface =
ppr (mi_module iface)
$$ pprDeps unit_state (mi_deps iface)
$$ nest 2 (vcat (map pprExport (mi_exports iface)))
pprModIface :: UnitState -> ModIface -> SDoc
pprModIface unit_state iface@ModIface{ mi_final_exts = exts }
= vcat [ text "interface"
<+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)
<+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty)
<+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty)
<+> (if mi_hpc iface then text "[hpc]" else Outputable.empty)
<+> integer hiVersion
, nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts))
, nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts))
, nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts))
, nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts))
, nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts))
, nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts))
, nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts))
, nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts))
, nest 2 (text "src_hash:" <+> ppr (mi_src_hash iface))
, nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))
, nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
, nest 2 (text "where")
, text "exports:"
, nest 2 (vcat (map pprExport (mi_exports iface)))
, pprDeps unit_state (mi_deps iface)
, vcat (map pprUsage (mi_usages iface))
, vcat (map pprIfaceAnnotation (mi_anns iface))
, pprFixities (mi_fixities iface)
, vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]
, vcat (map ppr (mi_insts iface))
, vcat (map ppr (mi_fam_insts iface))
, vcat (map ppr (mi_rules iface))
, ppr (mi_warns iface)
, pprTrustInfo (mi_trust iface)
, pprTrustPkg (mi_trust_pkg iface)
, vcat (map ppr (mi_complete_matches iface))
, text "docs:" $$ nest 2 (ppr (mi_docs iface))
, text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface))
]
where
pp_hsc_src HsBootFile = text "[boot]"
pp_hsc_src HsigFile = text "[hsig]"
pp_hsc_src HsSrcFile = Outputable.empty
pprExport :: IfaceExport -> SDoc
pprExport (Avail n) = ppr n
pprExport (AvailTC _ []) = Outputable.empty
pprExport avail@(AvailTC n _) =
ppr n <> mark <> pp_export (availSubordinateGreNames avail)
where
mark | availExportsDecl avail = Outputable.empty
| otherwise = vbar
pp_export [] = Outputable.empty
pp_export names = braces (hsep (map ppr names))
pprUsage :: Usage -> SDoc
pprUsage usage@UsagePackageModule{}
= pprUsageImport usage usg_mod
pprUsage usage@UsageHomeModule{}
= pprUsageImport usage (\u -> mkModule (usg_unit_id u) (usg_mod_name u)) $$
nest 2 (
maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
)
pprUsage usage@UsageFile{}
= hsep [text "addDependentFile",
doubleQuotes (text (usg_file_path usage)),
ppr (usg_file_hash usage)]
pprUsage usage@UsageMergedRequirement{}
= hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
pprUsage usage@UsageHomeModuleInterface{}
= hsep [text "implementation", ppr (usg_mod_name usage)
, ppr (usg_unit_id usage)
, ppr (usg_iface_hash usage)]
pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
pprUsageImport usage usg_mod'
= hsep [text "import", safe, ppr (usg_mod' usage),
ppr (usg_mod_hash usage)]
where
safe | usg_safe usage = text "safe"
| otherwise = text " -/ "
pprFixities :: [(OccName, Fixity)] -> SDoc
pprFixities [] = Outputable.empty
pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes
where
pprFix (occ,fix) = ppr fix <+> ppr occ
pprTrustInfo :: IfaceTrustInfo -> SDoc
pprTrustInfo trust = text "trusted:" <+> ppr trust
pprTrustPkg :: Bool -> SDoc
pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg
instance Outputable (Warnings pass) where
ppr = pprWarns
pprWarns :: Warnings pass -> SDoc
pprWarns NoWarnings = Outputable.empty
pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt
pprWarns (WarnSome prs) = text "Warnings:"
<+> vcat (map pprWarning prs)
where pprWarning (name, txt) = ppr name <+> ppr txt
pprIfaceAnnotation :: IfaceAnnotation -> SDoc
pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
= ppr target <+> text "annotated by" <+> ppr serialized
pprExtensibleFields :: ExtensibleFields -> SDoc
pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs
where
pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes"