module GHC.Iface.Load (
tcLookupImported_maybe, importDecl,
checkWiredInTyCon, ifCheckWiredInThing,
loadModuleInterface, loadModuleInterfaces,
loadSrcInterface, loadSrcInterface_maybe,
loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,
loadInterface,
loadSysInterface, loadUserInterface, loadPluginInterface,
findAndReadIface, readIface, writeIface,
loadDecls,
initExternalPackageState,
moduleFreeHolesPrecise,
needWiredInHomeIface, loadWiredInHomeIface,
pprModIfaceSimple,
ifaceStats, pprModIface, showIface
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.IfaceToCore
( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst
, tcIfaceAnnotations, tcIfaceCompleteSigs )
import GHC.Driver.Session
import GHC.Iface.Syntax
import GHC.Iface.Env
import GHC.Driver.Types
import GHC.Types.Basic hiding (SuccessFlag(..))
import GHC.Tc.Utils.Monad
import GHC.Utils.Binary ( BinData(..) )
import GHC.Settings.Constants
import GHC.Builtin.Names
import GHC.Builtin.Utils
import GHC.Builtin.PrimOps ( allThePrimOps, primOpFixity, primOpOcc )
import GHC.Types.Id.Make ( seqId, EnableBignumRules(..) )
import GHC.Core.Rules
import GHC.Core.TyCon
import GHC.Types.Annotations
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Avail
import GHC.Unit.Module
import GHC.Unit.State
import GHC.Data.Maybe
import GHC.Utils.Error
import GHC.Driver.Finder
import GHC.Types.Unique.FM
import GHC.Types.SrcLoc
import GHC.Utils.Outputable as Outputable
import GHC.Iface.Binary
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Utils.Fingerprint
import GHC.Driver.Hooks
import GHC.Types.FieldLabel
import GHC.Iface.Rename
import GHC.Types.Unique.DSet
import GHC.Driver.Plugins
import Control.Monad
import Control.Exception
import Data.IORef
import Data.Map ( toList )
import System.FilePath
import System.Directory
tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)
tcLookupImported_maybe name
= do { hsc_env <- getTopEnv
; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
; case mb_thing of
Just thing -> return (Succeeded thing)
Nothing -> tcImportDecl_maybe name }
tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc 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 MsgDoc TyThing)
importDecl name
= ASSERT( not (isWiredInName name) )
do { traceIf nd_doc
; mb_iface <- ASSERT2( 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 $ nameEnvElts $ 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
; traceIf (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
; ASSERT2( isExternalName name, ppr name )
when (needWiredInHomeIface thing && mod /= nameModule name)
(loadWiredInHomeIface name) }
needWiredInHomeIface :: TyThing -> Bool
needWiredInHomeIface (ATyCon {}) = True
needWiredInHomeIface _ = False
loadSrcInterface :: SDoc
-> ModuleName
-> IsBootInterface
-> Maybe FastString
-> 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 err
Succeeded iface -> return iface }
loadSrcInterface_maybe :: SDoc
-> ModuleName
-> IsBootInterface
-> Maybe FastString
-> RnM (MaybeErr MsgDoc 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_dflags 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
; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }
; ASSERT2( isExternalName name, ppr name )
initIfaceTcRn $ loadSysInterface doc (nameModule name) }
loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)
loadInterfaceForNameMaybe doc name
= do { this_mod <- getModule
; if nameIsLocalOrFrom this_mod name || not (isExternalName name)
then return Nothing
else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))
}
loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface
loadInterfaceForModule doc m
= do
when debugIsOn $ do
this_mod <- getModule
MASSERT2( 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
= withException (loadInterface doc mod_name where_from)
loadInterface :: SDoc -> Module -> WhereFrom
-> IfM lcl (MaybeErr MsgDoc ModIface)
loadInterface doc_str mod from
| isHoleModule mod
= do dflags <- getDynFlags
loadInterface doc_str (mkHomeModule dflags (moduleName mod)) from
| otherwise
= withTimingSilentD (text "loading interface") (pure ()) $
do {
(eps,hpt) <- getEpsAndHpt
; gbl_env <- getGblEnv
; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)
; dflags <- getDynFlags
; case lookupIfaceByModule hpt (eps_PIT eps) mod of {
Just iface
-> return (Succeeded iface) ;
_ -> do {
; read_result <- case (wantHiBootFile dflags eps mod from) of
Failed err -> return (Failed err)
Succeeded hi_boot_file -> computeInterface 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) $ do
dontLeakTheHPT $ do
; ignore_prags <- goptM Opt_IgnoreInterfacePragmas
; new_eps_decls <- loadDecls 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_sigs <- tcIfaceCompleteSigs (mi_complete_sigs 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 && fmap fst (if_rec_types gbl_env) == Just mod
; WARN( bad_boot, ppr mod )
updateEps_ $ \ eps ->
if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags 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
= extendCompleteMatchMap
(eps_complete_matches eps)
new_eps_complete_sigs,
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 dflags (\p -> interfaceLoadAction p) iface
; return (Succeeded res)
}}}}
dontLeakTheHPT :: IfL a -> IfL a
dontLeakTheHPT thing_inside = do
let
cleanTopEnv HscEnv{..} =
let
!hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT
| otherwise = emptyHomePackageTable
in
HscEnv { hsc_targets = panic "cleanTopEnv: hsc_targets"
, hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph"
, hsc_IC = panic "cleanTopEnv: hsc_IC"
, hsc_HPT = hpt
, .. }
updTopEnv cleanTopEnv $ do
!_ <- getTopEnv
thing_inside
is_external_sig :: DynFlags -> ModIface -> Bool
is_external_sig dflags iface =
mi_semantic_module iface /= mi_module iface &&
moduleUnit (mi_module iface) /= homeUnit dflags
computeInterface ::
SDoc -> IsBootInterface -> Module
-> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
computeInterface doc_str hi_boot_file mod0 = do
MASSERT( not (isHoleModule mod0) )
dflags <- getDynFlags
case getModuleInstantiation mod0 of
(imod, Just indef) | homeUnitIsIndefinite dflags -> do
r <- findAndReadIface doc_str imod mod0 hi_boot_file
case r of
Succeeded (iface0, path) -> do
hsc_env <- getTopEnv
r <- liftIO $
rnModIface hsc_env (instUnitInsts (moduleUnit indef))
Nothing iface0
case r of
Right x -> return (Succeeded (x, path))
Left errs -> liftIO . throwIO . mkSrcErr $ errs
Failed err -> return (Failed err)
(mod, _) ->
findAndReadIface doc_str mod mod0 hi_boot_file
moduleFreeHolesPrecise
:: SDoc -> Module
-> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))
moduleFreeHolesPrecise doc_str mod
| moduleIsDefinite mod = return (Succeeded emptyUniqDSet)
| otherwise =
case getModuleInstantiation mod of
(imod, Just indef) -> do
let insts = instUnitInsts (moduleUnit indef)
traceIf (text "Considering whether to load" <+> ppr mod <+>
text "to compute precise free module holes")
(eps, hpt) <- getEpsAndHpt
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
mb_iface <- findAndReadIface (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 :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
-> MaybeErr MsgDoc IsBootInterface
wantHiBootFile dflags eps mod from
= case from of
ImportByUser usr_boot
| usr_boot == IsBoot && not this_package
-> Failed (badSourceImport mod)
| otherwise -> Succeeded usr_boot
ImportByPlugin
-> Succeeded NotBoot
ImportBySystem
| not this_package
-> Succeeded NotBoot
| otherwise
-> case lookupUFM (eps_is_boot eps) (moduleName mod) of
Just (GWIB { gwib_isBoot = is_boot }) ->
Succeeded is_boot
Nothing ->
Succeeded NotBoot
where
this_package = homeUnit dflags == moduleUnit mod
badSourceImport :: Module -> SDoc
badSourceImport mod
= hang (text "You cannot {-# SOURCE #-} import a module from another package")
2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package")
<+> quotes (ppr (moduleUnit mod)))
addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
addDeclsToPTE pte things = extendNameEnvList pte things
loadDecls :: Bool
-> [(Fingerprint, IfaceDecl)]
-> IfL [(Name,TyThing)]
loadDecls ignore_prags ver_decls
= concatMapM (loadDecl ignore_prags) ver_decls
loadDecl :: Bool
-> (Fingerprint, IfaceDecl)
-> IfL [(Name,TyThing)]
loadDecl ignore_prags (_version, decl)
= do {
let main_name = ifName decl
; thing <- forkM doc $ do { bumpDeclStats main_name
; tcIfaceDecl ignore_prags decl }
; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
lookup n = case lookupOccEnv mini_env (getOccName n) of
Just thing -> thing
Nothing ->
pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)
; return $ (main_name, thing) :
[(n, lookup n) | n <- implicit_names]
}
where
doc = text "Declaration for" <+> ppr (ifName decl)
bumpDeclStats :: Name -> IfL ()
bumpDeclStats name
= do { traceIf (text "Loading decl for" <+> ppr name)
; updateEps_ (\eps -> let stats = eps_stats eps
in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
}
findAndReadIface :: SDoc
-> InstalledModule
-> Module
-> IsBootInterface
-> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file
= do traceIf (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
iface <- getHooked ghcPrimIfaceHook ghcPrimIface
return (Succeeded (iface,
"<built in interface for GHC.Prim>"))
else do
dflags <- getDynFlags
hsc_env <- getTopEnv
mb_found <- liftIO (findExactModule hsc_env mod)
case mb_found of
InstalledFound loc mod -> do
let file_path = addBootSuffix_maybe hi_boot_file
(ml_hi_file loc)
if moduleUnit mod `unitIdEq` homeUnit dflags &&
not (isOneShot (ghcMode dflags))
then return (Failed (homeModError mod loc))
else do r <- read_file file_path
checkBuildDynamicToo r
return r
err -> do
traceIf (text "...not found")
dflags <- getDynFlags
return (Failed (cannotFindInterface dflags
(moduleName mod) err))
where read_file file_path = do
traceIf (text "readIFace" <+> text file_path)
dflags <- getDynFlags
let wanted_mod =
case getModuleInstantiation wanted_mod_with_insts of
(_, Nothing) -> wanted_mod_with_insts
(_, Just indef_mod) ->
instModuleToModule (unitState dflags)
(uninstantiateInstantiatedModule indef_mod)
read_result <- readIface wanted_mod file_path
case read_result of
Failed err -> return (Failed (badIfaceFile file_path err))
Succeeded iface -> return (Succeeded (iface, file_path))
checkBuildDynamicToo (Succeeded (iface, filePath)) = do
dflags <- getDynFlags
let is_definite_iface = moduleIsDefinite (mi_module iface)
when is_definite_iface $
whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do
let ref = canGenerateDynamicToo dflags
dynFilePath = addBootSuffix_maybe hi_boot_file
$ replaceExtension filePath (dynHiSuf dflags)
r <- read_file dynFilePath
case r of
Succeeded (dynIface, _)
| mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->
return ()
| otherwise ->
do traceIf (text "Dynamic hash doesn't match")
liftIO $ writeIORef ref False
Failed err ->
do traceIf (text "Failed to load dynamic interface file:" $$ err)
liftIO $ writeIORef ref False
checkBuildDynamicToo _ = return ()
writeIface :: DynFlags -> FilePath -> ModIface -> IO ()
writeIface dflags hi_file_path new_iface
= do createDirectoryIfMissing True (takeDirectory hi_file_path)
writeBinIface dflags hi_file_path new_iface
readIface :: Module -> FilePath
-> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
readIface wanted_mod file_path
= do { res <- tryMostM $
readBinIface CheckHiWay QuietBinIFaceReading 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)))
}
initExternalPackageState :: DynFlags -> ExternalPackageState
initExternalPackageState dflags
= EPS {
eps_is_boot = emptyUFM,
eps_PIT = emptyPackageIfaceTable,
eps_free_holes = emptyInstalledModuleEnv,
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
eps_fam_inst_env = emptyFamInstEnv,
eps_rule_base = mkRuleBase builtinRules',
eps_mod_fam_inst_env
= emptyModuleEnv,
eps_complete_matches = emptyUFM,
eps_ann_env = emptyAnnEnv,
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
, n_insts_in = 0, n_insts_out = 0
, n_rules_in = length builtinRules', n_rules_out = 0 }
}
where
enableBignumRules
| homeUnitId dflags == primUnitId = EnableBignumRules False
| homeUnitId dflags == bignumUnitId = EnableBignumRules False
| otherwise = EnableBignumRules True
builtinRules' = builtinRules enableBignumRules
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_decl_docs = 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 :: HscEnv -> FilePath -> IO ()
showIface hsc_env filename = do
iface <- initTcRnIf 's' hsc_env () () $
readBinIface IgnoreHiWay TraceBinIFaceReading filename
let dflags = hsc_dflags hsc_env
qualifyImportedNames mod _
| mod == mi_module iface = NameUnqual
| otherwise = NameNotInScope1
print_unqual = QueryQualify qualifyImportedNames
neverQualifyModules
neverQualifyPackages
putLogMsg dflags NoReason SevDump noSrcSpan
$ withPprStyle (mkDumpStyle print_unqual) (pprModIface iface)
pprModIfaceSimple :: ModIface -> SDoc
pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))
pprModIface :: ModIface -> SDoc
pprModIface 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 "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 (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_sigs iface))
, text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))
, text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))
, text "arg docs:" $$ nest 2 (ppr (mi_arg_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 (AvailTC n ns0 fs)
= case ns0 of
(n':ns) | n==n' -> ppr n <> pp_export ns fs
_ -> ppr n <> vbar <> pp_export ns0 fs
where
pp_export [] [] = Outputable.empty
pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))
pprUsage :: Usage -> SDoc
pprUsage usage@UsagePackageModule{}
= pprUsageImport usage usg_mod
pprUsage usage@UsageHomeModule{}
= pprUsageImport usage usg_mod_name $$
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)]
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 " -/ "
pprDeps :: Dependencies -> SDoc
pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
dep_finsts = finsts })
= vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),
text "package dependencies:" <+> fsep (map ppr_pkg pkgs),
text "orphans:" <+> fsep (map ppr orphs),
text "family instance modules:" <+> fsep (map ppr finsts)
]
where
ppr_mod (GWIB { gwib_mod = mod_name, gwib_isBoot = boot }) = ppr mod_name <+> ppr_boot boot
ppr_pkg (pkg,trust_req) = ppr pkg <>
(if trust_req then text "*" else Outputable.empty)
ppr_boot IsBoot = text "[boot]"
ppr_boot NotBoot = Outputable.empty
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 where
ppr = pprWarns
pprWarns :: Warnings -> 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"
badIfaceFile :: String -> SDoc -> SDoc
badIfaceFile file err
= vcat [text "Bad interface file:" <+> text file,
nest 4 err]
hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc
hiModuleNameMismatchWarn requested_mod read_mod
| moduleUnit requested_mod == moduleUnit read_mod =
sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,
text "but we were expecting module" <+> quotes (ppr requested_mod),
sep [text "Probable cause: the source code which generated interface file",
text "has an incompatible module name"
]
]
| otherwise =
withPprStyle (mkUserStyle alwaysQualify AllTheWay) $
hsep [ text "Something is amiss; requested module "
, ppr requested_mod
, text "differs from name found in the interface file"
, ppr read_mod
, parens (text "if these names look the same, try again with -dppr-debug")
]
homeModError :: InstalledModule -> ModLocation -> SDoc
homeModError mod location
= text "attempting to use module " <> quotes (ppr mod)
<> (case ml_hs_file location of
Just file -> space <> parens (text file)
Nothing -> Outputable.empty)
<+> text "which is not loaded"