X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnHiFiles.lhs;h=82512dccef046e3b3ea33765214d123bc3123f84;hb=16e4ce4c0c02650082f2e11982017c903c549ad5;hp=4e067b9de5261c27e8e7de482040095b37d2be5b;hpb=90fa6b84fdc99ba99c0b7df9691ca69d50b62530;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 4e067b9..82512dc 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -5,54 +5,76 @@ \begin{code} module RnHiFiles ( - findAndReadIface, loadInterface, loadHomeInterface, - tryLoadInterface, loadOrphanModules, - loadExports, loadFixDecls, loadDeprecs, - - lookupFixityRn, - - getTyClDeclBinders, - removeContext -- removeContext probably belongs somewhere else + readIface, loadInterface, loadHomeInterface, + loadOrphanModules, + loadOldIface, + ParsedIface(..) ) where #include "HsVersions.h" +import DriverState ( v_GhcMode, isCompManagerMode ) +import DriverUtil ( replaceFilenameSuffix ) import CmdLineOpts ( opt_IgnoreIfacePragmas ) -import HscTypes -import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), - HsType(..), ConDecl(..), - FixitySig(..), RuleDecl(..), - tyClDeclNames - ) -import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl, - extractHsTyRdrNames +import Parser ( parseIface ) +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(..), ConDecl(..), + hsTyVarNames, splitHsInstDeclTy, tyClDeclName, tyClDeclNames ) -import BasicTypes ( Version, defaultFixity ) +import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) +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 ParseIface ( parseIface, IfaceStuff(..) ) +import TcRnMonad -import Name ( Name {-instance NamedThing-}, nameOccName, - nameModule, isLocallyDefined, - NamedThing(..), - mkNameEnv, extendNameEnv - ) -import Module ( Module, - moduleName, isModuleInThisPackage, - ModuleName, WhereFrom(..), - extendModuleEnv, lookupModuleEnvByName, - ) -import RdrName ( RdrName, rdrNameOcc ) +import PrelNames ( gHC_PRIM_Name, gHC_PRIM ) +import PrelInfo ( ghcPrimExports, cCallableClassDecl, cReturnableClassDecl ) +import Name ( Name {-instance NamedThing-}, + nameModule, isInternalName ) +import NameEnv import NameSet -import SrcLoc ( mkSrcLoc, SrcLoc ) -import Maybes ( maybeToBool, orElse ) +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, + hiBootExt, hiBootVerExt ) import Lex import FiniteMap +import ListSetOps ( minusList ) import Outputable import Bag +import BinIface ( readBinIface ) +import Panic + +import EXCEPTION as Exception +import DATA_IOREF ( readIORef ) + +import Directory \end{code} @@ -63,51 +85,66 @@ import Bag %********************************************************* \begin{code} -loadHomeInterface :: SDoc -> Name -> RnM d Ifaces +loadHomeInterface :: SDoc -> Name -> TcRn m ModIface loadHomeInterface doc_str name - = loadInterface doc_str (moduleName (nameModule name)) ImportBySystem + = 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 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 --> (..., True) - -- (If the load fails, we plug in a vanilla placeholder) -tryLoadInterface doc_str mod_name from - = getHomeIfaceTableRn `thenRn` \ hit -> - getIfacesRn `thenRn` \ ifaces -> - - -- Check whether we have it already in the home package - case lookupModuleEnvByName hit mod_name of { - Just _ -> returnRn (ifaces, Nothing) ; -- In the home package - Nothing -> +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. + +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 hpt pit mod_name of { + Just iface | case from of + 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 + -- before we got to real imports. + 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 - (ImportBySystem, Just (_, is_boot, _)) -> is_boot -- - (ImportBySystem, Nothing) -> False + (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 -- nothing about, so we assume it's from -- another package, where we aren't doing @@ -115,39 +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 - -- CHECK WHETHER WE HAVE IT ALREADY - case mod_info of { - Just (_, _, True) - -> -- We're read it already so don't re-read it - returnRn (ifaces, Nothing) ; - - _ -> -- 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 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 -> + findAndReadIface doc_str mod_name hi_boot_file + `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 - new_mod_map = addToFM mod_map mod_name (False, False, True) - new_ifaces = ifaces { iImpModInfo = new_mod_map } - in - setIfacesRn new_ifaces `thenRn_` - returnRn (new_ifaces, 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). @@ -159,125 +207,71 @@ tryLoadInterface doc_str mod_name from -- about, it should be from a different package to this one WARN( not (maybeToBool mod_info) && case from of { ImportBySystem -> True; other -> False } && - isModuleInThisPackage mod, + 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) -> - foldlRn (loadInstDecl 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. - mod_map1 = case from of - ImportByUser -> addModDeps mod (pi_usages iface) mod_map - other -> mod_map - mod_map2 = addToFM mod_map1 mod_name (has_orphans, hi_boot_file, True) - -- 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 (iPIT ifaces) mod mod_iface - mod_iface = ModIface { mi_module = mod, mi_version = version, - mi_exports = avails, mi_orphan = has_orphans, + new_pit = extendModuleEnv pit mod mod_iface + mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface, + mi_version = version, + 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 = panic "No mi_globals in PIT" + 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 (new_ifaces, Nothing) - }}} - ------------------------------------------------------ --- 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 - -- 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, IsLoaded))] - filtered_new_deps - | isModuleInThisPackage mod - = [ (imp_mod, (has_orphans, is_boot, False)) - | (imp_mod, has_orphans, is_boot, _) <- new_deps - ] - | otherwise = [ (imp_mod, (True, False, False)) - | (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, old_is_loaded) new - | old_is_loaded || 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 - + setEps new_eps `thenM_` + returnM mod_iface + }} ----------------------------------------------------- -- Loading the export list ----------------------------------------------------- -loadExports :: (Version, [ExportItem]) -> RnM d (Version, Avails) +loadExports :: (Version, [RdrExportItem]) -> TcRn m (Version, [(ModuleName,Avails)]) loadExports (vers, items) - = getModuleRn `thenRn` \ this_mod -> - mapRn (loadExport this_mod) items `thenRn` \ avails_s -> - returnRn (vers, concat avails_s) - - -loadExport :: Module -> ExportItem -> RnM d [AvailInfo] -loadExport this_mod (mod, entities) - | 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 - -- filter them out up front. This situation only arises if a module - -- imports itself, or another module that imported it. (Necessarily, - -- this invoves a loop.) Consequence: if you say - -- module A where - -- import B( AType ) - -- type AType = ... - -- - -- module B( AType ) where - -- import {-# SOURCE #-} A( AType ) - -- - -- then you'll get a 'B does not export AType' message. A bit bogus - -- but it's a bogus thing to do! + = mappM loadExport items `thenM` \ avails_s -> + returnM (vers, avails_s) - | otherwise - = mapRn (load_entity mod) entities - where - new_name mod occ = newGlobalName mod occ +loadExport :: RdrExportItem -> TcRn m (ModuleName, Avails) +loadExport (mod, entities) + = mappM (load_entity mod) entities `thenM` \ avails -> + returnM (mod, avails) + where load_entity mod (Avail occ) - = new_name mod occ `thenRn` \ name -> - returnRn (Avail name) + = newGlobalName2 mod occ `thenM` \ name -> + returnM (Avail name) load_entity mod (AvailTC occ occs) - = new_name mod occ `thenRn` \ name -> - mapRn (new_name mod) occs `thenRn` \ names -> - returnRn (AvailTC name names) + = newGlobalName2 mod occ `thenM` \ name -> + mappM (newGlobalName2 mod) occs `thenM` \ names -> + returnM (AvailTC name names) ----------------------------------------------------- @@ -287,17 +281,18 @@ loadExport this_mod (mod, entities) loadDecls :: Module -> DeclsMap -> [(Version, RdrNameTyClDecl)] - -> RnM d (NameEnv Version, DeclsMap) -loadDecls mod decls_map decls - = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls - -loadDecl :: Module - -> (NameEnv Version, DeclsMap) - -> (Version, RdrNameTyClDecl) - -> RnM d (NameEnv Version, DeclsMap) + -> TcRn m (NameEnv Version, DeclsMap) +loadDecls mod (decls_map, n_slurped) decls + = 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) - = getIfaceDeclBinders new_name decl `thenRn` \ full_avail -> + = getTyClDeclBinders mod decl `thenM` \ avail -> + getSysBinders mod decl `thenM` \ sys_names -> let + full_avail = case avail of + Avail n -> avail + AvailTC n ns -> AvailTC n (sys_names ++ ns) main_name = availName full_avail new_decls_map = extendNameEnvList decls_map stuff stuff = [ (name, (full_avail, name==main_name, (mod, decl))) @@ -305,43 +300,92 @@ loadDecl mod (version_map, decls_map) (version, decl) new_version_map = extendNameEnv version_map main_name version in - 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 - -- 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. - -- 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 rdr_name loc + 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 sig@(FixitySig rdr_name fixity loc) - = 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 ----------------------------------------------------- -loadInstDecl :: Module - -> IfaceInsts - -> RdrNameInstDecl - -> 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 +loadInstDecls :: Module -> IfaceInsts + -> [RdrNameInstDecl] + -> RnM IfaceInsts +loadInstDecls mod (insts, n_slurped) decls + = foldlM (loadInstDecl mod) insts decls `thenM` \ insts' -> + returnM (insts', n_slurped) + + +loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) + = -- Find out what type constructors and classes are "gates" for the -- instance declaration. If all these "gates" are slurped in then -- we should slurp the instance decl too. -- @@ -350,126 +394,156 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) -- instance Foo a => Baz (T a) where ... -- -- Here the gates are Baz and T, but *not* Foo. + -- + -- HOWEVER: functional dependencies make things more complicated + -- class C a b | a->b where ... + -- instance C Foo Baz where ... + -- Here, the gates are really only C and Foo, *not* Baz. + -- That is, if C and Foo are visible, even if Baz isn't, we must + -- slurp the decl. + -- + -- Rather than take fundeps into account "properly", we just slurp + -- if C is visible and *any one* of the Names in the types + -- This is a slightly brutal approximation, but most instance decls + -- are regular H98 ones and it's perfect for them. + -- + -- 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 (,). + rnHsType (text "In an interface instance decl") inst_ty `thenM` \ inst_ty' -> let - munged_inst_ty = removeContext inst_ty - free_names = extractHsTyRdrNames munged_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 - setModuleRn mod $ - mapRn lookupOrigName free_names `thenRn` \ gate_names -> - returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts) - - --- In interface files, the instance decls now look like --- forall a. Foo a -> Baz (T a) --- so we have to strip off function argument types as well --- as the bit before the '=>' (which is always empty in interface files) -removeContext (HsForAllTy tvs cxt ty) = HsForAllTy tvs [] (removeFuns ty) -removeContext ty = removeFuns ty +-- traceRn ((text "Load instance for" <+> ppr inst_ty') $$ ppr free_tcs) `thenM_` + returnM ((gate_fn, (mod, decl)) `consBag` insts) -removeFuns (HsFunTy _ ty) = removeFuns ty -removeFuns ty = ty ----------------------------------------------------- -- Loading Rules ----------------------------------------------------- -loadRules :: Module -> IfaceRules +loadRules :: Module + -> IfaceRules -> (Version, [RdrNameRuleDecl]) - -> RnM d (Version, IfaceRules) -loadRules mod rule_bag (version, rules) + -> RnM (Version, IfaceRules) +loadRules mod (rule_bag, n_slurped) (version, rules) | null rules || opt_IgnoreIfacePragmas - = returnRn (version, rule_bag) + = returnM (version, (rule_bag, n_slurped)) | otherwise - = setModuleRn mod $ - mapRn (loadRule mod) rules `thenRn` \ new_rules -> - returnRn (version, rule_bag `unionBags` listToBag new_rules) + = mappM (loadRule mod) rules `thenM` \ new_rules -> + returnM (version, (rule_bag `unionBags` listToBag new_rules, n_slurped)) -loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl +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) - = lookupOrigName var `thenRn` \ var_name -> - returnRn (unitNameSet var_name, (mod, RuleD decl)) +loadRule mod decl@(IfaceRule _ _ _ var _ _ src_loc) + = 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) - = lookupOrigName n `thenRn` \ name -> - traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_` - returnRn (extendNameEnv deprec_env 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@. +%******************************************************** \begin{code} -getIfaceDeclBinders, getTyClDeclBinders - :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function - -> RdrNameTyClDecl - -> RnM d AvailInfo - -getIfaceDeclBinders new_name tycl_decl - = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail -> - getSysTyClDeclBinders new_name tycl_decl `thenRn` \ extras -> - returnRn (addSysAvails avail extras) - -- Add the sys-binders to avail. When we import the decl, - -- it's full_avail that will get added to the 'already-slurped' set (iSlurp) - -- If we miss out sys-binders, we'll read the decl multiple times! - -getTyClDeclBinders new_name (IfaceSig var ty prags src_loc) - = new_name var src_loc `thenRn` \ var_name -> - returnRn (Avail var_name) - -getTyClDeclBinders new_name tycl_decl - = mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) -> - returnRn (AvailTC main_name (main_name : sub_names)) - where - do_one (name,loc) = new_name name loc -\end{code} +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 } -@getDeclSysBinders@ gets the implicit binders introduced by a decl. -A the moment that's just the tycon and datacon that come with a class decl. -They aren't returned by @getDeclBinders@ because they aren't in scope; -but they {\em should} be put into the @DeclsMap@ of this module. + decls = mkIfaceDecls new_decls new_rules new_insts -Note that this excludes the default-method names of a class decl, -and the dict fun of an instance decl, because both of these have -bindings of their own elsewhere. + 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} \begin{code} -getSysTyClDeclBinders new_name (ClassDecl _ cname _ _ sigs _ names src_loc) - = sequenceRn [new_name n src_loc | n <- names] - -getSysTyClDeclBinders new_name (TyData _ _ _ _ cons _ _ _ _ _) - = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons] - -getSysTyClDeclBinders new_name other_decl - = returnRn [] +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} - %********************************************************* %* * \subsection{Reading an interface file} @@ -480,24 +554,40 @@ getSysTyClDeclBinders new_name other_decl 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_` - getFinderRn `thenRn` \ finder -> - ioToRnM (finder mod_name) `thenRn` \ maybe_found -> + -- Check for GHC.Prim, and return its static interface + if mod_name == gHC_PRIM_Name + then returnM (Right (gHC_PRIM, ghcPrimIface)) + else + + ioToTcRn (findHiFile mod_name hi_boot_file) `thenM` \ maybe_found -> case maybe_found of - Right (Just (mod,locn)) - | hi_boot_file -> readIface mod (hi_file locn ++ "-hi-boot") - | otherwise -> readIface mod (hi_file locn) - - -- Can't find it - other -> traceRn (ptext SLIT("...not found")) `thenRn_` - returnRn (Left (noIfaceErr mod_name hi_boot_file)) + Left files -> + traceRn (ptext SLIT("...not found")) `thenM_` + getDOpts `thenM` \ dflags -> + returnM (Left (noIfaceErr dflags mod_name hi_boot_file files)) + + 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"), @@ -505,77 +595,110 @@ findAndReadIface doc_str mod_name hi_boot_file ptext SLIT("interface for"), ppr mod_name <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)] + +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 :: Module -> String -> RnM d (Either Message (Module, 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 wanted_mod file_path - = traceRn (ptext SLIT("...reading from") <+> text file_path) `thenRn_` - ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result -> - case read_result of - Right contents -> - case parseIface contents - PState{ bol = 0#, atbol = 1#, - context = [], - glasgow_exts = 1#, - loc = mkSrcLoc (mkFastString file_path) 1 } of - POk _ (PIface iface) -> - warnCheckRn (wanted_mod == read_mod) - (hiModuleNameMismatchWarn wanted_mod read_mod) `thenRn_` - returnRn (Right (wanted_mod, iface)) - where - read_mod = 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)) + +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} %********************************************************* -%* * -\subsection{Looking up fixities} -%* * +%* * + Wired-in interface for GHC.Prim +%* * %********************************************************* -This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface - \begin{code} -lookupFixityRn :: Name -> RnMS Fixity -lookupFixityRn name - | isLocallyDefined name - = getFixityEnv `thenRn` \ local_fix_env -> - returnRn (lookupLocalFixity local_fix_env name) - - | otherwise -- Imported - -- For imported names, we have to get their fixities by doing a loadHomeInterface, - -- and consulting the Ifaces that comes back from that, because the interface - -- file for the Name might not have been loaded yet. Why not? Suppose you import module A, - -- which exports a function 'f', which is defined in module B. Then B isn't loaded - -- right away (after all, it's possible that nothing from B will be used). - -- 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. - = getHomeIfaceTableRn `thenRn` \ hit -> - loadHomeInterface doc name `thenRn` \ ifaces -> - case lookupTable hit (iPIT ifaces) name of - Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity) - Nothing -> returnRn defaultFixity - where - doc = ptext SLIT("Checking fixity for") <+> ppr name +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} - %********************************************************* %* * \subsection{Errors} @@ -583,20 +706,14 @@ lookupFixityRn name %********************************************************* \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] -hiModuleNameMismatchWarn :: Module -> Module -> Message +hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message hiModuleNameMismatchWarn requested_mod read_mod = hsep [ ptext SLIT("Something is amiss; requested module name") - , ppr (moduleName requested_mod) + , ppr requested_mod , ptext SLIT("differs from name found in the interface file") , ppr read_mod ] @@ -604,5 +721,7 @@ hiModuleNameMismatchWarn requested_mod read_mod = warnRedundantSourceImport mod_name = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") <+> quotes (ppr mod_name) -\end{code} +warnSelfImport mod + = ptext SLIT("Importing my own interface: module") <+> ppr mod +\end{code}