X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FGHC.hs;h=bab465a42b79799a5f2baf5aa9a65f46d7fb856a;hb=5f6ed0dad13261fd14e5edb4147d1e8f732c3969;hp=a2487d84b5316ca9ad2a609849533b1343606a5e;hpb=1159c0c06db593588cfae24e47a80e71c51c6129;p=ghc-hetmet.git diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index a2487d8..bab465a 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -51,7 +51,7 @@ module GHC ( modInfoTopLevelScope, modInfoPrintUnqualified, modInfoExports, - lookupName, + lookupGlobalName, -- * Interactive evaluation getBindings, getPrintUnqual, @@ -68,6 +68,7 @@ module GHC ( browseModule, showModule, compileExpr, HValue, + lookupName, #endif -- * Abstract syntax elements @@ -76,7 +77,7 @@ module GHC ( Module, mkModule, pprModule, -- ** Names - Name, + Name, nameModule, -- ** Identifiers Id, idType, @@ -132,19 +133,25 @@ module GHC ( import qualified Linker import Linker ( HValue, extendLinkEnv ) import NameEnv ( lookupNameEnv ) -import TcRnDriver ( mkExportEnv, getModuleContents, tcRnLookupRdrName ) -import RdrName ( plusGlobalRdrEnv ) +import TcRnDriver ( getModuleContents, tcRnLookupRdrName, + getModuleExports ) +import RdrName ( plusGlobalRdrEnv, Provenance(..), ImportSpec(..), + emptyGlobalRdrEnv, mkGlobalRdrEnv ) import HscMain ( hscGetInfo, GetInfoResult, hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) import GHC.Exts ( unsafeCoerce# ) import IfaceSyn ( IfaceDecl ) +import Name ( getName, nameModule_maybe ) +import SrcLoc ( mkSrcLoc, srcLocSpan, interactiveSrcLoc ) +import Bag ( unitBag, emptyBag ) #endif import Packages ( initPackages ) import NameSet ( NameSet, nameSetToList ) -import RdrName ( GlobalRdrEnv ) +import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName, gre_name, + globalRdrEnvElts ) import HsSyn import Type ( Kind, Type, dropForAlls ) import Id ( Id, idType, isImplicitId, isDeadBinder, @@ -156,10 +163,9 @@ import Id ( Id, idType, isImplicitId, isDeadBinder, import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon ) import Class ( Class, classSCTheta, classTvsFds ) import DataCon ( DataCon ) -import Name ( Name, getName, nameModule_maybe ) -import RdrName ( RdrName, gre_name, globalRdrEnvElts ) +import Name ( Name, nameModule ) import NameEnv ( nameEnvElts ) -import SrcLoc ( Located(..), mkSrcLoc, srcLocSpan ) +import SrcLoc ( Located(..) ) import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import GetImports ( getImports ) @@ -183,7 +189,6 @@ import SysTools ( cleanTempFilesExcept ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Maybes ( orElse, expectJust, mapCatMaybes ) import TcType ( tcSplitSigmaTy, isDictTy ) -import Bag ( unitBag, emptyBag ) import FastString ( mkFastString ) import Directory ( getModificationTime, doesFileExist ) @@ -686,7 +691,8 @@ checkModule session@(Session ref) mod msg_act = do HscChecked parsed renamed (Just (tc_binds, rdr_env, details)) -> do let minf = ModuleInfo { - minf_details = details, + minf_type_env = md_types details, + minf_exports = md_exports details, minf_rdr_env = Just rdr_env } return (Just (CheckedModule { @@ -1028,7 +1034,7 @@ upsweep_compile hsc_env old_hpt this_mod msg_act summary let -- The old interface is ok if it's in the old HPT -- a) we're compiling a source file, and the old HPT - -- entry is for a source file + -- entry is for a source file -- b) we're compiling a hs-boot file -- Case (b) allows an hs-boot file to get the interface of its -- real source file on the second iteration of the compilation @@ -1206,10 +1212,12 @@ downsweep hsc_env old_summaries excl_mods getRootSummary :: Target -> IO ModSummary getRootSummary (Target (TargetFile file) maybe_buf) = do exists <- doesFileExist file - if exists then summariseFile hsc_env file maybe_buf else do + if exists + then summariseFile hsc_env old_summaries file maybe_buf + else do throwDyn (CmdLineError ("can't find file: " ++ file)) getRootSummary (Target (TargetModule modl) maybe_buf) - = do maybe_summary <- summarise hsc_env emptyNodeMap Nothing False + = do maybe_summary <- summariseModule hsc_env emptyNodeMap Nothing False modl maybe_buf excl_mods case maybe_summary of Nothing -> packageModErr modl @@ -1241,7 +1249,7 @@ downsweep hsc_env old_summaries excl_mods loop [] done = return (nodeMapElts done) loop ((cur_path, wanted_mod, is_boot) : ss) done | key `elemFM` done = loop ss done - | otherwise = do { mb_s <- summarise hsc_env old_summary_map + | otherwise = do { mb_s <- summariseModule hsc_env old_summary_map (Just cur_path) is_boot wanted_mod Nothing excl_mods ; case mb_s of @@ -1281,14 +1289,38 @@ msDeps s = concat [ [(f, m, True), (f,m,False)] | m <- ms_srcimps s] -- a summary. The finder is used to locate the file in which the module -- resides. -summariseFile :: HscEnv -> FilePath - -> Maybe (StringBuffer,ClockTime) - -> IO ModSummary --- Used for Haskell source only, I think --- We know the file name, and we know it exists, --- but we don't necessarily know the module name (might differ) -summariseFile hsc_env file maybe_buf - = do let dflags = hsc_dflags hsc_env +summariseFile + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe (StringBuffer,ClockTime) + -> IO ModSummary + +summariseFile hsc_env old_summaries file maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. + | Just old_summary <- findSummaryBySourceFile old_summaries file + = do + let location = ms_location old_summary + + -- return the cached summary if the source didn't change + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> getModificationTime file + + if ms_hs_date old_summary == src_timestamp + then do -- update the object-file timestamp + obj_timestamp <- getObjTimestamp location False + return old_summary{ ms_obj_date = obj_timestamp } + else + new_summary + + | otherwise + = new_summary + where + new_summary = do + let dflags = hsc_dflags hsc_env (dflags', hspp_fn, buf) <- preprocessFile dflags file maybe_buf @@ -1316,8 +1348,16 @@ summariseFile hsc_env file maybe_buf ms_hs_date = src_timestamp, ms_obj_date = obj_timestamp }) +findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary +findSummaryBySourceFile summaries file + = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], + fromJust (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:xs) -> Just x + -- Summarise a module, and pick up source and timestamp. -summarise :: HscEnv +summariseModule + :: HscEnv -> NodeMap ModSummary -- Map of old summaries -> Maybe FilePath -- Importing module (for error messages) -> IsBootInterface -- True <=> a {-# SOURCE #-} import @@ -1326,7 +1366,7 @@ summarise :: HscEnv -> [Module] -- Modules to exclude -> IO (Maybe ModSummary) -- Its new summary -summarise hsc_env old_summary_map cur_mod is_boot wanted_mod maybe_buf excl_mods +summariseModule hsc_env old_summary_map cur_mod is_boot wanted_mod maybe_buf excl_mods | wanted_mod `elem` excl_mods = return Nothing @@ -1334,7 +1374,7 @@ summarise hsc_env old_summary_map cur_mod is_boot wanted_mod maybe_buf excl_mods = do -- Find its new timestamp; all the -- ModSummaries in the old map have valid ml_hs_files let location = ms_location old_summary - src_fn = expectJust "summarise" (ml_hs_file location) + src_fn = expectJust "summariseModule" (ml_hs_file location) -- return the cached summary if the source didn't change src_timestamp <- case maybe_buf of @@ -1509,35 +1549,10 @@ getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC) getPrintUnqual :: Session -> IO PrintUnqualified getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) -#ifdef GHCI --- | Parses a string as an identifier, and returns the list of 'Name's that --- the identifier can refer to in the current interactive context. -parseName :: Session -> String -> IO [Name] -parseName s str = withSession s $ \hsc_env -> do - maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str - case maybe_rdr_name of - Nothing -> return [] - Just (L _ rdr_name) -> do - mb_names <- tcRnLookupRdrName hsc_env rdr_name - case mb_names of - Nothing -> return [] - Just ns -> return ns - -- ToDo: should return error messages -#endif - --- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any --- entity known to GHC, including 'Name's defined using 'runStmt'. -lookupName :: Session -> Name -> IO (Maybe TyThing) -lookupName s name = withSession s $ \hsc_env -> do - case lookupTypeEnv (ic_type_env (hsc_IC hsc_env)) name of - Just tt -> return (Just tt) - Nothing -> do - eps <- readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name - -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { - minf_details :: ModDetails, + minf_type_env :: TypeEnv, + minf_exports :: NameSet, minf_rdr_env :: Maybe GlobalRdrEnv } -- ToDo: this should really contain the ModIface too @@ -1548,11 +1563,34 @@ data ModuleInfo = ModuleInfo { getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo) getModuleInfo s mdl = withSession s $ \hsc_env -> do case lookupModuleEnv (hsc_HPT hsc_env) mdl of - Nothing -> return Nothing + Nothing -> do +#ifdef GHCI + mb_names <- getModuleExports hsc_env mdl + case mb_names of + Nothing -> return Nothing + Just names -> do + eps <- readIORef (hsc_EPS hsc_env) + let + pte = eps_PTE eps + n_list = nameSetToList names + tys = [ ty | name <- n_list, + Just ty <- [lookupTypeEnv pte name] ] + -- + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = names, + minf_rdr_env = Just $! nameSetToGlobalRdrEnv names mdl + })) +#else + -- bogusly different for non-GHCI (ToDo) + return Nothing +#endif Just hmi -> + let details = hm_details hmi in return (Just (ModuleInfo { - minf_details = hm_details hmi, - minf_rdr_env = mi_globals $! hm_iface hmi + minf_type_env = md_types details, + minf_exports = md_exports details, + minf_rdr_env = mi_globals $! hm_iface hmi })) -- ToDo: we should be able to call getModuleInfo on a package module, @@ -1560,14 +1598,14 @@ getModuleInfo s mdl = withSession s $ \hsc_env -> do -- | The list of top-level entities defined in a module modInfoTyThings :: ModuleInfo -> [TyThing] -modInfoTyThings minf = typeEnvElts (md_types (minf_details minf)) +modInfoTyThings minf = typeEnvElts (minf_type_env minf) modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] modInfoTopLevelScope minf = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) modInfoExports :: ModuleInfo -> [Name] -modInfoExports minf = nameSetToList $! (md_exports $! minf_details minf) +modInfoExports minf = nameSetToList $! minf_exports minf modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf) @@ -1576,6 +1614,15 @@ isDictonaryId :: Id -> Bool isDictonaryId id = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau } +-- | Looks up a global name: that is, any top-level name in any +-- visible module. Unlike 'lookupName', lookupGlobalName does not use +-- the interactive context, and therefore does not require a preceding +-- 'setContext'. +lookupGlobalName :: Session -> Name -> IO (Maybe TyThing) +lookupGlobalName s name = withSession s $ \hsc_env -> do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + #if 0 data ObjectCode @@ -1586,9 +1633,6 @@ data ObjectCode -- - typechecked syntax includes extra dictionary translation and -- AbsBinds which need to be translated back into something closer to -- the original source. --- - renamed syntax currently doesn't exist in a single blob, since --- renaming and typechecking are interleaved at splice points. We'd --- need a restriction that there are no splices in the source module. -- ToDo: -- - Data and Typeable instances for HsSyn. @@ -1619,10 +1663,6 @@ data ObjectCode -- :browse will use either lm_toplev or inspect lm_interface, depending -- on whether the module is interpreted or not. --- various abstract syntax types (perhaps IfaceBlah) -data Type = ... -data Kind = ... - -- This is for reconstructing refactored source code -- Calls the lexer repeatedly. -- ToDo: add comment tokens to token stream @@ -1656,6 +1696,28 @@ setContext (Session ref) toplevs exports = do ic_exports = exports, ic_rn_gbl_env = all_env } } +-- Make a GlobalRdrEnv based on the exports of the modules only. +mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv +mkExportEnv hsc_env mods = do + mb_name_sets <- mapM (getModuleExports hsc_env) mods + let + gres = [ nameSetToGlobalRdrEnv name_set mod + | (Just name_set, mod) <- zip mb_name_sets mods ] + -- + return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres + +nameSetToGlobalRdrEnv :: NameSet -> Module -> GlobalRdrEnv +nameSetToGlobalRdrEnv names mod = + mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod } + | name <- nameSetToList names ] + +vanillaProv :: Module -> Provenance +-- We're building a GlobalRdrEnv as if the user imported +-- all the specified modules into the global interactive module +vanillaProv mod = Imported [ImportSpec { is_mod = mod, is_as = mod, + is_qual = False, is_explicit = False, + is_loc = srcLocSpan interactiveSrcLoc }] + checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO () checkModuleExists hsc_env hpt mod = case lookupModuleEnv hpt mod of @@ -1705,6 +1767,30 @@ getNamesInScope :: Session -> IO [Name] getNamesInScope s = withSession s $ \hsc_env -> do return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) +-- | Parses a string as an identifier, and returns the list of 'Name's that +-- the identifier can refer to in the current interactive context. +parseName :: Session -> String -> IO [Name] +parseName s str = withSession s $ \hsc_env -> do + maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str + case maybe_rdr_name of + Nothing -> return [] + Just (L _ rdr_name) -> do + mb_names <- tcRnLookupRdrName hsc_env rdr_name + case mb_names of + Nothing -> return [] + Just ns -> return ns + -- ToDo: should return error messages + +-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any +-- entity known to GHC, including 'Name's defined using 'runStmt'. +lookupName :: Session -> Name -> IO (Maybe TyThing) +lookupName s name = withSession s $ \hsc_env -> do + case lookupTypeEnv (ic_type_env (hsc_IC hsc_env)) name of + Just tt -> return (Just tt) + Nothing -> do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + -- ----------------------------------------------------------------------------- -- Getting the type of an expression