X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FLoadIface.lhs;h=8c496f76efcbfe12d315629e66b90fc854fc28c7;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=579c09d8e06b382d3c348fce23cf92803f6680b5;hpb=c73c3891abaa5ed50d897e82ee9291054a5c9a0b;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index 579c09d..8c496f7 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -5,86 +5,67 @@ \begin{code} module LoadIface ( - loadHomeInterface, loadInterface, - loadSrcInterface, loadOrphanModules, loadHiBootInterface, - readIface, -- Used when reading the module's old interface - predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags, - initExternalPackageState, - noIfaceErr, -- used by CompManager too + loadInterface, loadHomeInterface, loadWiredInHomeIface, + loadSrcInterface, loadSysInterface, loadOrphanModules, + findAndReadIface, readIface, -- Used when reading the module's old interface + loadDecls, ifaceStats, discardDeclPrags, + initExternalPackageState ) where #include "HsVersions.h" -import {-# SOURCE #-} TcIface( tcIfaceDecl ) - -import Packages ( PackageState(..), isHomeModule ) -import DriverState ( v_GhcMode, isCompManagerMode ) -import DriverUtil ( replaceFilenameSuffix ) -import CmdLineOpts ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) -import Parser ( parseIface ) +import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst ) +import Packages ( PackageState(..), PackageIdH(..), isHomePackage ) +import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ), + isOneShot ) import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), - IfaceConDecls(..), IfaceInst(..), IfaceRule(..), - IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), - IfaceType(..), IfacePredType(..), IfaceExtName, - mkIfaceExtName ) -import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc, - lookupOrig ) + IfaceConDecls(..), IfaceIdInfo(..) ) +import IfaceEnv ( newGlobalBinder ) import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats, ExternalPackageState(..), - PackageTypeEnv, emptyTypeEnv, IfacePackage(..), + PackageTypeEnv, emptyTypeEnv, HscEnv(..), lookupIfaceByModule, emptyPackageIfaceTable, - IsBootInterface, mkIfaceFixCache, Gated, - implicitTyThings, addRulesToPool, addInstsToPool, - availNames + IsBootInterface, mkIfaceFixCache, + implicitTyThings ) import BasicTypes ( Version, Fixity(..), FixityDirection(..), isMarkedStrict ) -import TcType ( Type, tcSplitTyConApp_maybe ) -import Type ( funTyCon ) import TcRnMonad import PrelNames ( gHC_PRIM ) import PrelInfo ( ghcPrimExports ) import PrelRules ( builtinRules ) -import Rules ( emptyRuleBase ) -import InstEnv ( emptyInstEnv ) +import Rules ( extendRuleBaseList, mkRuleBase ) +import InstEnv ( emptyInstEnv, extendInstEnvList ) import Name ( Name {-instance NamedThing-}, getOccName, - nameModule, isInternalName ) + nameModule, nameIsLocalOrFrom, isWiredInName ) import NameEnv import MkId ( seqId ) import Module ( Module, ModLocation(ml_hi_file), emptyModuleEnv, - extendModuleEnv, lookupModuleEnv, moduleUserString + addBootSuffix_maybe, + extendModuleEnv, lookupModuleEnv, moduleString ) import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc ) -import Class ( Class, className ) -import TyCon ( tyConName ) -import SrcLoc ( mkSrcLoc, importedSrcLoc ) -import Maybes ( isJust, mapCatMaybes ) -import StringBuffer ( hGetStringBuffer ) +import SrcLoc ( importedSrcLoc ) +import Maybes ( MaybeErr(..) ) import FastString ( mkFastString ) -import ErrUtils ( Message, mkLocMessage ) -import Finder ( findModule, findPackageModule, FindResult(..), - hiBootExt, hiBootVerExt ) -import Lexer +import ErrUtils ( Message ) +import Finder ( findModule, findPackageModule, FindResult(..), cantFindError ) import Outputable import BinIface ( readBinIface ) -import Panic +import Panic ( ghcError, tryMost, showException, GhcException(..) ) import List ( nub ) - -import DATA_IOREF ( readIORef ) - -import Directory \end{code} %************************************************************************ %* * - loadSrcInterface, loadOrphanModules + loadSrcInterface, loadOrphanModules, loadHomeInterface - These two are called from TcM-land + These three are called from TcM-land %* * %************************************************************************ @@ -93,52 +74,18 @@ loadSrcInterface :: SDoc -> Module -> IsBootInterface -> RnM ModIface -- This is called for each 'import' declaration in the source code -- On a failure, fail in the monad with an error message -loadSrcInterface doc mod_name want_boot - = do { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name - (ImportByUser want_boot) +loadSrcInterface doc mod want_boot + = do { mb_iface <- initIfaceTcRn $ + loadInterface doc mod (ImportByUser want_boot) ; case mb_iface of - Left err -> failWithTc (elaborate err) - Right iface -> return iface + Failed err -> failWithTc (elaborate err) + Succeeded iface -> return iface } where elaborate err = hang (ptext SLIT("Failed to load interface for") <+> - quotes (ppr mod_name) <> colon) 4 err - -loadHiBootInterface :: TcRn [Name] --- Load the hi-boot iface for the module being compiled, --- if it indeed exists in the transitive closure of imports --- Return the list of names exported by the hi-boot file -loadHiBootInterface - = do { eps <- getEps - ; mod <- getModule - - ; traceIf (text "loadHiBootInterface" <+> ppr mod) - - -- We're read all the direct imports by now, so eps_is_boot will - -- record if any of our imports mention us by way of hi-boot file - ; case lookupModuleEnv (eps_is_boot eps) mod of { - Nothing -> return [] ; -- The typical case - - Just (_, False) -> -- Someone below us imported us! - -- This is a loop with no hi-boot in the way - failWithTc (moduleLoop mod) ; - - Just (mod_nm, True) -> -- There's a hi-boot interface below us - - - do { -- Load it (into the PTE, and return the exported names - iface <- loadSrcInterface (mk_doc mod_nm) mod_nm True - ; sequenceM [ lookupOrig mod_nm occ - | (mod,avails) <- mi_exports iface, - avail <- avails, occ <- availNames avail] - }}} - where - mk_doc mod = ptext SLIT("Need the hi-boot interface for") <+> ppr mod - <+> ptext SLIT("to compare against the Real Thing") - - moduleLoop mod = ptext SLIT("Circular imports: module") <+> quotes (ppr mod) - <+> ptext SLIT("depends on itself") + quotes (ppr mod) <> colon) 4 err +--------------- loadOrphanModules :: [Module] -> TcM () loadOrphanModules mods | null mods = returnM () @@ -150,28 +97,37 @@ loadOrphanModules mods where load mod = loadSysInterface (mk_doc mod) mod mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") -\end{code} - -%********************************************************* -%* * - loadHomeInterface - Called from Iface-land -%* * -%********************************************************* -\begin{code} -loadHomeInterface :: SDoc -> Name -> IfM lcl ModIface +--------------- +loadHomeInterface :: SDoc -> Name -> TcRn ModIface loadHomeInterface doc name - = ASSERT2( not (isInternalName name), ppr name <+> parens doc ) - loadSysInterface doc (nameModule name) + = do { +#ifdef DEBUG + -- Should not be called with a name from the module being compiled + this_mod <- getModule + ; ASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) +#endif + initIfaceTcRn $ loadSysInterface doc (nameModule name) + } + +--------------- +loadWiredInHomeIface :: Name -> IfM lcl () +-- A IfM function to load the home interface for a wired-in thing, +-- so that we're sure that we see its instance declarations and rules +loadWiredInHomeIface name + = ASSERT( isWiredInName name ) + do { loadSysInterface doc (nameModule name); return () } + where + doc = ptext SLIT("Need home interface for wired-in thing") <+> ppr name +--------------- loadSysInterface :: SDoc -> Module -> IfM lcl ModIface -- A wrapper for loadInterface that Throws an exception if it fails loadSysInterface doc mod_name = do { mb_iface <- loadInterface doc mod_name ImportBySystem ; case mb_iface of - Left err -> ghcError (ProgramError (showSDoc err)) - Right iface -> return iface } + Failed err -> ghcError (ProgramError (showSDoc err)) + Succeeded iface -> return iface } \end{code} @@ -187,7 +143,8 @@ loadSysInterface doc mod_name \begin{code} loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (Either Message ModIface) + -> IfM lcl (MaybeErr Message ModIface) + -- If it can't find a suitable interface file, we -- a) modify the PackageIfaceTable to have an empty entry -- (to avoid repeated complaints) @@ -195,19 +152,18 @@ loadInterface :: SDoc -> Module -> WhereFrom -- -- It's not necessarily an error for there not to be an interface -- file -- perhaps the module has changed, and that interface --- is no longer used -- but the caller can deal with that by --- catching the exception +-- is no longer used -loadInterface doc_str mod_name from +loadInterface doc_str mod from = do { -- Read the state (eps,hpt) <- getEpsAndHpt - ; traceIf (text "Considering whether to load" <+> ppr mod_name <+> ppr from) + ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) -- Check whether we have the interface already - ; case lookupIfaceByModule hpt (eps_PIT eps) mod_name of { + ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { Just iface - -> returnM (Right iface) ; -- Already loaded + -> returnM (Succeeded iface) ; -- Already loaded -- The (src_imp == mi_boot iface) test checks that the already-loaded -- interface isn't a boot iface. This can conceivably happen, -- if an earlier import had a before we got to real imports. I think. @@ -217,7 +173,7 @@ loadInterface doc_str mod_name from ImportByUser usr_boot -> usr_boot ImportBySystem -> sys_boot - ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod_name + ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod ; sys_boot = case mb_dep of Just (_, is_boot) -> is_boot Nothing -> False @@ -227,32 +183,33 @@ loadInterface doc_str mod_name from -- READ THE MODULE IN ; let explicit | ImportByUser _ <- from = True | otherwise = False - ; read_result <- findAndReadIface explicit doc_str mod_name hi_boot_file + ; read_result <- findAndReadIface explicit doc_str mod hi_boot_file ; dflags <- getDOpts ; case read_result of { - Left err -> do - { let fake_iface = emptyModIface ThisPackage mod_name + Failed err -> do + { let fake_iface = emptyModIface HomePackage mod ; updateEps_ $ \eps -> eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } -- Not found, so add an empty iface to -- the EPS map so that we don't look again - ; returnM (Left err) } ; + ; returnM (Failed err) } ; -- Found and parsed! - Right iface -> + Succeeded (iface, file_path) -- Sanity check: + | ImportBySystem <- from, -- system-importing... + isHomePackage (mi_package iface), -- ...a home-package module + Nothing <- mb_dep -- ...that we know nothing about + -> returnM (Failed (badDepMsg mod)) - let { mod = mi_module iface } in + | otherwise -> - -- 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( case from of { ImportBySystem -> True; other -> False } && - not (isJust mb_dep) && - isHomeModule dflags mod, - ppr mod $$ ppr mb_dep $$ ppr (eps_is_boot eps) ) + let + loc_doc = text file_path + in + initIfaceLcl mod loc_doc $ do - initIfaceLcl mod_name $ do -- Load the new ModIface into the External Package State -- Even home-package interfaces loaded by loadInterface -- (which only happens in OneShot mode; in Batch/Interactive @@ -269,25 +226,32 @@ 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) - { ignore_prags <- doptM Opt_IgnoreInterfacePragmas - ; new_eps_decls <- loadDecls ignore_prags mod (mi_decls iface) - ; new_eps_rules <- loadRules ignore_prags mod_name (mi_rules iface) - ; new_eps_insts <- loadInsts mod_name (mi_insts iface) + ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas + ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) + ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) + ; new_eps_rules <- if ignore_prags + then return [] + else mapM tcIfaceRule (mi_rules iface) ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT", mi_insts = panic "No mi_insts in PIT", mi_rules = panic "No mi_rules in PIT" } } ; updateEps_ $ \ eps -> - eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, - eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, - eps_rules = addRulesToPool (eps_rules eps) new_eps_rules, - eps_insts = addInstsToPool (eps_insts eps) new_eps_insts, - eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) - (length new_eps_insts) (length new_eps_rules) } + eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, + eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, + eps_rule_base = extendRuleBaseList (eps_rule_base eps) new_eps_rules, + eps_inst_env = extendInstEnvList (eps_inst_env eps) new_eps_insts, + eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) + (length new_eps_insts) (length new_eps_rules) } + + ; return (Succeeded final_iface) + }}}} - ; return (Right final_iface) - }}}}} +badDepMsg mod + = hang (ptext SLIT("Interface file inconsistency:")) + 2 (sep [ptext SLIT("home-package module") <+> quotes (ppr mod) <+> ptext SLIT("is mentioned,"), + ptext SLIT("but does not appear in the dependencies of the interface")]) ----------------------------------------------------- -- Loading type/class/value decls @@ -298,23 +262,35 @@ loadInterface doc_str mod_name from -- the declaration itself, will find the fully-glorious Name ----------------------------------------------------- -addDeclsToPTE :: PackageTypeEnv -> [[(Name,TyThing)]] -> PackageTypeEnv -addDeclsToPTE pte things = foldl extendNameEnvList pte things +addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv +addDeclsToPTE pte things = extendNameEnvList pte things -loadDecls :: Bool -- Don't load pragmas into the decl pool - -> Module +loadDecls :: Bool -> [(Version, IfaceDecl)] - -> IfL [[(Name,TyThing)]] -- The list can be poked eagerly, but the - -- TyThings are forkM'd thunks -loadDecls ignore_prags mod decls = mapM (loadDecl ignore_prags mod) decls + -> IfL [(Name,TyThing)] +loadDecls ignore_prags ver_decls + = do { mod <- getIfModule + ; thingss <- mapM (loadDecl ignore_prags mod) ver_decls + ; return (concat thingss) + } +loadDecl :: Bool -- Don't load pragmas into the decl pool + -> Module + -> (Version, IfaceDecl) + -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the + -- TyThings are forkM'd thunks loadDecl ignore_prags mod (_version, decl) = do { -- Populate the name cache with final versions of all -- the names associated with the decl - main_name <- mk_new_bndr Nothing (ifName decl) - ; implicit_names <- mapM (mk_new_bndr (Just main_name)) (ifaceDeclSubBndrs decl) + main_name <- mk_new_bndr mod Nothing (ifName decl) + ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl) -- Typecheck the thing, lazily + -- NB. firstly, the laziness is there in case we never need the + -- declaration (in one-shot mode), and secondly it is there so that + -- we don't look up the occurrence of a name before calling mk_new_bndr + -- on the binder. This is important because we must get the right name + -- which includes its nameParent. ; thing <- forkM doc (bumpDeclStats main_name >> tcIfaceDecl stripped_decl) ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] lookup n = case lookupOccEnv mini_env (getOccName n) of @@ -331,12 +307,13 @@ loadDecl ignore_prags mod (_version, decl) -- mk_new_bndr allocates in the name cache the final canonical -- name for the thing, with the correct - -- * package info -- * parent -- * location -- imported name, to fix the module correctly in the cache - mk_new_bndr mb_parent occ = newGlobalBinder mod occ mb_parent loc - loc = importedSrcLoc (moduleUserString mod) + mk_new_bndr mod mb_parent occ + = newGlobalBinder mod occ mb_parent + (importedSrcLoc (moduleString mod)) + doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) discardDeclPrags :: IfaceDecl -> IfaceDecl @@ -352,7 +329,7 @@ bumpDeclStats name ----------------- ifaceDeclSubBndrs :: IfaceDecl -> [OccName] --- *Excludes* the 'main' name, but *includes* the implicitly-bound names +-- *Excludes* the 'main' name, but *includes* the implicitly-bound names -- Deeply revolting, because it has to predict what gets bound, -- especially the question of whether there's a wrapper for a datacon @@ -377,7 +354,7 @@ ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con = fields ++ [con_occ, mkDataConWrapperOcc con_occ] -- Wrapper, no worker; see MkId.mkDataConIds -ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon _ cons}) +ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) = nub (concatMap fld_occs cons) -- Eliminate duplicate fields ++ concatMap dc_occs cons where @@ -396,137 +373,6 @@ ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon _ cons}) ifaceDeclSubBndrs _other = [] ------------------------------------------------------ --- Loading instance decls ------------------------------------------------------ - -loadInsts :: Module -> [IfaceInst] -> IfL [(Name, Gated IfaceInst)] -loadInsts mod decls = mapM (loadInstDecl mod) decls - -loadInstDecl mod decl@(IfaceInst {ifInstHead = inst_ty}) - = do { - -- 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. - -- - -- We *don't* want to count names in the context part as gates, though. - -- For example: - -- 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 (,). - let { (cls_ext, tc_exts) = ifaceInstGates inst_ty } - ; cls <- lookupIfaceExt cls_ext - ; tcs <- mapM lookupIfaceTc tc_exts - ; returnM (cls, (tcs, (mod,decl))) - } - ------------------------------------------------------ --- Loading Rules ------------------------------------------------------ - -loadRules :: Bool -- Don't load pragmas into the decl pool - -> Module - -> [IfaceRule] -> IfL [Gated IfaceRule] -loadRules ignore_prags mod rules - | ignore_prags = returnM [] - | otherwise = mapM (loadRule mod) rules - -loadRule :: Module -> IfaceRule -> IfL (Gated IfaceRule) --- "Gate" the rule simply by a crude notion of the free vars of --- the LHS. It can be crude, because having too few free vars is safe. -loadRule mod decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args}) - = do { names <- mapM lookupIfaceExt (fn : arg_fvs) - ; returnM (names, (mod, decl)) } - where - arg_fvs = [n | arg <- args, n <- crudeIfExprGblFvs arg] - - ---------------------------- -crudeIfExprGblFvs :: IfaceExpr -> [IfaceExtName] --- A crude approximation to the free external names of an IfExpr --- Returns a subset of the true answer -crudeIfExprGblFvs (IfaceType ty) = get_tcs ty -crudeIfExprGblFvs (IfaceExt v) = [v] -crudeIfExprGblFvs other = [] -- Well, I said it was crude - -get_tcs :: IfaceType -> [IfaceExtName] --- Get a crude subset of the TyCons of an IfaceType -get_tcs (IfaceTyVar _) = [] -get_tcs (IfaceAppTy t1 t2) = get_tcs t1 ++ get_tcs t2 -get_tcs (IfaceFunTy t1 t2) = get_tcs t1 ++ get_tcs t2 -get_tcs (IfaceForAllTy _ t) = get_tcs t -get_tcs (IfacePredTy st) = case st of - IfaceClassP cl ts -> get_tcs_s ts - IfaceIParam _ t -> get_tcs t -get_tcs (IfaceTyConApp (IfaceTc tc) ts) = tc : get_tcs_s ts -get_tcs (IfaceTyConApp other ts) = get_tcs_s ts - --- The lists are always small => appending is fine -get_tcs_s :: [IfaceType] -> [IfaceExtName] -get_tcs_s tys = foldr ((++) . get_tcs) [] tys -\end{code} - - -%********************************************************* -%* * - Gating -%* * -%********************************************************* - -Extract the gates of an instance declaration - -\begin{code} -ifaceInstGates :: IfaceType -> (IfaceExtName, [IfaceTyCon]) --- Return the class, and the tycons mentioned in the rest of the head --- We only pick the TyCon at the root of each type, to avoid --- difficulties with overlap. For example, suppose there are interfaces --- in the pool for --- C Int b --- C a [b] --- C a [T] --- Then, if we are trying to resolve (C Int x), we need the first --- if we are trying to resolve (C x [y]), we need *both* the latter --- two, even though T is not involved yet, so that we spot the overlap - -ifaceInstGates (IfaceForAllTy _ t) = ifaceInstGates t -ifaceInstGates (IfaceFunTy _ t) = ifaceInstGates t -ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = instHeadGates cls tys -ifaceInstGates other = pprPanic "ifaceInstGates" (ppr other) - -- The other cases should not happen - -instHeadGates cls tys = (cls, mapCatMaybes root_tycon tys) - where - root_tycon (IfaceFunTy _ _) = Just (IfaceTc funTyConExtName) - root_tycon (IfaceTyConApp tc _) = Just tc - root_tycon other = Nothing - -funTyConExtName = mkIfaceExtName (tyConName funTyCon) - - -predInstGates :: Class -> [Type] -> (Name, [Name]) --- The same function, only this time on the predicate found in a dictionary -predInstGates cls tys - = (className cls, mapCatMaybes root_tycon tys) - where - root_tycon ty = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> Just (tyConName tc) - Nothing -> Nothing \end{code} @@ -541,7 +387,7 @@ findAndReadIface :: Bool -- True <=> explicit user import -> SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> IfM lcl (Either Message ModIface) + -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed @@ -559,112 +405,81 @@ findAndReadIface explicit doc_str mod_name hi_boot_file -- Check for GHC.Prim, and return its static interface ; dflags <- getDOpts - ; let base_id = basePackageId (pkgState dflags) - base_pkg - | Just id <- base_id = ExternalPackage id - | otherwise = ThisPackage - -- if basePackageId is Nothing, it means we must be - -- compiling the base package. + ; let base_pkg = basePackageId (pkgState dflags) ; if mod_name == gHC_PRIM - then returnM (Right (ghcPrimIface{ mi_package = base_pkg })) + then returnM (Succeeded (ghcPrimIface{ mi_package = base_pkg }, + "")) else do -- Look for the file - ; mb_found <- ioToIOEnv (findHiFile dflags explicit mod_name hi_boot_file) + ; hsc_env <- getTopEnv + ; mb_found <- ioToIOEnv (findHiFile hsc_env explicit mod_name hi_boot_file) ; case mb_found of { - Left err -> do + Failed err -> do { traceIf (ptext SLIT("...not found")) ; dflags <- getDOpts - ; returnM (Left (noIfaceErr dflags mod_name err)) } ; + ; returnM (Failed (cantFindError dflags mod_name err)) } ; - Right (file_path,pkg) -> do + Succeeded (file_path, pkg) -> do -- Found file, so read it { traceIf (ptext SLIT("readIFace") <+> text file_path) ; read_result <- readIface mod_name file_path hi_boot_file ; case read_result of - Left err -> returnM (Left (badIfaceFile file_path err)) - Right iface + Failed err -> returnM (Failed (badIfaceFile file_path err)) + Succeeded iface | mi_module iface /= mod_name -> - return (Left (wrongIfaceModErr iface mod_name file_path)) + return (Failed (wrongIfaceModErr iface mod_name file_path)) | otherwise -> - returnM (Right iface{mi_package=pkg}) - -- don't forget to fill in the package name... + returnM (Succeeded (iface{mi_package=pkg}, file_path)) + -- Don't forget to fill in the package name... }}} -findHiFile :: DynFlags -> Bool -> Module -> IsBootInterface - -> IO (Either FindResult (FilePath, IfacePackage)) -findHiFile dflags explicit mod_name hi_boot_file +findHiFile :: HscEnv -> Bool -> Module -> IsBootInterface + -> IO (MaybeErr FindResult (FilePath, PackageIdH)) +findHiFile hsc_env explicit 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) } ; + let { home_allowed = isOneShot (ghcMode (hsc_dflags hsc_env)) } ; maybe_found <- if home_allowed - then findModule dflags mod_name explicit - else findPackageModule dflags mod_name explicit; - - case maybe_found of { - Found loc pkg -> foundOk loc hi_boot_file pkg; - err -> return (Left err) ; - }} - where - foundOk loc hi_boot_file pkg = do { -- Don't need module returned by finder - - -- 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 (hi_path,pkg)) - else do { - hi_ver_exists <- doesFileExist hi_boot_ver_path ; - if hi_ver_exists then return (Right (hi_boot_ver_path,pkg)) - else return (Right (hi_boot_path,pkg)) - }} + then findModule hsc_env mod_name explicit + else findPackageModule hsc_env mod_name explicit; + + case maybe_found of + Found loc pkg -> return (Succeeded (path, pkg)) + where + path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) + + err -> return (Failed err) + } \end{code} @readIface@ tries just the one file. \begin{code} readIface :: Module -> String -> IsBootInterface - -> IfM lcl (Either Message ModIface) - -- Left err <=> file not found, or unreadable, or illegible - -- Right iface <=> successfully found and parsed + -> TcRnIf gbl lcl (MaybeErr Message ModIface) + -- Failed err <=> file not found, or unreadable, or illegible + -- Succeeded iface <=> successfully found and parsed -readIface wanted_mod_name file_path is_hi_boot_file +readIface wanted_mod file_path is_hi_boot_file = do { dflags <- getDOpts - ; ioToIOEnv (read_iface dflags wanted_mod_name file_path is_hi_boot_file) } - -read_iface dflags wanted_mod file_path is_hi_boot_file - | is_hi_boot_file -- Read ascii - = do { res <- tryMost (hGetStringBuffer file_path) ; - case res of { - Left exn -> return (Left (text (showException exn))) ; - Right buffer -> - case unP parseIface (mkPState buffer loc dflags) of - PFailed span err -> return (Left (mkLocMessage span err)) - POk _ iface - | wanted_mod == actual_mod -> return (Right iface) - | otherwise -> return (Left err) - where - actual_mod = mi_module iface - err = hiModuleNameMismatchWarn wanted_mod actual_mod - }} - - | otherwise -- Read binary - = do { res <- tryMost (readBinIface file_path) + ; ioToIOEnv $ do + { res <- tryMost (readBinIface file_path) ; case res of - Right iface -> return (Right iface) - Left exn -> return (Left (text (showException exn))) } - where - loc = mkSrcLoc (mkFastString file_path) 1 0 + Right iface + | wanted_mod == actual_mod -> return (Succeeded iface) + | otherwise -> return (Failed err) + where + actual_mod = mi_module iface + err = hiModuleNameMismatchWarn wanted_mod actual_mod + + Left exn -> return (Failed (text (showException exn))) + }} \end{code} @@ -682,17 +497,12 @@ initExternalPackageState eps_PIT = emptyPackageIfaceTable, eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, - eps_rule_base = emptyRuleBase, - eps_insts = emptyNameEnv, - eps_rules = addRulesToPool [] (map mk_gated_rule builtinRules), + eps_rule_base = mkRuleBase builtinRules, -- Initialise the EPS rule pool with the built-in rules eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 , n_insts_in = 0, n_insts_out = 0 , n_rules_in = length builtinRules, n_rules_out = 0 } } - where - mk_gated_rule (fn_name, core_rule) - = ([fn_name], (nameModule fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule)) \end{code} @@ -705,7 +515,7 @@ initExternalPackageState \begin{code} ghcPrimIface :: ModIface ghcPrimIface - = (emptyModIface ThisPackage gHC_PRIM) { + = (emptyModIface HomePackage gHC_PRIM) { mi_exports = [(gHC_PRIM, ghcPrimExports)], mi_decls = [], mi_fixities = fixities, @@ -759,26 +569,6 @@ hiModuleNameMismatchWarn requested_mod read_mod = , ppr read_mod ] -noIfaceErr dflags mod_name (PackageHidden pkg) - = ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon - $$ ptext SLIT("it is a member of package") <+> ppr pkg <> comma - <+> ptext SLIT("which is hidden") - -noIfaceErr dflags mod_name (ModuleHidden pkg) - = ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon - $$ ptext SLIT("it is hidden") - <+> parens (ptext SLIT("in package") <+> ppr pkg) - -noIfaceErr dflags mod_name (NotFound files) - = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name) - $$ extra files - where - extra files - | verbosity dflags < 3 = - text "(use -v to see a list of the files searched for)" - | otherwise = - hang (ptext SLIT("locations searched:")) 4 (vcat (map text files)) - wrongIfaceModErr iface mod_name file_path = sep [ptext SLIT("Interface file") <+> iface_file, ptext SLIT("contains module") <+> quotes (ppr (mi_module iface)) <> comma,