diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-08-03 16:10:24 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-08-03 16:10:24 +0100 |
commit | 66096716817eb22ccd1dfb142e816b4b2846f7b3 (patch) | |
tree | d29a9a797b942d3e197b7a92cf0b99baef630241 | |
parent | a303ee91d4186eba80864c45ff3ad7a58e70fa65 (diff) | |
download | haskell-66096716817eb22ccd1dfb142e816b4b2846f7b3.tar.gz |
Refactor to replace hscGetModuleExports by hscGetModuleInterface
I also tidied up the interfaces for LoadIface to be a bit simpler
-rw-r--r-- | compiler/iface/LoadIface.lhs | 65 | ||||
-rw-r--r-- | compiler/main/DynamicLoading.hs | 30 | ||||
-rw-r--r-- | compiler/main/GHC.hs | 32 | ||||
-rw-r--r-- | compiler/main/HscMain.lhs | 9 | ||||
-rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 29 |
5 files changed, 67 insertions, 98 deletions
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 9d087c1808..fef97119b4 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -7,8 +7,13 @@ Loading interface files \begin{code} module LoadIface ( - loadInterface, loadInterfaceForName, loadWiredInHomeIface, - loadSrcInterface, loadSysInterface, loadUserInterface, loadOrphanModules, + -- RnM/TcM functions + loadModuleInterface, loadModuleInterfaces, + loadSrcInterface, loadInterfaceForName, + + -- IfM functions + loadInterface, loadWiredInHomeIface, + loadSysInterface, loadUserInterface, findAndReadIface, readIface, -- Used when reading the module's old interface loadDecls, -- Should move to TcIface and be renamed initExternalPackageState, @@ -90,22 +95,17 @@ loadSrcInterface doc mod want_boot maybe_pkg = do let dflags = hsc_dflags hsc_env in failWithTc (cannotFindInterface dflags mod err) --- | Load interfaces for a collection of orphan modules. -loadOrphanModules :: [Module] -- the modules - -> Bool -- these are family instance-modules - -> TcM () -loadOrphanModules mods isFamInstMod +-- | Load interface for a module. +loadModuleInterface :: SDoc -> Module -> TcM ModIface +loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod) + +-- | Load interfaces for a collection of modules. +loadModuleInterfaces :: SDoc -> [Module] -> TcM () +loadModuleInterfaces doc mods | null mods = return () - | otherwise = initIfaceTcRn $ - do { traceIf (text "Loading orphan modules:" <+> - fsep (map ppr mods)) - ; mapM_ load mods - ; return () } + | otherwise = initIfaceTcRn (mapM_ load mods) where - load mod = loadSysInterface (mk_doc mod) mod - mk_doc mod - | isFamInstMod = ppr mod <+> ptext (sLit "is a family-instance module") - | otherwise = ppr mod <+> ptext (sLit "is a orphan-instance module") + load mod = loadSysInterface (doc <+> parens (ppr mod)) mod -- | Loads the interface for a given Name. loadInterfaceForName :: SDoc -> Name -> TcRn ModIface @@ -119,7 +119,20 @@ loadInterfaceForName doc name ; ASSERT2( isExternalName name, ppr name ) initIfaceTcRn $ loadSysInterface doc (nameModule name) } +\end{code} + + +%********************************************************* +%* * + loadInterface + + The main function to load an interface + for an imported module, and put it in + the External Package State +%* * +%********************************************************* +\begin{code} -- | An '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 -- See Note [Loading instances for wired-in things] in TcIface @@ -130,15 +143,19 @@ loadWiredInHomeIface name where doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name +------------------ -- | Loads a system interface and throws an exception if it fails loadSysInterface :: SDoc -> Module -> IfM lcl ModIface loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem +------------------ -- | Loads a user interface and throws an exception if it fails. The first parameter indicates -- whether we should import the boot variant of the module loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface -loadUserInterface is_boot doc mod_name = loadInterfaceWithException doc mod_name (ImportByUser is_boot) +loadUserInterface is_boot doc mod_name + = loadInterfaceWithException doc mod_name (ImportByUser is_boot) +------------------ -- | A wrapper for 'loadInterface' that throws an exception if it fails loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface loadInterfaceWithException doc mod_name where_from @@ -146,20 +163,8 @@ loadInterfaceWithException doc mod_name where_from ; case mb_iface of Failed err -> ghcError (ProgramError (showSDoc err)) Succeeded iface -> return iface } -\end{code} - - -%********************************************************* -%* * - loadInterface - The main function to load an interface - for an imported module, and put it in - the External Package State -%* * -%********************************************************* - -\begin{code} +------------------ loadInterface :: SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr Message ModIface) diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index e8a8dfe015..cc382a74fe 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -17,21 +17,19 @@ module DynamicLoading ( #ifdef GHCI import Linker ( linkModule, getHValue ) -import OccName ( occNameSpace ) -import Name ( nameOccName ) import SrcLoc ( noSrcSpan ) import Finder ( findImportedModule, cannotFindModule ) import DriverPhases ( HscSource(HsSrcFile) ) -import TcRnDriver ( getModuleExports ) +import TcRnDriver ( getModuleInterface ) import TcRnMonad ( initTc, initIfaceTcRn ) import LoadIface ( loadUserInterface ) -import RdrName ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - mkGlobalRdrEnv, lookupGRE_RdrName, gre_name, rdrNameSpace ) +import RdrName ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..) + , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName, gre_name ) import RnNames ( gresFromAvails ) import PrelNames ( iNTERACTIVE ) import DynFlags -import HscTypes ( HscEnv(..), FindResult(..), lookupTypeHscEnv ) +import HscTypes ( HscEnv(..), FindResult(..), ModIface(..), lookupTypeHscEnv ) import TypeRep ( TyThing(..), pprTyThingCategory ) import Type ( Type, eqType ) import TyCon ( TyCon ) @@ -138,17 +136,19 @@ lookupRdrNameInModule hsc_env mod_name rdr_name = do case found_module of Found _ mod -> do -- Find the exports of the module - (_, mb_avail_info) <- getModuleExports hsc_env mod - case mb_avail_info of - Just avail_info -> do + (_, mb_iface) <- getModuleInterface hsc_env mod + case mb_iface of + Just iface -> do -- Try and find the required name in the exports - let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = noSrcSpan } + let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name + , is_qual = False, is_dloc = noSrcSpan } provenance = Imported [ImpSpec decl_spec ImpAll] - env = mkGlobalRdrEnv (gresFromAvails provenance avail_info) - case [name | gre <- lookupGRE_RdrName rdr_name env, let name = gre_name gre, rdrNameSpace rdr_name == occNameSpace (nameOccName name)] of - [name] -> return (Just name) - [] -> return Nothing - _ -> panic "lookupRdrNameInModule" + env = mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface)) + case lookupGRE_RdrName rdr_name env of + [gre] -> return (Just (gre_name gre)) + [] -> return Nothing + _ -> panic "lookupRdrNameInModule" + Nothing -> throwCmdLineErrorS $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] err -> throwCmdLineErrorS $ cannotFindModule dflags mod_name err where diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 665b1b0532..d8c6fdda4e 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -261,10 +261,8 @@ import Id import TysPrim ( alphaTyVars ) import TyCon import Class --- import FunDeps import DataCon import Name hiding ( varName ) --- import OccName ( parenSymOcc ) import InstEnv import SrcLoc import CoreSyn ( CoreBind ) @@ -946,18 +944,11 @@ getModuleInfo mdl = withSession $ \hsc_env -> do getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) #ifdef GHCI -getPackageModuleInfo hsc_env mdl = do - mb_avails <- hscGetModuleExports hsc_env mdl - -- This is the only use of hscGetModuleExports. Perhaps we could use - -- hscRnImportDecls instead, but that does a lot more than we need - -- (building instance environment, checking family instance consistency - -- etc.). - case mb_avails of - Nothing -> return Nothing - Just avails -> do - eps <- hscEPS hsc_env - iface <- lookupModuleIface hsc_env mdl +getPackageModuleInfo hsc_env mdl + = do eps <- hscEPS hsc_env + iface <- hscGetModuleInterface hsc_env mdl let + avails = mi_exports iface names = availsToNameSet avails pte = eps_PTE eps tys = [ ty | name <- concatMap availNames avails, @@ -968,7 +959,7 @@ getPackageModuleInfo hsc_env mdl = do minf_exports = names, minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_instances = error "getModuleInfo: instances for package module unimplemented", - minf_iface = iface, + minf_iface = Just iface, minf_modBreaks = emptyModBreaks })) #else @@ -983,7 +974,7 @@ getHomeModuleInfo hsc_env mdl = Nothing -> return Nothing Just hmi -> do let details = hm_details hmi - let iface = hm_iface hmi + iface = hm_iface hmi return (Just (ModuleInfo { minf_type_env = md_types details, minf_exports = availsToNameSet (md_exports details), @@ -995,17 +986,6 @@ getHomeModuleInfo hsc_env mdl = #endif })) -#ifdef GHCI -lookupModuleIface :: HscEnv -> Module -> IO (Maybe ModIface) -lookupModuleIface env m = do - eps <- hscEPS env - let dflags = hsc_dflags env - pkgIfaceT = eps_PIT eps - homePkgT = hsc_HPT env - iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m - return iface -#endif - -- | The list of top-level entities defined in a module modInfoTyThings :: ModuleInfo -> [TyThing] modInfoTyThings minf = typeEnvElts (minf_type_env minf) diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 48f60f074b..ae858fde28 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -59,8 +59,8 @@ module HscMain , hscTcRcLookupName , hscTcRnGetInfo #ifdef GHCI + , hscGetModuleInterface , hscRnImportDecls - , hscGetModuleExports , hscTcRnLookupRdrName , hscStmt, hscStmtWithLocation , hscTcExpr, hscImport, hscKcType @@ -292,13 +292,12 @@ hscTcRnGetInfo hsc_env name = runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name #ifdef GHCI -hscGetModuleExports :: HscEnv -> Module -> IO (Maybe [AvailInfo]) -hscGetModuleExports hsc_env mdl = - runHsc hsc_env $ ioMsgMaybe' $ getModuleExports hsc_env mdl +hscGetModuleInterface :: HscEnv -> Module -> IO ModIface +hscGetModuleInterface hsc_env mod + = runHsc hsc_env $ ioMsgMaybe $ getModuleInterface hsc_env mod -- ----------------------------------------------------------------------------- -- | Rename some import declarations - hscRnImportDecls :: HscEnv -> Module diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 437877aa7d..403a3aa847 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -9,7 +9,7 @@ module TcRnDriver ( #ifdef GHCI tcRnStmt, tcRnExpr, tcRnType, tcRnLookupRdrName, - getModuleExports, + getModuleInterface, #endif tcRnImports, tcRnLookupName, @@ -84,7 +84,6 @@ import TcHsType import TcMatches import RnTypes import RnExpr -import IfaceEnv import MkId import BasicTypes import TidyPgm ( globaliseAndTidyId ) @@ -269,7 +268,8 @@ tcRnImports hsc_env this_mod import_decls -- Load any orphan-module and family instance-module -- interfaces, so that their rules and instance decls will be -- found. - ; loadOrphanModules (imp_orphs imports) False + ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) + (imp_orphs imports) -- Check type-family consistency ; traceRn (text "rn1: checking family instance consistency") @@ -1391,25 +1391,10 @@ tcRnType hsc_env ictxt rdr_type -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. -getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo]) -getModuleExports hsc_env mod - = initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod) - --- Get the export avail info and also load all orphan and family-instance --- modules. Finally, check that the family instances of all modules in the --- interactive context are consistent (these modules are in the second --- argument). -tcGetModuleExports :: Module -> TcM [AvailInfo] -tcGetModuleExports mod - = do { let doc = ptext (sLit "context for compiling statements") - ; iface <- initIfaceTcRn $ loadSysInterface doc mod - - -- Load any orphan-module and family instance-module - -- interfaces, so their instances are visible. - ; loadOrphanModules (dep_orphs (mi_deps iface)) False - - ; ifaceExportNames (mi_exports iface) - } +getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface) +getModuleInterface hsc_env mod + = initTc hsc_env HsSrcFile False iNTERACTIVE $ + loadModuleInterface (ptext (sLit "getModuleInterface")) mod tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name |