\begin{code}
module LoadIface (
- loadHomeInterface, loadInterface, loadSysInterface,
+ loadHomeInterface, loadInterface,
loadSrcInterface, loadOrphanModules,
readIface, -- Used when reading the module's old interface
- predInstGates, ifaceInstGates, ifaceStats,
+ predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags,
initExternalPackageState
) where
opt_InPackage )
import Parser ( parseIface )
-import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceInst(..),
- IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..),
- IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName )
+import IfaceSyn ( IfaceDecl(..), IfaceConDecls(..), IfaceConDecl(..), IfaceClassOp(..),
+ IfaceInst(..), IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..),
+ IfaceType(..), IfacePredType(..), IfaceExtName, visibleIfConDecls, mkIfaceExtName )
import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc )
import HscTypes ( HscEnv(..), ModIface(..), emptyModIface,
ExternalPackageState(..), emptyTypeEnv, emptyPool,
lookupIfaceByModName, emptyPackageIfaceTable,
IsBootInterface, mkIfaceFixCache,
Pool(..), DeclPool, InstPool,
- RulePool, Gated, addRuleToPool, RulePoolContents
+ RulePool, addRuleToPool, RulePoolContents
)
import BasicTypes ( Version, Fixity(..), FixityDirection(..) )
mkSuperDictSelOcc,
mkDataConWrapperOcc, mkDataConWorkerOcc )
import Class ( Class, className )
-import TyCon ( DataConDetails(..), tyConName )
+import TyCon ( tyConName )
import SrcLoc ( mkSrcLoc, importedSrcLoc )
import Maybes ( isJust, mapCatMaybes )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
-import ErrUtils ( Message )
+import ErrUtils ( Message, mkLocMessage )
import Finder ( findModule, findPackageModule,
hiBootExt, hiBootVerExt )
import Lexer
\begin{code}
loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -> RnM ModIface
-- This is called for each 'import' declaration in the source code
--- On a failure, fail in the mnad with an error message
+-- On a failure, fail in the monad with an error message
loadSrcInterface doc mod_name want_boot
= do { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name
-> returnM (Right iface) ; -- Already loaded
-- The (src_imp == mi_boot iface) test checks that the already-loaded
-- interface isn't a boot iface. This can conceivably happen,
- -- if an earlier import had a
- -- before we got to real imports. I think.
+ -- if an earlier import had a before we got to real imports. I think.
other -> do
{ if_gbl_env <- getGblEnv
; let { hi_boot_file = case from of
ImportByUser usr_boot -> usr_boot
- ImportBySystem -> sys_boot
+ ImportBySystem -> sys_boot
; mb_dep = lookupModuleEnvByName (if_is_boot if_gbl_env) mod_name
; sys_boot = case mb_dep of
WARN( case from of { ImportBySystem -> True; other -> False } &&
not (isJust mb_dep) &&
isHomeModule mod,
- ppr mod )
+ ppr mod $$ ppr mb_dep)
initIfaceLcl (moduleName mod) $ do
-- Load the new ModIface into the External Package State
-- If we do loadExport first the wrong info gets into the cache (unless we
-- explicitly tag each export which seems a bit of a bore)
- { new_eps_decls <- loadDecls mod (eps_decls eps) (mi_decls iface)
- ; new_eps_insts <- loadInsts mod (eps_insts eps) (mi_insts iface)
- ; new_eps_rules <- loadRules mod (eps_rules eps) (mi_rules iface)
+ { ignore_prags <- doptM Opt_IgnoreInterfacePragmas
+ ; new_eps_decls <- loadDecls ignore_prags mod (eps_decls eps) (mi_decls iface)
+ ; new_eps_rules <- loadRules ignore_prags mod (eps_rules eps) (mi_rules iface)
+ ; new_eps_insts <- loadInsts mod (eps_insts eps) (mi_insts iface)
; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_insts in PIT",
-- the declaration itself, will find the fully-glorious Name
-----------------------------------------------------
-loadDecls :: Module -> DeclPool
+loadDecls :: Bool -- Don't load pragmas into the decl pool
+ -> Module -> DeclPool
-> [(Version, IfaceDecl)]
-> IfM lcl DeclPool
-loadDecls mod (Pool decls_map n_in n_out) decls
- = do { ignore_prags <- doptM Opt_IgnoreInterfacePragmas
- ; decls_map' <- foldlM (loadDecl ignore_prags mod) decls_map decls
+loadDecls ignore_prags mod (Pool decls_map n_in n_out) decls
+ = do { decls_map' <- foldlM (loadDecl ignore_prags mod) decls_map decls
; returnM (Pool decls_map' (n_in + length decls) n_out) }
loadDecl ignore_prags mod decls_map (_version, decl)
= do { main_name <- mk_new_bndr Nothing (ifName decl)
- ; let decl' | ignore_prags = zapIdInfo decl
+ ; let decl' | ignore_prags = discardDeclPrags decl
| otherwise = decl
-- Populate the name cache with final versions of all the subordinate names
mk_new_bndr mb_parent occ = newGlobalBinder mod occ mb_parent loc
loc = importedSrcLoc (moduleUserString mod)
-zapIdInfo decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = DiscardedInfo }
-zapIdInfo decl = decl
- -- Don't alter "NoInfo", just "HasInfo"
+discardDeclPrags :: IfaceDecl -> IfaceDecl
+discardDeclPrags decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = NoInfo }
+discardDeclPrags decl = decl
+
-----------------
ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
tc_occ = mkClassTyConOcc cls_occ
dc_occ = mkClassDataConOcc cls_occ
-ifaceDeclSubBndrs (IfaceData {ifCons = Unknown}) = []
-ifaceDeclSubBndrs (IfaceData {ifCons = DataCons cons})
- = foldr ((++) . conDeclBndrs) [] cons
-
-ifaceDeclSubBndrs other = []
+ifaceDeclSubBndrs (IfaceData {ifCons = cons}) = foldr ((++) . conDeclBndrs) []
+ (visibleIfConDecls cons)
+ifaceDeclSubBndrs other = []
-conDeclBndrs (IfaceConDecl con_occ _ _ _ _ fields)
+conDeclBndrs (IfaceConDecl con_occ _ _ _ _ _ fields)
= fields ++
[con_occ, mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ]
-- Loading Rules
-----------------------------------------------------
-loadRules :: Module -> RulePool -> [IfaceRule] -> IfL RulePool
-loadRules mod pool@(Pool rule_pool n_in n_out) rules
- = do { ignore_prags <- doptM Opt_IgnoreInterfacePragmas
- ; if ignore_prags then
- returnM pool
- else do
- { new_pool <- foldlM (loadRule (moduleName mod)) rule_pool rules
- ; returnM (Pool new_pool (n_in + length rules) n_out) } }
+loadRules :: Bool -- Don't load pragmas into the decl pool
+ -> Module -> RulePool -> [IfaceRule] -> IfL RulePool
+loadRules ignore_prags mod pool@(Pool rule_pool n_in n_out) rules
+ | ignore_prags = returnM pool
+ | otherwise
+ = do { new_pool <- foldlM (loadRule (moduleName mod)) rule_pool rules
+ ; returnM (Pool new_pool (n_in + length rules) n_out) }
loadRule :: ModuleName -> RulePoolContents -> IfaceRule -> IfL RulePoolContents
-- "Gate" the rule simply by a crude notion of the free vars of
; read_result <- readIface mod_name file_path hi_boot_file
; case read_result of
Left err -> returnM (Left (badIfaceFile file_path err))
- Right iface -> returnM (Right iface)
+ Right iface
+ | moduleName (mi_module iface) /= mod_name ->
+ return (Left (wrongIfaceModErr iface mod_name file_path))
+ | otherwise ->
+ returnM (Right iface)
}}}
findHiFile :: ModuleName -> IsBootInterface
Left exn -> return (Left (text (showException exn))) ;
Right buffer ->
case unP parseIface (mkPState buffer loc dflags) of
- PFailed loc1 loc2 err -> return (Left (showPFailed loc1 loc2 err))
+ PFailed span err -> return (Left (mkLocMessage span err))
POk _ iface
| wanted_mod == actual_mod -> return (Right iface)
| otherwise -> return (Left err)
text "(use -v to see a list of the files searched for)"
| otherwise =
hang (ptext SLIT("locations searched:")) 4 (vcat (map text files))
+
+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)
\end{code}
projects / ghc-hetmet.git / blobdiff