%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 19921998
%
Loading interface files
\begin{code}
module LoadIface (
loadInterface, loadInterfaceForName, loadWiredInHomeIface,
loadSrcInterface, loadSysInterface, loadUserInterface, loadOrphanModules,
findAndReadIface, readIface,
loadDecls,
initExternalPackageState,
ifaceStats, pprModIface, showIface
) where
#include "HsVersions.h"
import TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations )
import DynFlags
import IfaceSyn
import IfaceEnv
import HscTypes
import BasicTypes hiding (SuccessFlag(..))
import TcRnMonad
import PrelNames
import PrelInfo
import PrelRules
import Rules
import Annotations
import InstEnv
import FamInstEnv
import Name
import NameEnv
import Module
import Maybes
import ErrUtils
import Finder
import LazyUniqFM
import StaticFlags
import Outputable
import BinIface
import Panic
import Util
import FastString
import Fingerprint
import Control.Monad
\end{code}
%************************************************************************
%* *
loadSrcInterface, loadOrphanModules, loadHomeInterface
These three are called from TcMland
%* *
%************************************************************************
\begin{code}
loadSrcInterface :: SDoc
-> ModuleName
-> IsBootInterface
-> Maybe FastString
-> RnM ModIface
loadSrcInterface doc mod want_boot maybe_pkg = do
hsc_env <- getTopEnv
res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
case res of
Found _ mod -> do
mb_iface <- initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
case mb_iface of
Failed err -> failWithTc err
Succeeded iface -> return iface
err ->
let dflags = hsc_dflags hsc_env in
failWithTc (cannotFindInterface dflags mod err)
loadOrphanModules :: [Module]
-> Bool
-> TcM ()
loadOrphanModules mods isFamInstMod
| null mods = return ()
| otherwise = initIfaceTcRn $
do { traceIf (text "Loading orphan modules:" <+>
fsep (map ppr mods))
; mapM_ load mods
; return () }
where
load mod = loadSysInterface (mk_doc mod) mod
mk_doc mod
| isFamInstMod = ppr mod <+> ptext (sLit "is a family-instance module")
| otherwise = ppr mod <+> ptext (sLit "is a orphan-instance module")
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)
}
loadWiredInHomeIface :: Name -> IfM lcl ()
loadWiredInHomeIface name
= ASSERT( isWiredInName name )
do _ <- loadSysInterface doc (nameModule name); return ()
where
doc = ptext (sLit "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 :: Bool -> SDoc -> Module -> IfM lcl ModIface
loadUserInterface is_boot doc mod_name = loadInterfaceWithException doc mod_name (ImportByUser is_boot)
loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
loadInterfaceWithException doc mod_name where_from
= do { mb_iface <- loadInterface doc mod_name where_from
; case mb_iface of
Failed err -> ghcError (ProgramError (showSDoc err))
Succeeded iface -> return iface }
\end{code}
%*********************************************************
%* *
loadInterface
The main function to load an interface
for an imported module, and put it in
the External Package State
%* *
%*********************************************************
\begin{code}
loadInterface :: SDoc -> Module -> WhereFrom
-> IfM lcl (MaybeErr Message ModIface)
loadInterface doc_str mod from
= do {
(eps,hpt) <- getEpsAndHpt
; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)
; dflags <- getDOpts
; case lookupIfaceByModule dflags 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 -> findAndReadIface doc_str mod hi_boot_file
; case read_result of {
Failed err -> do
{ let fake_iface = emptyModIface mod
; updateEps_ $ \eps ->
eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
; return (Failed err) } ;
Succeeded (iface, file_path) ->
let
loc_doc = text file_path
in
initIfaceLcl mod loc_doc $ do
; ignore_prags <- doptM 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_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls)
(mi_vect_info 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"
}
}
; updateEps_ $ \ eps ->
if elemModuleEnv mod (eps_PIT eps) then eps 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_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_vect_info = plusVectInfo (eps_vect_info eps)
new_eps_vect_info,
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) }
; return (Succeeded final_iface)
}}}}
wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
-> MaybeErr Message IsBootInterface
wantHiBootFile dflags eps mod from
= case from of
ImportByUser usr_boot
| usr_boot && not this_package
-> Failed (badSourceImport mod)
| otherwise -> Succeeded usr_boot
ImportBySystem
| not this_package
-> Succeeded False
| otherwise
-> case lookupUFM (eps_is_boot eps) (moduleName mod) of
Just (_, is_boot) -> Succeeded is_boot
Nothing -> Succeeded False
where
this_package = thisPackage dflags == modulePackageId mod
badSourceImport :: Module -> SDoc
badSourceImport mod
= hang (ptext (sLit "You cannot {-# SOURCE #-} import a module from another package"))
2 (ptext (sLit "but") <+> quotes (ppr mod) <+> ptext (sLit "is from package")
<+> quotes (ppr (modulePackageId mod)))
\end{code}
\begin{code}
addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
addDeclsToPTE pte things = extendNameEnvList pte things
loadDecls :: Bool
-> [(Fingerprint, IfaceDecl)]
-> IfL [(Name,TyThing)]
loadDecls ignore_prags ver_decls
= do { mod <- getIfModule
; thingss <- mapM (loadDecl ignore_prags mod) ver_decls
; return (concat thingss)
}
loadDecl :: Bool
-> Module
-> (Fingerprint, IfaceDecl)
-> IfL [(Name,TyThing)]
loadDecl ignore_prags mod (_version, decl)
= do {
main_name <- lookupOrig mod (ifName decl)
; implicit_names <- mapM (lookupOrig mod) (ifaceDeclSubBndrs 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))
; return $ (main_name, thing) :
[(n, lookup n) | n <- implicit_names]
}
where
doc = ptext (sLit "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 } })
}
\end{code}
%*********************************************************
%* *
\subsection{Reading an interface file}
%* *
%*********************************************************
\begin{code}
findAndReadIface :: SDoc -> Module
-> IsBootInterface
-> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))
findAndReadIface doc_str mod hi_boot_file
= do { traceIf (sep [hsep [ptext (sLit "Reading"),
if hi_boot_file
then ptext (sLit "[boot]")
else empty,
ptext (sLit "interface for"),
ppr mod <> semi],
nest 4 (ptext (sLit "reason:") <+> doc_str)])
; dflags <- getDOpts
; if mod == gHC_PRIM
then return (Succeeded (ghcPrimIface,
"<built in interface for GHC.Prim>"))
else do
; hsc_env <- getTopEnv
; mb_found <- liftIO (findExactModule hsc_env mod)
; case mb_found of {
Found loc mod -> do
{ let { file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) }
; if thisPackage dflags == modulePackageId mod
&& not (isOneShot (ghcMode dflags))
then return (Failed (homeModError mod loc))
else do {
; traceIf (ptext (sLit "readIFace") <+> text file_path)
; read_result <- readIface mod file_path hi_boot_file
; case read_result of
Failed err -> return (Failed (badIfaceFile file_path err))
Succeeded iface
| mi_module iface /= mod ->
return (Failed (wrongIfaceModErr iface mod file_path))
| otherwise ->
return (Succeeded (iface, file_path))
}}
; err -> do
{ traceIf (ptext (sLit "...not found"))
; dflags <- getDOpts
; return (Failed (cannotFindInterface dflags
(moduleName mod) err)) }
}
}
\end{code}
@readIface@ tries just the one file.
\begin{code}
readIface :: Module -> FilePath -> IsBootInterface
-> TcRnIf gbl lcl (MaybeErr Message 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)))
}
\end{code}
%*********************************************************
%* *
Wiredin interface for GHC.Prim
%* *
%*********************************************************
\begin{code}
initExternalPackageState :: ExternalPackageState
initExternalPackageState
= EPS {
eps_is_boot = emptyUFM,
eps_PIT = emptyPackageIfaceTable,
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
eps_fam_inst_env = emptyFamInstEnv,
eps_rule_base = mkRuleBase builtinRules,
eps_mod_fam_inst_env
= emptyModuleEnv,
eps_vect_info = noVectInfo,
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 }
}
\end{code}
%*********************************************************
%* *
Wiredin interface for GHC.Prim
%* *
%*********************************************************
\begin{code}
ghcPrimIface :: ModIface
ghcPrimIface
= (emptyModIface gHC_PRIM) {
mi_exports = [(gHC_PRIM, ghcPrimExports)],
mi_decls = [],
mi_fixities = fixities,
mi_fix_fn = mkIfaceFixCache fixities
}
where
fixities = [(getOccName seqId, Fixity 0 InfixR)]
\end{code}
%*********************************************************
%* *
\subsection{Statistics}
%* *
%*********************************************************
\begin{code}
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"]
]
\end{code}
%************************************************************************
%* *
Printing interfaces
%* *
%************************************************************************
\begin{code}
showIface :: HscEnv -> FilePath -> IO ()
showIface hsc_env filename = do
iface <- initTcRnIf 's' hsc_env () () $
readBinIface IgnoreHiWay TraceBinIFaceReading filename
printDump (pprModIface iface)
\end{code}
\begin{code}
pprModIface :: ModIface -> SDoc
pprModIface iface
= vcat [ ptext (sLit "interface")
<+> ppr (mi_module iface) <+> pp_boot
<+> (if mi_orphan iface then ptext (sLit "[orphan module]") else empty)
<+> (if mi_finsts iface then ptext (sLit "[family instance module]") else empty)
<+> (if mi_hpc iface then ptext (sLit "[hpc]") else empty)
<+> integer opt_HiVersion
, nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))
, nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
, nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
, nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
, nest 2 (ptext (sLit "where"))
, 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 (map pprIfaceDecl (mi_decls iface))
, vcat (map ppr (mi_insts iface))
, vcat (map ppr (mi_fam_insts iface))
, vcat (map ppr (mi_rules iface))
, pprVectInfo (mi_vect_info iface)
, ppr (mi_warns iface)
]
where
pp_boot | mi_boot iface = ptext (sLit "[boot]")
| otherwise = empty
\end{code}
When printing export lists, we print like this:
Avail f f
AvailTC C [C, x, y] C(x,y)
AvailTC C [x, y] C!(x,y)
\begin{code}
pprExport :: IfaceExport -> SDoc
pprExport (mod, items)
= hsep [ ptext (sLit "export"), ppr mod, hsep (map pp_avail items) ]
where
pp_avail :: GenAvailInfo OccName -> SDoc
pp_avail (Avail occ) = ppr occ
pp_avail (AvailTC _ []) = empty
pp_avail (AvailTC n (n':ns))
| n==n' = ppr n <> pp_export ns
| otherwise = ppr n <> char '|' <> pp_export (n':ns)
pp_export [] = empty
pp_export names = braces (hsep (map ppr names))
pprUsage :: Usage -> SDoc
pprUsage usage@UsagePackageModule{}
= hsep [ptext (sLit "import"), ppr (usg_mod usage),
ppr (usg_mod_hash usage)]
pprUsage usage@UsageHomeModule{}
= hsep [ptext (sLit "import"), ppr (usg_mod_name usage),
ppr (usg_mod_hash usage)] $$
nest 2 (
maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
)
pprDeps :: Dependencies -> SDoc
pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
dep_finsts = finsts })
= vcat [ptext (sLit "module dependencies:") <+> fsep (map ppr_mod mods),
ptext (sLit "package dependencies:") <+> fsep (map ppr pkgs),
ptext (sLit "orphans:") <+> fsep (map ppr orphs),
ptext (sLit "family instance modules:") <+> fsep (map ppr finsts)
]
where
ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
ppr_boot True = text "[boot]"
ppr_boot False = empty
pprIfaceDecl :: (Fingerprint, IfaceDecl) -> SDoc
pprIfaceDecl (ver, decl)
= ppr ver $$ nest 2 (ppr decl)
pprFixities :: [(OccName, Fixity)] -> SDoc
pprFixities [] = empty
pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes
where
pprFix (occ,fix) = ppr fix <+> ppr occ
pprVectInfo :: IfaceVectInfo -> SDoc
pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars
, ifaceVectInfoTyCon = tycons
, ifaceVectInfoTyConReuse = tyconsReuse
}) =
vcat
[ ptext (sLit "vectorised variables:") <+> hsep (map ppr vars)
, ptext (sLit "vectorised tycons:") <+> hsep (map ppr tycons)
, ptext (sLit "vectorised reused tycons:") <+> hsep (map ppr tyconsReuse)
]
instance Outputable Warnings where
ppr = pprWarns
pprWarns :: Warnings -> SDoc
pprWarns NoWarnings = empty
pprWarns (WarnAll txt) = ptext (sLit "Warn all") <+> ppr txt
pprWarns (WarnSome prs) = ptext (sLit "Warnings")
<+> vcat (map pprWarning prs)
where pprWarning (name, txt) = ppr name <+> ppr txt
pprIfaceAnnotation :: IfaceAnnotation -> SDoc
pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
= ppr target <+> ptext (sLit "annotated by") <+> ppr serialized
\end{code}
%*********************************************************
%* *
\subsection{Errors}
%* *
%*********************************************************
\begin{code}
badIfaceFile :: String -> SDoc -> SDoc
badIfaceFile file err
= vcat [ptext (sLit "Bad interface file:") <+> text file,
nest 4 err]
hiModuleNameMismatchWarn :: Module -> Module -> Message
hiModuleNameMismatchWarn requested_mod read_mod =
withPprStyle defaultUserStyle $
hsep [ ptext (sLit "Something is amiss; requested module ")
, ppr requested_mod
, ptext (sLit "differs from name found in the interface file")
, ppr read_mod
]
wrongIfaceModErr :: ModIface -> Module -> String -> SDoc
wrongIfaceModErr iface mod_name file_path
= sep [ptext (sLit "Interface file") <+> iface_file,
ptext (sLit "contains module") <+> quotes (ppr (mi_module iface)) <> comma,
ptext (sLit "but we were expecting module") <+> quotes (ppr mod_name),
sep [ptext (sLit "Probable cause: the source code which generated"),
nest 2 iface_file,
ptext (sLit "has an incompatible module name")
]
]
where iface_file = doubleQuotes (text file_path)
homeModError :: Module -> ModLocation -> SDoc
homeModError mod location
= ptext (sLit "attempting to use module ") <> quotes (ppr mod)
<> (case ml_hs_file location of
Just file -> space <> parens (text file)
Nothing -> empty)
<+> ptext (sLit "which is not loaded")
\end{code}