X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnIfaces.lhs;h=08e7fb9948c974abf8efd3e240eb3753d9246273;hb=a237946da277f10bd3d223e5926d118044d24194;hp=d15cd2526e722d6f836d1d9943b0f6d65a2628f1;hpb=6c872fff42025a842e8500ddbb13fdcca60eaf75;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index d15cd25..08e7fb9 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -5,13 +5,15 @@ \begin{code} module RnIfaces ( - getInterfaceExports, + findAndReadIface, + + getInterfaceExports, getDeferredDecls, getImportedInstDecls, getImportedRules, - lookupFixity, loadHomeInterface, - importDecl, recordSlurp, - getImportVersions, getSlurped, + lookupFixityRn, loadHomeInterface, + importDecl, ImportDeclResult(..), recordLocalSlurps, loadBuiltinRules, + mkImportExportInfo, getSlurped, - checkUpToDate, + checkModUsage, outOfDate, upToDate, getDeclBinders, getDeclSysBinders, removeContext -- removeContext probably belongs somewhere else @@ -19,58 +21,48 @@ module RnIfaces ( #include "HsVersions.h" -import CmdLineOpts ( opt_NoPruneDecls, opt_IgnoreIfacePragmas ) +import CmdLineOpts ( opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas ) import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..), HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..), ForeignDecl(..), ForKind(..), isDynamicExtName, FixitySig(..), RuleDecl(..), - isClassOpSig, Deprecation(..) - ) -import BasicTypes ( Version, NewOrData(..), defaultFixity ) -import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, RdrNameRuleDecl, - extractHsTyRdrNames, RdrNameDeprecation + isClassOpSig, DeprecDecl(..) ) -import RnEnv ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName, - lookupOccRn, lookupImplicitOccRn, - pprAvail, - availName, availNames, addAvailToNameSet, addSysAvails, - FreeVars, emptyFVs +import HsImpExp ( ieNames ) +import CoreSyn ( CoreRule ) +import BasicTypes ( Version, NewOrData(..) ) +import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameRuleDecl, + RdrNameDeprecation, RdrNameIE, + extractHsTyRdrNames ) +import RnEnv import RnMonad -import RnHsSyn ( RenamedHsDecl, RenamedDeprecation ) import ParseIface ( parseIface, IfaceStuff(..) ) -import FiniteMap ( FiniteMap, sizeFM, emptyFM, delFromFM, listToFM, - lookupFM, addToFM, addToFM_C, addListToFM, - fmToList, elemFM, foldFM - ) -import Name ( Name {-instance NamedThing-}, - nameModule, isLocallyDefined, - isWiredInName, nameUnique, NamedThing(..) +import Name ( Name {-instance NamedThing-}, nameOccName, + nameModule, isLocallyDefined, + isWiredInName, NamedThing(..), + elemNameEnv, extendNameEnv ) -import Module ( Module, moduleString, pprModule, - mkVanillaModule, pprModuleName, - moduleUserString, moduleName, isLibModule, +import Module ( Module, mkVanillaModule, pprModuleName, + moduleName, isLocalModule, ModuleName, WhereFrom(..), ) import RdrName ( RdrName, rdrNameOcc ) import NameSet -import Var ( Id ) import SrcLoc ( mkSrcLoc, SrcLoc ) -import PrelMods ( pREL_GHC ) import PrelInfo ( cCallishTyKeys ) -import Bag -import Maybes ( MaybeErr(..), maybeToBool, orElse ) -import ListSetOps ( unionLists ) -import Outputable -import Unique ( Unique ) -import StringBuffer ( StringBuffer, hGetStringBuffer ) +import Maybes ( maybeToBool ) +import Unique ( Uniquable(..) ) +import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) import ErrUtils ( Message ) +import Util ( sortLt ) import Lex +import FiniteMap import Outputable +import Bag -import IO ( isDoesNotExistError ) import List ( nub ) \end{code} @@ -84,60 +76,84 @@ import List ( nub ) \begin{code} loadHomeInterface :: SDoc -> Name -> RnM d Ifaces loadHomeInterface doc_str name - = loadInterface doc_str (moduleName (nameModule name)) ImportBySystem `thenRn` \ (_, ifaces) -> - returnRn ifaces + = loadInterface doc_str (moduleName (nameModule name)) ImportBySystem loadOrphanModules :: [ModuleName] -> RnM d () loadOrphanModules mods | null mods = returnRn () - | otherwise = traceRn (text "Loading orphan modules:" <+> fsep (map pprModuleName mods)) `thenRn_` - mapRn_ load mods `thenRn_` + | otherwise = traceRn (text "Loading orphan modules:" <+> + fsep (map pprModuleName mods)) `thenRn_` + mapRn_ load mods `thenRn_` returnRn () where - load mod = loadInterface (pprModuleName mod <+> ptext SLIT("is a orphan-instance module")) mod ImportBySystem + load mod = loadInterface (mk_doc mod) mod ImportBySystem + mk_doc mod = pprModuleName mod <+> ptext SLIT("is a orphan-instance module") + -loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Module, Ifaces) -loadInterface doc_str mod_name from +loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d Ifaces +loadInterface doc mod from + = tryLoadInterface doc mod from `thenRn` \ (ifaces, maybe_err) -> + case maybe_err of + Nothing -> returnRn ifaces + Just err -> failWithRn ifaces err + +tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Ifaces, Maybe Message) + -- Returns (Just err) if an error happened + -- Guarantees to return with iImpModInfo m --> (... Just cts) + -- (If the load fails, we plug in a vanilla placeholder +tryLoadInterface doc_str mod_name from = getIfacesRn `thenRn` \ ifaces -> let mod_map = iImpModInfo ifaces mod_info = lookupFM mod_map mod_name - below_me = case mod_info of - Nothing -> False - Just (_, _, is_boot, _) -> not is_boot - in - - -- Issue a warning for a redundant {- SOURCE -} import - -- It's redundant if the moduld is in the iImpModInfo at all, - -- because we arrange to read all the ordinary imports before - -- any of the {- SOURCE -} imports - warnCheckRn (not (below_me && case from of {ImportByUserSource -> True; other -> False})) - (warnRedundantSourceImport mod_name) `thenRn_` + hi_boot_file = case from of { + ImportByUser -> False ; -- Not hi-boot + ImportByUserSource -> True ; -- hi-boot + ImportBySystem -> + case mod_info of + Just (_, is_boot, _) -> is_boot + + Nothing -> False + -- We're importing a module we know absolutely + -- nothing about, so we assume it's from + -- another package, where we aren't doing + -- dependency tracking. So it won't be a hi-boot file. + } + redundant_source_import + = case (from, mod_info) of + (ImportByUserSource, Just (_,False,_)) -> True + other -> False + in -- CHECK WHETHER WE HAVE IT ALREADY case mod_info of { - Just (_, _, _, Just (load_mod, _)) + Just (_, _, Just _) -> -- We're read it already so don't re-read it - returnRn (load_mod, ifaces) ; + returnRn (ifaces, Nothing) ; - mod_map_result -> + _ -> + + -- Issue a warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports + warnCheckRn (not redundant_source_import) + (warnRedundantSourceImport mod_name) `thenRn_` -- READ THE MODULE IN - findAndReadIface doc_str mod_name from below_me - `thenRn` \ (hi_boot_read, read_result) -> + findAndReadIface doc_str mod_name hi_boot_file `thenRn` \ read_result -> case read_result of { - Nothing -> -- Not found, so add an empty export env to the Ifaces map + Left err -> -- Not found, so add an empty export env to the Ifaces map -- so that we don't look again let mod = mkVanillaModule mod_name - new_mod_map = addToFM mod_map mod_name (0, False, False, Just (mod, [])) + new_mod_map = addToFM mod_map mod_name (False, False, Just (mod, 0, 0, 0, from, [])) new_ifaces = ifaces { iImpModInfo = new_mod_map } in setIfacesRn new_ifaces `thenRn_` - failWithRn (mod, new_ifaces) (noIfaceErr mod hi_boot_read) ; + returnRn (new_ifaces, Just err) ; -- Found and parsed! - Just (mod, iface) -> + Right iface -> -- LOAD IT INTO Ifaces @@ -146,31 +162,36 @@ loadInterface doc_str mod_name from -- 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) - getModuleRn `thenRn` \ this_mod_nm -> + getModuleRn `thenRn` \ this_mod -> let - rd_decls = pi_decls iface + mod = pi_mod iface in - foldlRn (loadDecl mod) (iDecls ifaces) rd_decls `thenRn` \ new_decls -> - foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> - (if opt_IgnoreIfacePragmas - then returnRn emptyBag - else foldlRn (loadRule mod) (iRules ifaces) (pi_rules iface)) `thenRn` \ new_rules -> - (if opt_IgnoreIfacePragmas - then returnRn emptyNameEnv - else foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface)) `thenRn` \ new_deprecs -> - foldlRn (loadFixDecl mod_name) (iFixes ifaces) rd_decls `thenRn` \ new_fixities -> - mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s -> + -- Sanity check. If we're system-importing a module we know nothing at all + -- about, it should be from a different package to this one + WARN( not (maybeToBool mod_info) && + case from of { ImportBySystem -> True; other -> False } && + isLocalModule mod, + ppr mod ) + foldlRn (loadDecl mod) (iDecls ifaces) (pi_decls iface) `thenRn` \ new_decls -> + foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> + loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ new_rules -> + loadFixDecls mod_name (iFixes ifaces) (pi_fixity iface) `thenRn` \ new_fixities -> + foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface) `thenRn` \ new_deprecs -> + mapRn (loadExport this_mod) (pi_exports iface) `thenRn` \ avails_s -> let -- For an explicit user import, add to mod_map info about -- the things the imported module depends on, extracted -- from its usage info. mod_map1 = case from of - ImportByUser -> addModDeps mod mod_map (pi_usages iface) + ImportByUser -> addModDeps mod (pi_usages iface) mod_map other -> mod_map -- Now add info about this module mod_map2 = addToFM mod_map1 mod_name mod_details - mod_details = (pi_mod iface, pi_orphan iface, hi_boot_read, Just (mod, concat avails_s)) + cts = (pi_mod iface, pi_vers iface, + fst (pi_fixity iface), fst (pi_rules iface), + from, concat avails_s) + mod_details = (pi_orphan iface, hi_boot_file, Just cts) new_ifaces = ifaces { iImpModInfo = mod_map2, iDecls = new_decls, @@ -180,32 +201,47 @@ loadInterface doc_str mod_name from iDeprecs = new_deprecs } in setIfacesRn new_ifaces `thenRn_` - returnRn (mod, new_ifaces) + returnRn (new_ifaces, Nothing) }} -addModDeps :: Module -> ImportedModuleInfo - -> [ImportVersion a] -> ImportedModuleInfo -addModDeps mod mod_deps new_deps - = foldr add mod_deps new_deps +----------------------------------------------------- +-- Adding module dependencies from the +-- import decls in the interface file +----------------------------------------------------- + +addModDeps :: Module -> [ImportVersion a] + -> ImportedModuleInfo -> ImportedModuleInfo +-- (addModDeps M ivs deps) +-- We are importing module M, and M.hi contains 'import' decls given by ivs +addModDeps mod new_deps mod_deps + = foldr add mod_deps filtered_new_deps where - is_lib = isLibModule mod -- Don't record dependencies when importing a library module - add (imp_mod, version, has_orphans, is_boot, _) deps - | is_lib && not has_orphans = deps - | otherwise = addToFM_C combine deps imp_mod (version, has_orphans, is_boot, Nothing) - -- Record dependencies for modules that are - -- either are dependent via a non-library module - -- or contain orphan rules or instance decls - - -- Don't ditch a module that's already loaded - -- If it isn't loaded, and together the is_boot-ness - combine old@(_, _, _, Just _) new = old - combine old@(_, _, old_is_boot, Nothing) - new@(version, has_orphans, new_is_boot, _) - = (version, has_orphans, old_is_boot && new_is_boot, Nothing) - -loadExport :: ModuleName -> ExportItem -> RnM d [AvailInfo] + -- Don't record dependencies when importing a module from another package + -- Except for its descendents which contain orphans, + -- and in that case, forget about the boot indicator + filtered_new_deps + | isLocalModule mod = [ (imp_mod, (has_orphans, is_boot, Nothing)) + | (imp_mod, has_orphans, is_boot, _) <- new_deps + ] + | otherwise = [ (imp_mod, (True, False, Nothing)) + | (imp_mod, has_orphans, _, _) <- new_deps, + has_orphans + ] + add (imp_mod, dep) deps = addToFM_C combine deps imp_mod dep + + combine old@(_, old_is_boot, cts) new + | maybeToBool cts || not old_is_boot = old -- Keep the old info if it's already loaded + -- or if it's a non-boot pending load + | otherwise = new -- Otherwise pick new info + + +----------------------------------------------------- +-- Loading the export list +----------------------------------------------------- + +loadExport :: Module -> ExportItem -> RnM d [AvailInfo] loadExport this_mod (mod, entities) - | mod == this_mod = returnRn [] + | mod == moduleName this_mod = returnRn [] -- If the module exports anything defined in this module, just ignore it. -- Reason: otherwise it looks as if there are two local definition sites -- for the thing, and an error gets reported. Easiest thing is just to @@ -225,7 +261,7 @@ loadExport this_mod (mod, entities) | otherwise = mapRn (load_entity mod) entities where - new_name mod occ = mkImportedGlobalName mod occ + new_name mod occ = newGlobalName mod occ load_entity mod (Avail occ) = new_name mod occ `thenRn` \ name -> @@ -236,21 +272,9 @@ loadExport this_mod (mod, entities) returnRn (AvailTC name names) -loadFixDecl :: ModuleName -> FixityEnv - -> (Version, RdrNameHsDecl) - -> RnM d FixityEnv -loadFixDecl mod_name fixity_env (version, FixD sig@(FixitySig rdr_name fixity loc)) - = -- Ignore the version; when the fixity changes the version of - -- its 'host' entity changes, so we don't need a separate version - -- number for fixities - mkImportedGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> - let - new_fixity_env = addToNameEnv fixity_env name (FixitySig name fixity loc) - in - returnRn new_fixity_env - - -- Ignore the other sorts of decl -loadFixDecl mod_name fixity_env other_decl = returnRn fixity_env +----------------------------------------------------- +-- Loading type/class/value decls +----------------------------------------------------- loadDecl :: Module -> DeclsMap @@ -276,15 +300,18 @@ loadDecl mod decls_map (version, decl) | name <- availNames full_avail] add_decl decls_map (name, stuff) = WARN( name `elemNameEnv` decls_map, ppr name ) - addToNameEnv decls_map name stuff + extendNameEnv decls_map name stuff in returnRn new_decls_map } where - -- newImportedBinder puts into the cache the binder with the + -- newTopBinder puts into the cache the binder with the -- module information set correctly. When the decl is later renamed, -- the binding site will thereby get the correct module. - new_name rdr_name loc = newImportedBinder mod rdr_name + -- There maybe occurrences that don't have the correct Module, but + -- by the typechecker will propagate the binding definition to all + -- the occurrences, so that doesn't matter + new_name rdr_name loc = newTopBinder mod (rdrNameOcc rdr_name) {- If a signature decl is being loaded, and optIgnoreIfacePragmas is on, @@ -307,10 +334,30 @@ loadDecl mod decls_map (version, decl) -> SigD (IfaceSig name tp [] loc) other -> decl +----------------------------------------------------- +-- Loading fixity decls +----------------------------------------------------- + +loadFixDecls mod_name fixity_env (version, decls) + | null decls = returnRn fixity_env + + | otherwise + = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add -> + returnRn (extendNameEnvList fixity_env to_add) + +loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc) + = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> + returnRn (name, FixitySig name fixity loc) + + +----------------------------------------------------- +-- Loading instance decls +----------------------------------------------------- + loadInstDecl :: Module - -> Bag GatedDecl + -> IfaceInsts -> RdrNameInstDecl - -> RnM d (Bag GatedDecl) + -> RnM d IfaceInsts loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) = -- Find out what type constructors and classes are "gates" for the @@ -326,8 +373,8 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) munged_inst_ty = removeContext inst_ty free_names = extractHsTyRdrNames munged_inst_ty in - setModuleRn (moduleName mod) $ - mapRn mkImportedGlobalFromRdrName free_names `thenRn` \ gate_names -> + setModuleRn mod $ + mapRn lookupOrigName free_names `thenRn` \ gate_names -> returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts) @@ -338,70 +385,79 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) removeContext (HsForAllTy tvs cxt ty) = HsForAllTy tvs [] (removeFuns ty) removeContext ty = removeFuns ty -removeFuns (MonoFunTy _ ty) = removeFuns ty +removeFuns (HsFunTy _ ty) = removeFuns ty removeFuns ty = ty -loadRule :: Module -> Bag GatedDecl - -> RdrNameRuleDecl -> RnM d (Bag GatedDecl) +----------------------------------------------------- +-- Loading Rules +----------------------------------------------------- + +loadRules :: Module -> IfaceRules + -> (Version, [RdrNameRuleDecl]) + -> RnM d IfaceRules +loadRules mod rule_bag (version, rules) + | null rules || opt_IgnoreIfacePragmas + = returnRn rule_bag + | otherwise + = setModuleRn mod $ + mapRn (loadRule mod) rules `thenRn` \ new_rules -> + returnRn (rule_bag `unionBags` listToBag new_rules) + +loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl -- "Gate" the rule simply by whether the rule variable is -- needed. We can refine this later. -loadRule mod rules decl@(IfaceRuleDecl var body src_loc) - = setModuleRn (moduleName mod) $ - mkImportedGlobalFromRdrName var `thenRn` \ var_name -> - returnRn ((unitNameSet var_name, (mod, RuleD decl)) `consBag` rules) +loadRule mod decl@(IfaceRule _ _ var _ _ src_loc) + = lookupOrigName var `thenRn` \ var_name -> + returnRn (unitNameSet var_name, (mod, RuleD decl)) + +loadBuiltinRules :: [(RdrName, CoreRule)] -> RnMG () +loadBuiltinRules builtin_rules + = getIfacesRn `thenRn` \ ifaces -> + mapRn loadBuiltinRule builtin_rules `thenRn` \ rule_decls -> + setIfacesRn (ifaces { iRules = iRules ifaces `unionBags` listToBag rule_decls }) + +loadBuiltinRule (var, rule) + = lookupOrigName var `thenRn` \ var_name -> + returnRn (unitNameSet var_name, (nameModule var_name, RuleD (IfaceRuleOut var rule))) + + +----------------------------------------------------- +-- Loading Deprecations +----------------------------------------------------- --- SUP: TEMPORARY HACK, ignoring module deprecations for now loadDeprec :: Module -> DeprecationEnv -> RdrNameDeprecation -> RnM d DeprecationEnv -loadDeprec mod deprec_env (Deprecation (IEModuleContents _) txt) +loadDeprec mod deprec_env (Deprecation (IEModuleContents _) txt _) = traceRn (text "module deprecation not yet implemented:" <+> ppr mod <> colon <+> ppr txt) `thenRn_` + -- SUP: TEMPORARY HACK, ignoring module deprecations for now returnRn deprec_env -loadDeprec mod deprec_env (Deprecation ie txt) - = setModuleRn (moduleName mod) $ - mapRn mkImportedGlobalFromRdrName (namesFromIE ie) `thenRn` \ names -> + +loadDeprec mod deprec_env (Deprecation ie txt _) + = setModuleRn mod $ + mapRn lookupOrigName (ieNames ie) `thenRn` \ names -> traceRn (text "loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_` - returnRn (extendNameEnv deprec_env (zip names (repeat txt))) - -namesFromIE :: IE a -> [a] -namesFromIE (IEVar n ) = [n] -namesFromIE (IEThingAbs n ) = [n] -namesFromIE (IEThingAll n ) = [n] -namesFromIE (IEThingWith n ns) = n:ns -namesFromIE (IEModuleContents _ ) = [] + returnRn (extendNameEnvList deprec_env (zip names (repeat txt))) \end{code} %******************************************************** %* * -\subsection{Loading usage information} +\subsection{Checking usage information} %* * %******************************************************** \begin{code} -checkUpToDate :: ModuleName -> RnMG Bool -- True <=> no need to recompile -checkUpToDate mod_name - = getIfacesRn `thenRn` \ ifaces -> - findAndReadIface doc_str mod_name - ImportByUser - (error "checkUpToDate") `thenRn` \ (_, read_result) -> +upToDate = True +outOfDate = False - -- CHECK WHETHER WE HAVE IT ALREADY - case read_result of - Nothing -> -- Old interface file not found, so we'd better bail out - traceRn (sep [ptext SLIT("Didnt find old iface"), - pprModuleName mod_name]) `thenRn_` - returnRn False - - Just (_, iface) - -> -- Found it, so now check it - checkModUsage (pi_usages iface) - where - -- Only look in current directory, with suffix .hi - doc_str = sep [ptext SLIT("need usage info from"), pprModuleName mod_name] +checkModUsage :: [ImportVersion OccName] -> RnMG Bool +-- Given the usage information extracted from the old +-- M.hi file for the module being compiled, figure out +-- whether M needs to be recompiled. -checkModUsage [] = returnRn True -- Yes! Everything is up to date! +checkModUsage [] = returnRn upToDate -- Yes! Everything is up to date! -checkModUsage ((mod_name, old_mod_vers, _, _, Specifically []) : rest) +checkModUsage ((mod_name, _, _, NothingAtAll) : rest) -- If CurrentModule.hi contains -- import Foo :: ; -- then that simply records that Foo lies below CurrentModule in the @@ -410,22 +466,26 @@ checkModUsage ((mod_name, old_mod_vers, _, _, Specifically []) : rest) = traceRn (ptext SLIT("Nothing used from:") <+> ppr mod_name) `thenRn_` checkModUsage rest -- This one's ok, so check the rest -checkModUsage ((mod_name, old_mod_vers, _, _, whats_imported) : rest) - = loadInterface doc_str mod_name ImportBySystem `thenRn` \ (mod, ifaces) -> +checkModUsage ((mod_name, _, _, whats_imported) : rest) + = tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) -> + case maybe_err of { + Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), + pprModuleName mod_name]) ; + -- Couldn't find or parse a module mentioned in the + -- old interface file. Don't complain -- it might just be that + -- the current module doesn't need that import and it's been deleted + + Nothing -> let - maybe_mod_vers = case lookupFM (iImpModInfo ifaces) mod_name of - Just (version, _, _, Just (_, _)) -> Just version - other -> Nothing + (_, new_mod_vers, new_fix_vers, new_rule_vers, _, _) + = case lookupFM (iImpModInfo ifaces) mod_name of + Just (_, _, Just stuff) -> stuff + + old_mod_vers = case whats_imported of + Everything v -> v + Specifically v _ _ _ -> v + -- NothingAtAll case dealt with by previous eqn for checkModUsage in - case maybe_mod_vers of { - Nothing -> -- If we can't find a version number for the old module then - -- bail out saying things aren't up to date - traceRn (sep [ptext SLIT("Can't find version number for module"), - pprModuleName mod_name]) - `thenRn_` returnRn False ; - - Just new_mod_vers -> - -- If the module version hasn't changed, just move on if new_mod_vers == old_mod_vers then traceRn (sep [ptext SLIT("Module version unchanged:"), pprModuleName mod_name]) @@ -438,34 +498,39 @@ checkModUsage ((mod_name, old_mod_vers, _, _, whats_imported) : rest) -- If the usage info wants to say "I imported everything from this module" -- it does so by making whats_imported equal to Everything -- In that case, we must recompile - case whats_imported of { - Everything -> traceRn (ptext SLIT("...and I needed the whole module")) `thenRn_` - returnRn False; -- Bale out + case whats_imported of { -- NothingAtAll dealt with earlier + + Everything _ + -> out_of_date (ptext SLIT("...and I needed the whole module")) ; - Specifically old_local_vers -> + Specifically _ old_fix_vers old_rule_vers old_local_vers -> + if old_fix_vers /= new_fix_vers then + out_of_date (ptext SLIT("Fixities changed")) + else if old_rule_vers /= new_rule_vers then + out_of_date (ptext SLIT("Rules changed")) + else -- Non-empty usage list, so check item by item checkEntityUsage mod_name (iDecls ifaces) old_local_vers `thenRn` \ up_to_date -> if up_to_date then traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_` checkModUsage rest -- This one's ok, so check the rest else - returnRn False -- This one failed, so just bail out now + returnRn outOfDate -- This one failed, so just bail out now }} where doc_str = sep [ptext SLIT("need version info for"), pprModuleName mod_name] checkEntityUsage mod decls [] - = returnRn True -- Yes! All up to date! + = returnRn upToDate -- Yes! All up to date! checkEntityUsage mod decls ((occ_name,old_vers) : rest) - = mkImportedGlobalName mod occ_name `thenRn` \ name -> + = newGlobalName mod occ_name `thenRn` \ name -> case lookupNameEnv decls name of Nothing -> -- We used it before, but it ain't there now - traceRn (sep [ptext SLIT("No longer exported:"), ppr name]) - `thenRn_` returnRn False + out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) Just (new_vers,_,_,_) -- It's there, but is it up to date? | new_vers == old_vers @@ -474,8 +539,9 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) | otherwise -- Out of date, so bale out - -> traceRn (sep [ptext SLIT("Out of date:"), ppr name]) `thenRn_` - returnRn False + -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name]) + +out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate \end{code} @@ -486,44 +552,111 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) %********************************************************* \begin{code} -importDecl :: Name -> RnMG (Maybe (Module, RdrNameHsDecl)) - -- Returns Nothing for - -- (a) wired in name - -- (b) local decl - -- (c) already slurped +importDecl :: Name -> RnMG ImportDeclResult + +data ImportDeclResult + = AlreadySlurped + | WiredIn + | Deferred + | HereItIs (Module, RdrNameHsDecl) importDecl name - | isWiredInName name - = returnRn Nothing - | otherwise = getSlurped `thenRn` \ already_slurped -> if name `elemNameSet` already_slurped then - returnRn Nothing -- Already dealt with - else - if isLocallyDefined name then -- Don't bring in decls from + returnRn AlreadySlurped -- Already dealt with + + else if isLocallyDefined name then -- Don't bring in decls from -- the renamed module's own interface file - addWarnRn (importDeclWarn name) `thenRn_` - returnRn Nothing - else - getNonWiredInDecl name -\end{code} + addWarnRn (importDeclWarn name) `thenRn_` + returnRn AlreadySlurped -\begin{code} -getNonWiredInDecl :: Name -> RnMG (Maybe (Module, RdrNameHsDecl)) + else if isWiredInName name then + -- When we find a wired-in name we must load its + -- home module so that we find any instance decls therein + loadHomeInterface doc name `thenRn_` + returnRn WiredIn + + else getNonWiredInDecl name + where + doc = ptext SLIT("need home module for wired in thing") <+> ppr name + + +{- I don't think this is necessary any more; SLPJ May 00 + load_home name + | name `elemNameSet` source_binders = returnRn () + -- When compiling the prelude, a wired-in thing may + -- be defined in this module, in which case we don't + -- want to load its home module! + -- Using 'isLocallyDefined' doesn't work because some of + -- the free variables returned are simply 'listTyCon_Name', + -- with a system provenance. We could look them up every time + -- but that seems a waste. + | otherwise = loadHomeInterface doc name `thenRn_` + returnRn () +-} + +getNonWiredInDecl :: Name -> RnMG ImportDeclResult getNonWiredInDecl needed_name = traceRn doc_str `thenRn_` loadHomeInterface doc_str needed_name `thenRn` \ ifaces -> case lookupNameEnv (iDecls ifaces) needed_name of + Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _ _))) + -- This case deals with deferred import of algebraic data types + + | not opt_NoPruneTyDecls + + && (opt_IgnoreIfacePragmas || ncons > 1) + -- We only defer if imported interface pragmas are ingored + -- or if it's not a product type. + -- Sole reason: The wrapper for a strict function may need to look + -- inside its arg, and hence need to see its arg type's constructors. + + && not (getUnique tycon_name `elem` cCallishTyKeys) + -- Never defer ccall types; we have to unbox them, + -- and importing them does no harm + + -> -- OK, so we're importing a deferrable data type + if needed_name == tycon_name then + -- The needed_name is the TyCon of a data type decl + -- Record that it's slurped, put it in the deferred set + -- and don't return a declaration at all + setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces + `addOneToNameSet` tycon_name}) + version (AvailTC needed_name [needed_name])) `thenRn_` + returnRn Deferred + else + -- The needed name is a constructor of a data type decl, + -- getting a constructor, so remove the TyCon from the deferred set + -- (if it's there) and return the full declaration + setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces + `delFromNameSet` tycon_name}) + version avail) `thenRn_` + returnRn (HereItIs decl) + where + tycon_name = availName avail + Just (version,avail,_,decl) - -> recordSlurp (Just version) avail `thenRn_` - returnRn (Just decl) + -> setIfacesRn (recordSlurp ifaces version avail) `thenRn_` + returnRn (HereItIs decl) - Nothing -- Can happen legitimately for "Optional" occurrences + Nothing -> addErrRn (getDeclErr needed_name) `thenRn_` - returnRn Nothing + returnRn AlreadySlurped where doc_str = ptext SLIT("need decl for") <+> ppr needed_name + +getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)] +getDeferredDecls + = getIfacesRn `thenRn` \ ifaces -> + let + decls_map = iDecls ifaces + deferred_names = nameSetToList (iDeferred ifaces) + get_abstract_decl n = case lookupNameEnv decls_map n of + Just (_, _, _, decl) -> decl + in + traceRn (sep [text "getDeferredDecls", nest 4 (fsep (map ppr deferred_names))]) `thenRn_` + returnRn (map get_abstract_decl deferred_names) \end{code} @getWiredInDecl@ maps a wired-in @Name@ to what it makes available. @@ -559,15 +692,11 @@ that we know just what instances to bring into scope. \begin{code} getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, Avails) getInterfaceExports mod_name from - = loadInterface doc_str mod_name from `thenRn` \ (mod, ifaces) -> + = loadInterface doc_str mod_name from `thenRn` \ ifaces -> case lookupFM (iImpModInfo ifaces) mod_name of - Nothing -> -- Not there; it must be that the interface file wasn't found; - -- the error will have been reported already. - -- (Actually loadInterface should put the empty export env in there - -- anyway, but this does no harm.) - returnRn (mod, []) - - Just (_, _, _, Just (mod, avails)) -> returnRn (mod, avails) + Just (_, _, Just (mod, _, _, _, _, avails)) -> returnRn (mod, avails) + -- loadInterface always puts something in the map + -- even if it's a fake where doc_str = sep [pprModuleName mod_name, ptext SLIT("is directly imported")] \end{code} @@ -587,7 +716,7 @@ getImportedInstDecls gates getIfacesRn `thenRn` \ ifaces -> let orphan_mods = - [mod | (mod, (_, True, _, Nothing)) <- fmToList (iImpModInfo ifaces)] + [mod | (mod, (True, _, Nothing)) <- fmToList (iImpModInfo ifaces)] in loadOrphanModules orphan_mods `thenRn_` @@ -608,12 +737,6 @@ getImportedInstDecls gates where gate_list = nameSetToList gates - load_home gate | isLocallyDefined gate - = returnRn () - | otherwise - = loadHomeInterface (ppr gate <+> text "is an instance gate") gate `thenRn_` - returnRn () - ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _)) = case inst_ty of HsForAllTy _ _ tau -> ppr tau @@ -626,11 +749,15 @@ getImportedRules = getIfacesRn `thenRn` \ ifaces -> let gates = iSlurp ifaces -- Anything at all that's been slurped - (decls, new_rules) = selectGated gates (iRules ifaces) + rules = iRules ifaces + (decls, new_rules) = selectGated gates rules in - setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` + if null decls then + returnRn [] + else + setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` traceRn (sep [text "getImportedRules:", - text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` + text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` returnRn decls selectGated gates decl_bag @@ -647,13 +774,11 @@ selectGated gates decl_bag | isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no) | otherwise = (yes, (reqd,decl) `consBag` no) -lookupFixity :: Name -> RnMS Fixity -lookupFixity name +lookupFixityRn :: Name -> RnMS Fixity +lookupFixityRn name | isLocallyDefined name = getFixityEnv `thenRn` \ local_fix_env -> - case lookupNameEnv local_fix_env name of - Just (FixitySig _ fix _) -> returnRn fix - Nothing -> returnRn defaultFixity + returnRn (lookupFixity local_fix_env name) | otherwise -- Imported -- For imported names, we have to get their fixities by doing a loadHomeInterface, @@ -664,9 +789,7 @@ lookupFixity name -- When we come across a use of 'f', we need to know its fixity, and it's then, -- and only then, that we load B.hi. That is what's happening here. = loadHomeInterface doc name `thenRn` \ ifaces -> - case lookupNameEnv (iFixes ifaces) name of - Just (FixitySig _ fix _) -> returnRn fix - Nothing -> returnRn defaultFixity + returnRn (lookupFixity (iFixes ifaces) name) where doc = ptext SLIT("Checking fixity for") <+> ppr name \end{code} @@ -730,20 +853,32 @@ imports A. This line says that A imports B, but uses nothing in it. So we'll get an early bale-out when compiling A if B's version changes. \begin{code} -getImportVersions :: ModuleName -- Name of this module - -> ExportEnv -- Info about exports - -> RnMG (VersionInfo Name) -- Version info for these names - -getImportVersions this_mod (ExportEnv _ _ export_all_mods) +mkImportExportInfo :: ModuleName -- Name of this module + -> Avails -- Info about exports + -> Maybe [RdrNameIE] -- The export header + -> RnMG ([ExportItem], -- Export info for iface file; sorted + [ImportVersion OccName]) -- Import info for iface file; sorted + -- Both results are sorted into canonical order to + -- reduce needless wobbling of interface files + +mkImportExportInfo this_mod export_avails exports = getIfacesRn `thenRn` \ ifaces -> let + export_all_mods = case exports of + Nothing -> [] + Just es -> [mod | IEModuleContents mod <- es, + mod /= this_mod] + mod_map = iImpModInfo ifaces imp_names = iVSlurp ifaces -- mv_map groups together all the things imported from a particular module. - mv_map :: FiniteMap ModuleName [(Name,Version)] + mv_map :: FiniteMap ModuleName [(OccName,Version)] mv_map = foldr add_mv emptyFM imp_names + add_mv (name, version) mv_map = addItem mv_map (moduleName (nameModule name)) + (nameOccName name, version) + -- Build the result list by adding info for each module. -- For (a) a library module, we don't record it at all unless it contains orphans -- (We must never lose track of orphans.) @@ -760,9 +895,16 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) -- whether something is a boot file along with the usage info for it, but -- I can't be bothered just now. - mk_version_info mod_name (version, has_orphans, is_boot, contents) so_far + mk_imp_info mod_name (has_orphans, is_boot, contents) so_far + | mod_name == this_mod -- Check if M appears in the set of modules 'below' M + -- This seems like a convenient place to check + = WARN( not is_boot, ptext SLIT("Wierd:") <+> ppr this_mod <+> + ptext SLIT("imports itself (perhaps indirectly)") ) + so_far + + | otherwise = let - go_for_it exports = (mod_name, version, has_orphans, is_boot, exports) + go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far in case contents of @@ -772,40 +914,63 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) -- Foo in the module dependency hierarchy. We want to propagate this -- information. The Nothing says that we didn't even open the interface -- file but we must still propagate the dependeny info. - go_for_it (Specifically []) + -- The module in question must be a local module (in the same package) + go_for_it NothingAtAll - Just (mod, _) -- We did open the interface - | is_lib_module && not has_orphans + Just (mod, mod_vers, fix_vers, rule_vers, how_imported, _) + | is_sys_import && is_lib_module && not has_orphans -> so_far | is_lib_module -- Record the module but not detailed || mod_name `elem` export_all_mods -- version information for the imports - -> go_for_it Everything + -> go_for_it (Everything mod_vers) | otherwise -> case lookupFM mv_map mod_name of - Just whats_imported -> go_for_it (Specifically whats_imported) - Nothing -> go_for_it (Specifically []) + Just whats_imported -> go_for_it (Specifically mod_vers fix_vers rule_vers + (sortImport whats_imported)) + Nothing -> go_for_it NothingAtAll -- This happens if you have -- import Foo -- but don't actually *use* anything from Foo -- In which case record an empty dependency list where - is_lib_module = isLibModule mod + is_lib_module = not (isLocalModule mod) + is_sys_import = case how_imported of + ImportBySystem -> True + other -> False + + import_info = foldFM mk_imp_info [] mod_map + + -- Sort exports into groups by module + export_fm :: FiniteMap ModuleName [RdrAvailInfo] + export_fm = foldr insert emptyFM export_avails + + insert avail efm = addItem efm (moduleName (nameModule (availName avail))) + (rdrAvailInfo avail) + + export_info = [(m, sortExport as) | (m,as) <- fmToList export_fm] in - -- A module shouldn't load its own interface - -- This seems like a convenient place to check - WARN( maybeToBool (lookupFM mod_map this_mod), - ptext SLIT("Wierd:") <+> ppr this_mod <+> ptext SLIT("loads its own interface") ) + traceRn (text "Modules in Ifaces: " <+> fsep (map ppr (keysFM mod_map))) `thenRn_` + returnRn (export_info, import_info) - returnRn (foldFM mk_version_info [] mod_map) - where - add_mv v@(name, version) mv_map - = addToFM_C add_item mv_map mod [v] - where - mod = moduleName (nameModule name) - add_item vs _ = (v:vs) + +addItem :: FiniteMap ModuleName [a] -> ModuleName -> a -> FiniteMap ModuleName [a] +addItem fm mod x = addToFM_C add_item fm mod [x] + where + add_item xs _ = x:xs + +sortImport :: [(OccName,Version)] -> [(OccName,Version)] + -- Make the usage lists appear in canonical order +sortImport vs = sortLt lt vs + where + lt (n1,v1) (n2,v2) = n1 < n2 + +sortExport :: [RdrAvailInfo] -> [RdrAvailInfo] +sortExport as = sortLt lt as + where + lt a1 a2 = availName a1 < availName a2 \end{code} \begin{code} @@ -813,20 +978,20 @@ getSlurped = getIfacesRn `thenRn` \ ifaces -> returnRn (iSlurp ifaces) -recordSlurp maybe_version avail --- Nothing for locally defined names --- Just version for imported names - = getIfacesRn `thenRn` \ ifaces@(Ifaces { iSlurp = slurped_names, - iVSlurp = imp_names }) -> - let +recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = imp_names }) + version avail + = let new_slurped_names = addAvailToNameSet slurped_names avail + new_imp_names = (availName avail, version) : imp_names + in + ifaces { iSlurp = new_slurped_names, iVSlurp = new_imp_names } - new_imp_names = case maybe_version of - Just version -> (availName avail, version) : imp_names - Nothing -> imp_names +recordLocalSlurps local_avails + = getIfacesRn `thenRn` \ ifaces -> + let + new_slurped_names = foldl addAvailToNameSet (iSlurp ifaces) local_avails in - setIfacesRn (ifaces { iSlurp = new_slurped_names, - iVSlurp = new_imp_names }) + setIfacesRn (ifaces { iSlurp = new_slurped_names }) \end{code} @@ -848,7 +1013,7 @@ getDeclBinders :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function -> RdrNameHsDecl -> RnM d (Maybe AvailInfo) -getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ src_loc)) +getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc _ _)) = new_name tycon src_loc `thenRn` \ tycon_name -> getConFieldNames new_name condecls `thenRn` \ sub_names -> returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names))) @@ -859,7 +1024,7 @@ getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> returnRn (Just (AvailTC tycon_name [tycon_name])) -getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ _ _ _ src_loc)) +getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ src_loc)) = new_name cname src_loc `thenRn` \ class_name -> -- Record the names for the class ops @@ -875,7 +1040,8 @@ getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc)) = new_name var src_loc `thenRn` \ var_name -> returnRn (Just (Avail var_name)) -getDeclBinders new_name (FixD _) = returnRn Nothing +getDeclBinders new_name (FixD _) = returnRn Nothing +getDeclBinders new_name (DeprecD _) = returnRn Nothing -- foreign declarations getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc)) @@ -883,8 +1049,8 @@ getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc)) = new_name nm loc `thenRn` \ name -> returnRn (Just (Avail name)) - | otherwise -- a foreign export - = lookupImplicitOccRn nm `thenRn_` + | otherwise -- a foreign export + = lookupOrigName nm `thenRn_` returnRn Nothing getDeclBinders new_name (DefD _) = returnRn Nothing @@ -905,17 +1071,12 @@ getConFieldNames new_name (ConDecl con _ _ _ (RecCon fielddecls) src_loc : rest) getConFieldNames new_name (ConDecl con _ _ _ condecl src_loc : rest) = new_name con src_loc `thenRn` \ n -> - (case condecl of - NewCon _ (Just f) -> - new_name f src_loc `thenRn` \ new_f -> - returnRn [n,new_f] - _ -> returnRn [n]) `thenRn` \ nn -> getConFieldNames new_name rest `thenRn` \ ns -> - returnRn (nn ++ ns) + returnRn (n : ns) getConFieldNames new_name [] = returnRn [] -getClassOpNames new_name (ClassOpSig op _ _ _ src_loc) = new_name op src_loc +getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc \end{code} @getDeclSysBinders@ gets the implicit binders introduced by a decl. @@ -928,10 +1089,11 @@ and the dict fun of an instance decl, because both of these have bindings of their own elsewhere. \begin{code} -getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname dwname snames src_loc)) - = sequenceRn [new_name n src_loc | n <- (tname : dname : dwname : snames)] +getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ names + src_loc)) + = sequenceRn [new_name n src_loc | n <- names] -getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _)) +getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _ _)) = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons] getDeclSysBinders new_name other_decl @@ -945,51 +1107,38 @@ getDeclSysBinders new_name other_decl %********************************************************* \begin{code} -findAndReadIface :: SDoc -> ModuleName -> WhereFrom - -> Bool -- Only relevant for SystemImport - -- True <=> Look for a .hi file - -- False <=> Look for .hi-boot file unless there's - -- a library .hi file - -> RnM d (Bool, Maybe (Module, ParsedIface)) - -- Bool is True if the interface actually read was a .hi-boot one +findAndReadIface :: SDoc -> ModuleName + -> IsBootInterface -- True <=> Look for a .hi-boot file + -- False <=> Look for .hi file + -> RnM d (Either Message ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -findAndReadIface doc_str mod_name from hi_file +findAndReadIface doc_str mod_name hi_boot_file = traceRn trace_msg `thenRn_` -- we keep two maps for interface files, -- one for 'normal' ones, the other for .hi-boot files, -- hence the need to signal which kind we're interested. - getHiMaps `thenRn` \ hi_maps -> + --getHiMaps `thenRn` \ (search_path, hi_map, hiboot_map) -> + let + bomb = panic "findAndReadInterface: hi_maps: FIXME" + search_path = panic "findAndReadInterface: search_path: FIXME" + relevant_map | hi_boot_file = bomb --hiboot_map + | otherwise = bomb --hi_map + in + case lookupFM relevant_map mod_name of + -- Found the file + Just fpath -> traceRn (ptext SLIT("...reading from") <+> text fpath) `thenRn_` + readIface mod_name fpath - case find_path from hi_maps of - -- Found the file - (hi_boot, Just (fpath, mod)) -> traceRn (ptext SLIT("...reading from") <+> text fpath) - `thenRn_` - readIface mod fpath `thenRn` \ result -> - returnRn (hi_boot, result) - (hi_boot, Nothing) -> traceRn (ptext SLIT("...not found")) `thenRn_` - returnRn (hi_boot, Nothing) - where - find_path ImportByUser (hi_map, _) = (False, lookupFM hi_map mod_name) - find_path ImportByUserSource (_, hiboot_map) = (True, lookupFM hiboot_map mod_name) - - find_path ImportBySystem (hi_map, hiboot_map) - | hi_file - = -- If the module we seek is in our dependent set, - -- Look for a .hi file - (False, lookupFM hi_map mod_name) - - | otherwise - -- Check if there's a library module of that name - -- If not, look for an hi-boot file - = case lookupFM hi_map mod_name of - stuff@(Just (_, mod)) | isLibModule mod -> (False, stuff) - other -> (True, lookupFM hiboot_map mod_name) + -- Can't find it + Nothing -> traceRn (ptext SLIT("...not found")) `thenRn_` + returnRn (Left (noIfaceErr mod_name hi_boot_file search_path)) + where trace_msg = sep [hsep [ptext SLIT("Reading"), - ppr from, + if hi_boot_file then ptext SLIT("[boot]") else empty, ptext SLIT("interface for"), pprModuleName mod_name <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)] @@ -998,10 +1147,10 @@ findAndReadIface doc_str mod_name from hi_file @readIface@ tries just the one file. \begin{code} -readIface :: Module -> String -> RnM d (Maybe (Module, ParsedIface)) +readIface :: ModuleName -> String -> RnM d (Either Message ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -readIface the_mod file_path +readIface wanted_mod file_path = ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result -> case read_result of Right contents -> @@ -1010,21 +1159,23 @@ readIface the_mod file_path context = [], glasgow_exts = 1#, loc = mkSrcLoc (mkFastString file_path) 1 } of - POk _ (PIface mod_nm iface) -> - warnCheckRn (mod_nm == moduleName the_mod) - (hiModuleNameMismatchWarn the_mod mod_nm) `thenRn_` - returnRn (Just (the_mod, iface)) - - PFailed err -> failWithRn Nothing err - other -> failWithRn Nothing (ptext SLIT("Unrecognisable interface file")) - -- This last case can happen if the interface file is (say) empty - -- in which case the parser thinks it looks like an IdInfo or - -- something like that. Just an artefact of the fact that the - -- parser is used for several purposes at once. - - Left err - | isDoesNotExistError err -> returnRn Nothing - | otherwise -> failWithRn Nothing (cannaeReadFile file_path err) + POk _ (PIface iface) -> + warnCheckRn (read_mod == wanted_mod) + (hiModuleNameMismatchWarn wanted_mod read_mod) `thenRn_` + returnRn (Right iface) + where + read_mod = moduleName (pi_mod iface) + + PFailed err -> bale_out err + parse_result -> bale_out empty + -- This last case can happen if the interface file is (say) empty + -- in which case the parser thinks it looks like an IdInfo or + -- something like that. Just an artefact of the fact that the + -- parser is used for several purposes at once. + + Left io_err -> bale_out (text (show io_err)) + where + bale_out err = returnRn (Left (badIfaceFile file_path err)) \end{code} %********************************************************* @@ -1034,25 +1185,26 @@ readIface the_mod file_path %********************************************************* \begin{code} -noIfaceErr filename boot_file - = hsep [ptext SLIT("Could not find valid"), boot, - ptext SLIT("interface file"), quotes (pprModule filename)] +noIfaceErr mod_name boot_file search_path + = vcat [ptext SLIT("Could not find interface file for") <+> quotes (pprModuleName mod_name), + ptext SLIT("in the directories") <+> + -- \& to avoid cpp interpreting this string as a + -- comment starter with a pre-4.06 mkdependHS --SDM + vcat [ text dir <> text "/\&*" <> pp_suffix suffix + | (dir,suffix) <- search_path] + ] where - boot | boot_file = ptext SLIT("[boot]") - | otherwise = empty + pp_suffix suffix | boot_file = ptext SLIT(".hi-boot") + | otherwise = text suffix -cannaeReadFile file err - = hcat [ptext SLIT("Failed in reading file: "), - text file, - ptext SLIT("; error="), - text (show err)] +badIfaceFile file err + = vcat [ptext SLIT("Bad interface file:") <+> text file, + nest 4 err] getDeclErr name - = ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name) - -getDeclWarn name loc - = sep [ptext SLIT("Failed to find (optional) interface decl for") <+> quotes (ppr name), - ptext SLIT("desired at") <+> ppr loc] + = vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name), + ptext SLIT("from module") <+> quotes (ppr (nameModule name)) + ] importDeclWarn name = sep [ptext SLIT( @@ -1066,12 +1218,12 @@ warnRedundantSourceImport mod_name = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") <+> quotes (pprModuleName mod_name) -hiModuleNameMismatchWarn :: Module -> ModuleName -> Message -hiModuleNameMismatchWarn requested_mod mod_nm = +hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message +hiModuleNameMismatchWarn requested_mod read_mod = hsep [ ptext SLIT("Something is amiss; requested module name") - , pprModule requested_mod - , ptext SLIT("differs from name found in the interface file ") - , pprModuleName mod_nm + , pprModuleName requested_mod + , ptext SLIT("differs from name found in the interface file") + , pprModuleName read_mod ] \end{code}