X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnHiFiles.lhs;h=82512dccef046e3b3ea33765214d123bc3123f84;hb=16e4ce4c0c02650082f2e11982017c903c549ad5;hp=3bd71f9966fbc11c0d23d093bf47bb99b31859e5;hpb=ef2b170c6298b4826d3b56465a3c1438b5be7307;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 3bd71f9..82512dc 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -5,67 +5,76 @@ \begin{code} module RnHiFiles ( - readIface, findAndReadIface, loadInterface, loadHomeInterface, - tryLoadInterface, loadOrphanModules, - loadExports, loadFixDecls, loadDeprecs, - - getTyClDeclBinders + readIface, loadInterface, loadHomeInterface, + loadOrphanModules, + loadOldIface, + ParsedIface(..) ) where #include "HsVersions.h" import DriverState ( v_GhcMode, isCompManagerMode ) -import DriverUtil ( splitFilename ) +import DriverUtil ( replaceFilenameSuffix ) import CmdLineOpts ( opt_IgnoreIfacePragmas ) import Parser ( parseIface ) -import HscTypes ( ModuleLocation(..), - ModIface(..), emptyModIface, - VersionInfo(..), ImportedModuleInfo, - lookupIfaceByModName, RdrExportItem, - ImportVersion, WhetherHasOrphans, IsBootInterface, - DeclsMap, GatedDecl, IfaceInsts, IfaceRules, - AvailInfo, GenAvailInfo(..), Avails, Deprecations(..) +import HscTypes ( ModIface(..), emptyModIface, + ExternalPackageState(..), noDependencies, + VersionInfo(..), Usage(..), + lookupIfaceByModName, RdrExportItem, + IsBootInterface, + DeclsMap, GatedDecl, IfaceInsts, IfaceRules, mkIfaceDecls, + AvailInfo, GenAvailInfo(..), ParsedIface(..), IfaceDeprecs, + Avails, availNames, availName, Deprecations(..) ) -import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..), - tyClDeclNames, tyClDeclSysNames, hsTyVarNames, - getHsInstHead, +import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..), ConDecl(..), + hsTyVarNames, splitHsInstDeclTy, tyClDeclName, tyClDeclNames ) import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) -import RnHsSyn ( extractHsTyNames_s ) -import BasicTypes ( Version ) +import RnHsSyn ( RenamedInstDecl, RenamedRuleDecl, RenamedTyClDecl, + extractHsTyNames_s ) +import BasicTypes ( Version, FixitySig(..), Fixity(..), FixityDirection(..) ) +import RnSource ( rnIfaceRuleDecl, rnTyClDecl, rnInstDecl ) import RnTypes ( rnHsType ) import RnEnv -import RnMonad +import TcRnMonad import PrelNames ( gHC_PRIM_Name, gHC_PRIM ) +import PrelInfo ( ghcPrimExports, cCallableClassDecl, cReturnableClassDecl ) import Name ( Name {-instance NamedThing-}, - nameModule, isInternalName, nameIsLocalOrFrom - ) + nameModule, isInternalName ) import NameEnv import NameSet -import Module -import RdrName ( rdrNameOcc ) -import SrcLoc ( mkSrcLoc ) +import Id ( idName ) +import MkId ( seqId ) +import Packages ( basePackage ) +import Module ( Module, ModuleName, ModLocation(ml_hi_file), + moduleName, isHomeModule, mkPackageModule, + extendModuleEnv, lookupModuleEnvByName + ) +import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName ) +import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc, + mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2, + mkDataConWrapperOcc, mkDataConWorkerOcc ) +import TyCon ( DataConDetails(..) ) +import SrcLoc ( noSrcLoc, mkSrcLoc ) import Maybes ( maybeToBool ) import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) import ErrUtils ( Message ) -import Finder ( findModule, findPackageModule ) +import Finder ( findModule, findPackageModule, + hiBootExt, hiBootVerExt ) import Lex import FiniteMap import ListSetOps ( minusList ) import Outputable import Bag -import BinIface ( {- just instances -} ) -import qualified Binary +import BinIface ( readBinIface ) import Panic -import Config -import IOExts -import Exception -import Dynamic ( fromDynamic ) +import EXCEPTION as Exception +import DATA_IOREF ( readIORef ) + import Directory -import List ( isSuffixOf ) \end{code} @@ -76,53 +85,50 @@ import List ( isSuffixOf ) %********************************************************* \begin{code} -loadHomeInterface :: SDoc -> Name -> RnM d ModIface +loadHomeInterface :: SDoc -> Name -> TcRn m ModIface loadHomeInterface doc_str name = ASSERT2( not (isInternalName name), ppr name <+> parens doc_str ) loadInterface doc_str (moduleName (nameModule name)) ImportBySystem -loadOrphanModules :: [ModuleName] -> RnM d () +loadOrphanModules :: [ModuleName] -> TcRn m () loadOrphanModules mods - | null mods = returnRn () + | null mods = returnM () | otherwise = traceRn (text "Loading orphan modules:" <+> - fsep (map ppr mods)) `thenRn_` - mapRn_ load mods `thenRn_` - returnRn () + fsep (map ppr mods)) `thenM_` + mappM_ load mods `thenM_` + returnM () where load mod = loadInterface (mk_doc mod) mod ImportBySystem mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") -loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d ModIface -loadInterface doc mod from - = tryLoadInterface doc mod from `thenRn` \ (ifaces, maybe_err) -> - case maybe_err of - Nothing -> returnRn ifaces - Just err -> failWithRn ifaces (elaborate err) - where - elaborate err = hang (ptext SLIT("failed to load interface for") <+> quotes (ppr mod) <> colon) - 4 err - -tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (ModIface, Maybe Message) - -- Returns (Just err) if an error happened - -- It *doesn't* add an error to the monad, because sometimes it's ok to fail... - -- Specifically, when we read the usage information from an interface file, - -- we try to read the interfaces it mentions. But it's OK to fail; perhaps - -- the module has changed, and that interface is no longer used. +loadInterface :: SDoc -> ModuleName -> WhereFrom -> TcRn m ModIface + -- Returns Nothing if failed + -- If we can't find an interface file, and we are doing ImportForUsage, + -- just fail in the monad, and modify anything else + -- Otherwise, if we can't find an interface file, + -- add an error message to the monad (the first time only) + -- and return emptyIface + -- The "first time only" part is done by modifying the PackageIfaceTable + -- to have an empty entry + -- + -- The ImportForUsage case is because when we read the usage information from + -- an interface file, we try to read the interfaces it mentions. + -- But it's OK to fail; perhaps the module has changed, and that interface + -- is no longer used. - -- tryLoadInterface guarantees to return with iImpModInfo m --> (..., True) - -- (If the load fails, we plug in a vanilla placeholder) -tryLoadInterface doc_str mod_name from - = getHomeIfaceTableRn `thenRn` \ hit -> - getModuleRn `thenRn` \ this_mod -> - getIfacesRn `thenRn` \ ifaces@(Ifaces { iPIT = pit }) -> +loadInterface doc_str mod_name from + = getHpt `thenM` \ hpt -> + getModule `thenM` \ this_mod -> + getImports `thenM` \ import_avails -> + getEps `thenM` \ eps@(EPS { eps_PIT = pit }) -> -- CHECK WHETHER WE HAVE IT ALREADY - case lookupIfaceByModName hit pit mod_name of { + case lookupIfaceByModName hpt pit mod_name of { Just iface | case from of - ImportByUser -> not (mi_boot iface) - ImportByUserSource -> mi_boot iface - ImportBySystem -> True - -> returnRn (iface, Nothing) ; -- Already loaded + ImportByUser src_imp -> src_imp == mi_boot iface + ImportForUsage src_imp -> src_imp == mi_boot iface + ImportBySystem -> True + -> returnM iface ; -- Already loaded -- The not (mi_boot iface) test checks that the already-loaded -- interface isn't a boot iface. This can conceivably happen, -- if the version checking happened to load a boot interface @@ -130,13 +136,13 @@ tryLoadInterface doc_str mod_name from other -> let - mod_map = iImpModInfo ifaces - mod_info = lookupFM mod_map mod_name + mod_map = imp_dep_mods import_avails + mod_info = lookupModuleEnvByName mod_map mod_name hi_boot_file = case (from, mod_info) of - (ImportByUser, _) -> False -- Not hi-boot - (ImportByUserSource, _) -> True -- hi-boot + (ImportByUser is_boot, _) -> is_boot + (ImportForUsage is_boot, _) -> is_boot (ImportBySystem, Just (_, is_boot)) -> is_boot (ImportBySystem, Nothing) -> False -- We're importing a module we know absolutely @@ -146,41 +152,50 @@ tryLoadInterface doc_str mod_name from redundant_source_import = case (from, mod_info) of - (ImportByUserSource, Just (_,False)) -> True - other -> False + (ImportByUser True, Just (_, False)) -> True + other -> False in -- 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_` + warnIf redundant_source_import + (warnRedundantSourceImport mod_name) `thenM_` -- Check that we aren't importing ourselves. -- That only happens in Rename.checkOldIface, - -- which doesn't call tryLoadInterface - warnCheckRn - (not (isHomeModule this_mod) || moduleName this_mod /= mod_name) - (warnSelfImport this_mod) `thenRn_` + -- which doesn't call loadInterface + warnIf + (isHomeModule this_mod && moduleName this_mod == mod_name) + (warnSelfImport this_mod) `thenM_` -- READ THE MODULE IN findAndReadIface doc_str mod_name hi_boot_file - `thenRn` \ read_result -> + `thenM` \ read_result -> case read_result of { - Left err -> -- Not found, so add an empty export env to the Ifaces map - -- so that we don't look again - let - fake_mod = mkVanillaModule mod_name - fake_iface = emptyModIface fake_mod - new_ifaces = ifaces { iPIT = extendModuleEnv pit fake_mod fake_iface } - in - setIfacesRn new_ifaces `thenRn_` - returnRn (fake_iface, Just err) ; + Left err + | case from of { ImportForUsage _ -> True ; other -> False } + -> failM -- Fail with no error messages + + | otherwise + -> let -- Not found, so add an empty export env to + -- the EPS map so that we don't look again + fake_mod = mkPackageModule mod_name + fake_iface = emptyModIface fake_mod + new_eps = eps { eps_PIT = extendModuleEnv pit fake_mod fake_iface } + in + setEps new_eps `thenM_` + addErr (elaborate err) `thenM_` + returnM fake_iface + where + elaborate err = hang (ptext SLIT("Failed to load interface for") <+> + quotes (ppr mod_name) <> colon) 4 err + ; -- Found and parsed! Right (mod, iface) -> - -- LOAD IT INTO Ifaces + -- LOAD IT INTO EPS -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). @@ -195,35 +210,24 @@ tryLoadInterface doc_str mod_name from isHomeModule mod, ppr mod ) - loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) -> - loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) -> - loadInstDecls mod (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> - loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> - loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env -> - loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> - let + initRn (InterfaceMode mod) $ + -- Set the module, for use when looking up occurrences + -- of names in interface decls and rules + loadDecls mod (eps_decls eps) (pi_decls iface) `thenM` \ (decls_vers, new_decls) -> + loadRules mod (eps_rules eps) (pi_rules iface) `thenM` \ (rule_vers, new_rules) -> + loadInstDecls mod (eps_insts eps) (pi_insts iface) `thenM` \ new_insts -> + loadExports (pi_exports iface) `thenM` \ (export_vers, avails) -> + loadFixDecls (pi_fixity iface) `thenM` \ fix_env -> + loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env -> + let version = VersionInfo { vers_module = pi_vers iface, vers_exports = export_vers, vers_rules = rule_vers, vers_decls = decls_vers } - -- For an explicit user import, add to mod_map info about - -- the things the imported module depends on, extracted - -- from its usage info; and delete the module itself, which is now in the PIT - mod_map1 = case from of - ImportByUser -> addModDeps mod is_loaded (pi_usages iface) mod_map - other -> mod_map - mod_map2 = delFromFM mod_map1 mod_name - - this_mod_name = moduleName this_mod - is_loaded m = m == this_mod_name - || maybeToBool (lookupIfaceByModName hit pit m) - -- We treat the currently-being-compiled module as 'loaded' because - -- even though it isn't yet in the HIT or PIT; otherwise it gets - -- put into iImpModInfo, and then spat out into its own interface - -- file as a dependency - -- Now add info about this module to the PIT + -- Even home modules loaded by this route (which only + -- happens in OneShot mode) are put in the PIT has_orphans = pi_orphan iface new_pit = extendModuleEnv pit mod mod_iface mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface, @@ -231,76 +235,43 @@ tryLoadInterface doc_str mod_name from mi_orphan = has_orphans, mi_boot = hi_boot_file, mi_exports = avails, mi_fixities = fix_env, mi_deprecs = deprec_env, - mi_usages = [], -- Will be filled in later - mi_decls = panic "No mi_decls in PIT", - mi_globals = Nothing + mi_deps = pi_deps iface, + mi_usages = panic "No mi_usages in PIT", + mi_decls = panic "No mi_decls in PIT", + mi_globals = Nothing } - new_ifaces = ifaces { iPIT = new_pit, - iDecls = new_decls, - iInsts = new_insts, - iRules = new_rules, - iImpModInfo = mod_map2 } + new_eps = eps { eps_PIT = new_pit, + eps_decls = new_decls, + eps_insts = new_insts, + eps_rules = new_rules } in - setIfacesRn new_ifaces `thenRn_` - returnRn (mod_iface, Nothing) + setEps new_eps `thenM_` + returnM mod_iface }} ----------------------------------------------------- --- Adding module dependencies from the --- import decls in the interface file ------------------------------------------------------ - -addModDeps :: Module - -> (ModuleName -> Bool) -- True for modules that are already loaded - -> [ImportVersion a] - -> ImportedModuleInfo -> ImportedModuleInfo --- (addModDeps M ivs deps) --- We are importing module M, and M.hi contains 'import' decls given by ivs -addModDeps mod is_loaded new_deps mod_deps - = foldr add mod_deps filtered_new_deps - where - -- 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 :: [(ModuleName, (WhetherHasOrphans, IsBootInterface))] - filtered_new_deps - | isHomeModule mod = [ (imp_mod, (has_orphans, is_boot)) - | (imp_mod, has_orphans, is_boot, _) <- new_deps, - not (is_loaded imp_mod) - ] - | otherwise = [ (imp_mod, (True, False)) - | (imp_mod, has_orphans, _, _) <- new_deps, - not (is_loaded imp_mod) && has_orphans - ] - add (imp_mod, dep) deps = addToFM_C combine deps imp_mod dep - - combine old@(old_has_orphans, old_is_boot) new@(new_has_orphans, new_is_boot) - | old_is_boot = new -- Record the best is_boot info - | otherwise = old - ------------------------------------------------------ -- Loading the export list ----------------------------------------------------- -loadExports :: (Version, [RdrExportItem]) -> RnM d (Version, [(ModuleName,Avails)]) +loadExports :: (Version, [RdrExportItem]) -> TcRn m (Version, [(ModuleName,Avails)]) loadExports (vers, items) - = mapRn loadExport items `thenRn` \ avails_s -> - returnRn (vers, avails_s) + = mappM loadExport items `thenM` \ avails_s -> + returnM (vers, avails_s) -loadExport :: RdrExportItem -> RnM d (ModuleName, Avails) +loadExport :: RdrExportItem -> TcRn m (ModuleName, Avails) loadExport (mod, entities) - = mapRn (load_entity mod) entities `thenRn` \ avails -> - returnRn (mod, avails) + = mappM (load_entity mod) entities `thenM` \ avails -> + returnM (mod, avails) where load_entity mod (Avail occ) - = newGlobalName mod occ `thenRn` \ name -> - returnRn (Avail name) + = newGlobalName2 mod occ `thenM` \ name -> + returnM (Avail name) load_entity mod (AvailTC occ occs) - = newGlobalName mod occ `thenRn` \ name -> - mapRn (newGlobalName mod) occs `thenRn` \ names -> - returnRn (AvailTC name names) + = newGlobalName2 mod occ `thenM` \ name -> + mappM (newGlobalName2 mod) occs `thenM` \ names -> + returnM (AvailTC name names) ----------------------------------------------------- @@ -310,13 +281,14 @@ loadExport (mod, entities) loadDecls :: Module -> DeclsMap -> [(Version, RdrNameTyClDecl)] - -> RnM d (NameEnv Version, DeclsMap) + -> TcRn m (NameEnv Version, DeclsMap) loadDecls mod (decls_map, n_slurped) decls - = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls `thenRn` \ (vers, decls_map') -> - returnRn (vers, (decls_map', n_slurped)) + = foldlM (loadDecl mod) (emptyNameEnv, decls_map) decls `thenM` \ (vers, decls_map') -> + returnM (vers, (decls_map', n_slurped)) loadDecl mod (version_map, decls_map) (version, decl) - = getTyClDeclBinders mod decl `thenRn` \ (avail, sys_names) -> + = getTyClDeclBinders mod decl `thenM` \ avail -> + getSysBinders mod decl `thenM` \ sys_names -> let full_avail = case avail of Avail n -> avail @@ -328,36 +300,88 @@ loadDecl mod (version_map, decls_map) (version, decl) new_version_map = extendNameEnv version_map main_name version in - traceRn (text "Loading" <+> ppr full_avail) `thenRn_` - returnRn (new_version_map, new_decls_map) +-- traceRn (text "Loading" <+> ppr full_avail) `thenM_` + returnM (new_version_map, new_decls_map) + + + +----------------- +getTyClDeclBinders :: Module -> RdrNameTyClDecl -> TcRn m AvailInfo + +getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc}) + = newTopBinder mod var src_loc `thenM` \ var_name -> + returnM (Avail var_name) + +getTyClDeclBinders mod tycl_decl + = mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) -> + returnM (AvailTC main_name names) + where + new (nm,loc) = newTopBinder mod nm loc + +-------------------------------- +-- The "system names" are extra implicit names *bound* by the decl. + +getSysBinders :: Module -> TyClDecl RdrName -> TcRn m [Name] +-- Similar to tyClDeclNames, but returns the "implicit" +-- or "system" names of the declaration. And it only works +-- on RdrNames, returning OccNames + +getSysBinders mod (ClassDecl {tcdName = cname, tcdCtxt = cxt, tcdLoc = loc}) + = mapM (new_sys_bndr mod loc) sys_occs + where + -- C.f. TcClassDcl.tcClassDecl1 + sys_occs = tc_occ : data_occ : dwrap_occ : dwork_occ : sc_sel_occs + cls_occ = rdrNameOcc cname + data_occ = mkClassDataConOcc cls_occ + dwrap_occ = mkDataConWrapperOcc data_occ + dwork_occ = mkDataConWorkerOcc data_occ + tc_occ = mkClassTyConOcc cls_occ + sc_sel_occs = [mkSuperDictSelOcc n cls_occ | n <- [1..length cxt]] + +getSysBinders mod (TyData {tcdName = tc_name, tcdCons = DataCons cons, + tcdGeneric = Just want_generic, tcdLoc = loc}) + -- The 'Just' is because this is an interface-file decl + -- so it will say whether to derive generic stuff for it or not + = mapM (new_sys_bndr mod loc) (gen_occs ++ concatMap mk_con_occs cons) + where + new = new_sys_bndr + -- c.f. TcTyDecls.tcTyDecl + tc_occ = rdrNameOcc tc_name + gen_occs | want_generic = [mkGenOcc1 tc_occ, mkGenOcc2 tc_occ] + | otherwise = [] + mk_con_occs (ConDecl name _ _ _ _) + = [mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ] + where + con_occ = rdrNameOcc name -- The "source name" + +getSysBinders mod decl = returnM [] + +new_sys_bndr mod loc occ = newTopBinder mod (mkRdrUnqual occ) loc + ----------------------------------------------------- -- Loading fixity decls ----------------------------------------------------- -loadFixDecls mod decls - = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add -> - returnRn (mkNameEnv to_add) - where - mod_name = moduleName mod +loadFixDecls decls + = mappM loadFixDecl decls `thenM` \ to_add -> + returnM (mkNameEnv to_add) -loadFixDecl mod_name (rdr_name, fixity) - = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> - returnRn (name, fixity) +loadFixDecl (FixitySig rdr_name fixity loc) + = lookupGlobalOccRn rdr_name `thenM` \ name -> + returnM (name, FixitySig name fixity loc) ----------------------------------------------------- -- Loading instance decls ----------------------------------------------------- -loadInstDecls :: Module - -> IfaceInsts +loadInstDecls :: Module -> IfaceInsts -> [RdrNameInstDecl] - -> RnM d IfaceInsts + -> RnM IfaceInsts loadInstDecls mod (insts, n_slurped) decls - = setModuleRn mod $ - foldlRn (loadInstDecl mod) insts decls `thenRn` \ insts' -> - returnRn (insts', n_slurped) + = foldlM (loadInstDecl mod) insts decls `thenM` \ insts' -> + returnM (insts', n_slurped) loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) @@ -386,19 +410,19 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) -- NOTICE that we rename the type before extracting its free -- variables. The free-variable finder for a renamed HsType -- does the Right Thing for built-in syntax like [] and (,). - initIfaceRnMS mod ( - rnHsType (text "In an interface instance decl") inst_ty - ) `thenRn` \ inst_ty' -> + rnHsType (text "In an interface instance decl") inst_ty `thenM` \ inst_ty' -> let - (tvs,(cls,tys)) = getHsInstHead inst_ty' + (tvs,_,cls,tys) = splitHsInstDeclTy inst_ty' free_tcs = nameSetToList (extractHsTyNames_s tys) `minusList` hsTyVarNames tvs gate_fn vis_fn = vis_fn cls && (null free_tcs || any vis_fn free_tcs) + -- The 'vis_fn' returns True for visible names -- Here is the implementation of HOWEVER above -- (Note that we do let the inst decl in if it mentions -- no tycons at all. Hence the null free_ty_names.) in - returnRn ((gate_fn, (mod, decl)) `consBag` insts) +-- traceRn ((text "Load instance for" <+> ppr inst_ty') $$ ppr free_tcs) `thenM_` + returnM ((gate_fn, (mod, decl)) `consBag` insts) @@ -406,81 +430,117 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) -- Loading Rules ----------------------------------------------------- -loadRules :: Module -> IfaceRules +loadRules :: Module + -> IfaceRules -> (Version, [RdrNameRuleDecl]) - -> RnM d (Version, IfaceRules) + -> RnM (Version, IfaceRules) loadRules mod (rule_bag, n_slurped) (version, rules) | null rules || opt_IgnoreIfacePragmas - = returnRn (version, (rule_bag, n_slurped)) + = returnM (version, (rule_bag, n_slurped)) | otherwise - = setModuleRn mod $ - mapRn (loadRule mod) rules `thenRn` \ new_rules -> - returnRn (version, (rule_bag `unionBags` listToBag new_rules, n_slurped)) + = mappM (loadRule mod) rules `thenM` \ new_rules -> + returnM (version, (rule_bag `unionBags` listToBag new_rules, n_slurped)) -loadRule :: Module -> RdrNameRuleDecl -> RnM d (GatedDecl RdrNameRuleDecl) +loadRule :: Module -> RdrNameRuleDecl -> RnM (GatedDecl RdrNameRuleDecl) -- "Gate" the rule simply by whether the rule variable is -- needed. We can refine this later. loadRule mod decl@(IfaceRule _ _ _ var _ _ src_loc) - = lookupIfaceName var `thenRn` \ var_name -> - returnRn (\vis_fn -> vis_fn var_name, (mod, decl)) + = lookupGlobalOccRn var `thenM` \ var_name -> + returnM (\vis_fn -> vis_fn var_name, (mod, decl)) ----------------------------------------------------- -- Loading Deprecations ----------------------------------------------------- -loadDeprecs :: Module -> IfaceDeprecs -> RnM d Deprecations -loadDeprecs m Nothing = returnRn NoDeprecs -loadDeprecs m (Just (Left txt)) = returnRn (DeprecAll txt) -loadDeprecs m (Just (Right prs)) = setModuleRn m $ - foldlRn loadDeprec emptyNameEnv prs `thenRn` \ env -> - returnRn (DeprecSome env) +loadDeprecs :: IfaceDeprecs -> RnM Deprecations +loadDeprecs Nothing = returnM NoDeprecs +loadDeprecs (Just (Left txt)) = returnM (DeprecAll txt) +loadDeprecs (Just (Right prs)) = foldlM loadDeprec emptyNameEnv prs `thenM` \ env -> + returnM (DeprecSome env) loadDeprec deprec_env (n, txt) - = lookupIfaceName n `thenRn` \ name -> - traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_` - returnRn (extendNameEnv deprec_env name (name,txt)) + = lookupGlobalOccRn n `thenM` \ name -> +-- traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenM_` + returnM (extendNameEnv deprec_env name (name,txt)) \end{code} -%********************************************************* +%******************************************************** %* * -\subsection{Getting binders out of a declaration} + Load the ParsedIface for the *current* module + into a ModIface; then it can be checked + for up-to-date-ness %* * -%********************************************************* - -@getDeclBinders@ returns the names for a @RdrNameHsDecl@. -It's used for both source code (from @availsFromDecl@) and interface files -(from @loadDecl@). - -It doesn't deal with source-code specific things: @ValD@, @DefD@. They -are handled by the sourc-code specific stuff in @RnNames@. - - *** See "THE NAMING STORY" in HsDecls **** - +%******************************************************** \begin{code} -getTyClDeclBinders - :: Module - -> RdrNameTyClDecl - -> RnM d (AvailInfo, [Name]) -- The [Name] are the system names - ------------------ -getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc}) - = newTopBinder mod var src_loc `thenRn` \ var_name -> - returnRn (Avail var_name, []) +loadOldIface :: ParsedIface -> RnM ModIface + +loadOldIface iface + = loadHomeDecls (pi_decls iface) `thenM` \ (decls_vers, new_decls) -> + loadHomeRules (pi_rules iface) `thenM` \ (rule_vers, new_rules) -> + loadHomeInsts (pi_insts iface) `thenM` \ new_insts -> + mappM loadHomeUsage (pi_usages iface) `thenM` \ usages -> + loadExports (pi_exports iface) `thenM` \ (export_vers, avails) -> + loadFixDecls (pi_fixity iface) `thenM` \ fix_env -> + loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env -> + + getModeRn `thenM` \ (InterfaceMode mod) -> + -- Caller sets the module before the call; also needed + -- by the newGlobalName stuff in some of the loadHomeX calls + let + version = VersionInfo { vers_module = pi_vers iface, + vers_exports = export_vers, + vers_rules = rule_vers, + vers_decls = decls_vers } -getTyClDeclBinders mod (CoreDecl {tcdName = var, tcdLoc = src_loc}) - = newTopBinder mod var src_loc `thenRn` \ var_name -> - returnRn (Avail var_name, []) + decls = mkIfaceDecls new_decls new_rules new_insts -getTyClDeclBinders mod tycl_decl - = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ names@(main_name:_) -> - new_top_bndrs mod (tyClDeclSysNames tycl_decl) `thenRn` \ sys_names -> - returnRn (AvailTC main_name names, sys_names) + mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface, + mi_version = version, mi_deps = pi_deps iface, + mi_exports = avails, mi_usages = usages, + mi_boot = False, mi_orphan = pi_orphan iface, + mi_fixities = fix_env, mi_deprecs = deprec_env, + mi_decls = decls, + mi_globals = Nothing + } + in + returnM mod_iface +\end{code} ------------------ -new_top_bndrs mod names_w_locs - = sequenceRn [newTopBinder mod name loc | (name,loc) <- names_w_locs] +\begin{code} +loadHomeDecls :: [(Version, RdrNameTyClDecl)] + -> RnM (NameEnv Version, [RenamedTyClDecl]) +loadHomeDecls decls = foldlM loadHomeDecl (emptyNameEnv, []) decls + +loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl]) + -> (Version, RdrNameTyClDecl) + -> RnM (NameEnv Version, [RenamedTyClDecl]) +loadHomeDecl (version_map, decls) (version, decl) + = rnTyClDecl decl `thenM` \ decl' -> + returnM (extendNameEnv version_map (tyClDeclName decl') version, decl':decls) + +------------------ +loadHomeRules :: (Version, [RdrNameRuleDecl]) + -> RnM (Version, [RenamedRuleDecl]) +loadHomeRules (version, rules) + = mappM rnIfaceRuleDecl rules `thenM` \ rules' -> + returnM (version, rules') + +------------------ +loadHomeInsts :: [RdrNameInstDecl] + -> RnM [RenamedInstDecl] +loadHomeInsts insts = mappM rnInstDecl insts + +------------------ +loadHomeUsage :: Usage OccName -> TcRn m (Usage Name) +loadHomeUsage usage + = mappM rn_imp (usg_entities usage) `thenM` \ entities' -> + returnM (usage { usg_entities = entities' }) + where + mod_name = usg_name usage + rn_imp (occ,vers) = newGlobalName2 mod_name occ `thenM` \ name -> + returnM (name,vers) \end{code} @@ -494,50 +554,40 @@ new_top_bndrs mod names_w_locs findAndReadIface :: SDoc -> ModuleName -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> RnM d (Either Message (Module, ParsedIface)) + -> TcRn m (Either Message (Module, ParsedIface)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed + -- It *doesn't* add an error to the monad, because + -- sometimes it's ok to fail... see notes with loadInterface + findAndReadIface doc_str mod_name hi_boot_file - = traceRn trace_msg `thenRn_` + = traceRn trace_msg `thenM_` -- Check for GHC.Prim, and return its static interface if mod_name == gHC_PRIM_Name - then returnRn (Right (gHC_PRIM, ghcPrimIface)) + then returnM (Right (gHC_PRIM, ghcPrimIface)) else - -- In interactive or --make mode, we are *not allowed* to demand-load - -- a home package .hi file. So don't even look for them. - -- This helps in the case where you are sitting in eg. ghc/lib/std - -- and start up GHCi - it won't complain that all the modules it tries - -- to load are found in the home location. - ioToRnM_no_fail (readIORef v_GhcMode) `thenRn` \ mode -> - let home_allowed = hi_boot_file || not (isCompManagerMode mode) - in - - ioToRnM (if home_allowed - then findModule mod_name - else findPackageModule mod_name) `thenRn` \ maybe_found -> + ioToTcRn (findHiFile mod_name hi_boot_file) `thenM` \ maybe_found -> case maybe_found of + Left files -> + traceRn (ptext SLIT("...not found")) `thenM_` + getDOpts `thenM` \ dflags -> + returnM (Left (noIfaceErr dflags mod_name hi_boot_file files)) - Right (Just (wanted_mod,locn)) - -> mkHiPath hi_boot_file locn `thenRn` \ file -> - readIface file `thenRn` \ read_result -> - case read_result of - Left bad -> returnRn (Left bad) - Right iface -> -- check that the module names agree - let read_mod_name = pi_mod iface - wanted_mod_name = moduleName wanted_mod - in - checkRn - (wanted_mod_name == read_mod_name) - (hiModuleNameMismatchWarn wanted_mod_name read_mod_name) - `thenRn_` - returnRn (Right (wanted_mod, iface)) - -- Can't find it - other -> traceRn (ptext SLIT("...not found")) `thenRn_` - returnRn (Left (noIfaceErr mod_name hi_boot_file)) + Right (wanted_mod, file_path) -> + traceRn (ptext SLIT("readIFace") <+> text file_path) `thenM_` + + readIface wanted_mod file_path hi_boot_file `thenM` \ read_result -> + -- Catch exceptions here + + case read_result of + Left exn -> returnM (Left (badIfaceFile file_path + (text (showException exn)))) + + Right iface -> returnM (Right (wanted_mod, iface)) where trace_msg = sep [hsep [ptext SLIT("Reading"), @@ -546,67 +596,107 @@ findAndReadIface doc_str mod_name hi_boot_file ppr mod_name <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)] -mkHiPath hi_boot_file locn - | hi_boot_file = - ioToRnM_no_fail (doesFileExist hi_boot_ver_path) `thenRn` \ b -> - if b then returnRn hi_boot_ver_path - else returnRn hi_boot_path - | otherwise = returnRn hi_path - where hi_path = ml_hi_file locn - (hi_base, _hi_suf) = splitFilename hi_path - hi_boot_path = hi_base ++ ".hi-boot" - hi_boot_ver_path = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion +findHiFile :: ModuleName -> IsBootInterface + -> IO (Either [FilePath] (Module, FilePath)) +findHiFile mod_name hi_boot_file + = do { + -- In interactive or --make mode, we are *not allowed* to demand-load + -- a home package .hi file. So don't even look for them. + -- This helps in the case where you are sitting in eg. ghc/lib/std + -- and start up GHCi - it won't complain that all the modules it tries + -- to load are found in the home location. + ghci_mode <- readIORef v_GhcMode ; + let { home_allowed = hi_boot_file || + not (isCompManagerMode ghci_mode) } ; + maybe_found <- if home_allowed + then findModule mod_name + else findPackageModule mod_name ; + + case maybe_found of { + Left files -> return (Left files) ; + + Right (mod,loc) -> do { + + -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate + let { hi_path = ml_hi_file loc ; + hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ; + hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt + }; + + if not hi_boot_file then + return (Right (mod, hi_path)) + else do { + hi_ver_exists <- doesFileExist hi_boot_ver_path ; + if hi_ver_exists then return (Right (mod, hi_boot_ver_path)) + else return (Right (mod, hi_boot_path)) + }}}} \end{code} @readIface@ tries just the one file. \begin{code} -readIface :: String -> RnM d (Either Message ParsedIface) +readIface :: Module -> String -> IsBootInterface -> TcRn m (Either Exception ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -readIface file_path - = --ioToRnM (putStrLn ("reading iface " ++ file_path)) `thenRn_` - traceRn (ptext SLIT("readIFace") <+> text file_path) `thenRn_` - - let hi_boot_ver = "hi-boot-" ++ cHscIfaceFileVersion in - if ".hi-boot" `isSuffixOf` file_path - || hi_boot_ver `isSuffixOf` file_path then - - ioToRnM (hGetStringBuffer file_path) `thenRn` \ read_result -> - case read_result of { - Left io_error -> bale_out (text (show io_error)); - Right contents -> - - case parseIface contents (mkPState loc exts) of { - POk _ iface -> returnRn (Right iface); - PFailed err -> bale_out err - }} - - else - ioToRnM_no_fail (myTry (Binary.getBinFileWithDict file_path)) - `thenRn` \ either_iface -> - - case either_iface of - Right iface -> returnRn (Right iface) - Left (DynException d) | Just e <- fromDynamic d - -> bale_out (text (show (e :: GhcException))) - - Left err -> bale_out (text (show err)) - where +readIface mod file_path is_hi_boot_file + = ioToTcRn (tryMost (read_iface mod file_path is_hi_boot_file)) + +read_iface mod file_path is_hi_boot_file + | is_hi_boot_file -- Read ascii + = do { buffer <- hGetStringBuffer file_path ; + case parseIface buffer (mkPState loc exts) of + POk _ iface | wanted_mod_name == actual_mod_name + -> return iface + | otherwise + -> throwDyn (ProgramError (showSDoc err)) + -- 'showSDoc' is a bit yukky + where + wanted_mod_name = moduleName mod + actual_mod_name = pi_mod iface + err = hiModuleNameMismatchWarn wanted_mod_name actual_mod_name + + PFailed err -> throwDyn (ProgramError (showSDoc err)) + } + + | otherwise -- Read binary + = readBinIface file_path + + where exts = ExtFlags {glasgowExtsEF = True, ffiEF = True, + arrowsEF = True, withEF = True, parrEF = True} loc = mkSrcLoc (mkFastString file_path) 1 +\end{code} - bale_out err = returnRn (Left (badIfaceFile file_path err)) -#if __GLASGOW_HASKELL__ < 501 -myTry = Exception.tryAllIO -#else -myTry = Exception.try -#endif +%********************************************************* +%* * + Wired-in interface for GHC.Prim +%* * +%********************************************************* + +\begin{code} +ghcPrimIface :: ParsedIface +ghcPrimIface = ParsedIface { + pi_mod = gHC_PRIM_Name, + pi_pkg = basePackage, + pi_deps = noDependencies, + pi_vers = 1, + pi_orphan = False, + pi_usages = [], + pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]), + pi_decls = [(1,cCallableClassDecl), + (1,cReturnableClassDecl)], + pi_fixity = [FixitySig (nameRdrName (idName seqId)) + (Fixity 0 InfixR) noSrcLoc], + -- seq is infixr 0 + pi_insts = [], + pi_rules = (1,[]), + pi_deprecs = Nothing + } \end{code} %********************************************************* @@ -616,12 +706,6 @@ myTry = Exception.try %********************************************************* \begin{code} -noIfaceErr mod_name boot_file - = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name) - -- We used to print the search path, but we can't do that - -- now, because it's hidden inside the finder. - -- Maybe the finder should expose more functions. - badIfaceFile file err = vcat [ptext SLIT("Bad interface file:") <+> text file, nest 4 err]