From 6f7ad1accd1ef7e7394ae083797a89d2bb416ef7 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 13 Apr 2005 13:17:35 +0000 Subject: [PATCH] [project @ 2005-04-13 13:17:35 by simonmar] - checkModule is back, and now returns a ModuleInfo - added: modInfoTopLevelScope :: [Name] modInfoExports :: [Name] - in order to implement modInfoExports, ModDetails now contains md_exports::NameSet. --- ghc/compiler/main/GHC.hs | 103 +++++++++++++++++++++++++++++++++++----- ghc/compiler/main/HscMain.lhs | 33 +++++++++---- ghc/compiler/main/HscTypes.lhs | 2 + 3 files changed, 115 insertions(+), 23 deletions(-) diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index b8672b9..849711a 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -34,6 +34,7 @@ module GHC ( depanal, load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal workingDirectoryChanged, + checkModule, CheckedModule(..), -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), @@ -45,13 +46,14 @@ module GHC ( ModuleInfo, getModuleInfo, modInfoTyThings, + modInfoTopLevelScope, lookupName, - allNamesInScope, -- * Interactive evaluation getBindings, getPrintUnqual, #ifdef GHCI setContext, getContext, + getNamesInScope, moduleIsInterpreted, getInfo, GetInfoResult, exprType, @@ -136,6 +138,7 @@ import IfaceSyn ( IfaceDecl ) #endif import Packages ( initPackages ) +import NameSet ( NameSet, nameSetToList ) import RdrName ( GlobalRdrEnv ) import HsSyn ( HsModule, LHsBinds ) import Type ( Kind, Type, dropForAlls ) @@ -392,6 +395,7 @@ data ErrMsg = ErrMsg { data LoadHowMuch = LoadAllTargets | LoadUpTo Module + | LoadDependenciesOf Module -- | Try to load the program. If a Module is supplied, then just -- attempt to load up to this target. If no Module is supplied, @@ -475,11 +479,23 @@ load s@(Session ref) how_much maybe_top_mod = case how_much of LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m _ -> Nothing - partial_mg :: [SCC ModSummary] - partial_mg = topSortModuleGraph False mod_graph maybe_top_mod - + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod ms == mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + stable_mg = [ AcyclicSCC ms | AcyclicSCC ms <- full_mg, @@ -599,7 +615,53 @@ discardProg hsc_env -- source file, but that doesn't do any harm. ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ] ------------------------------------------------------------------------------ +-- ----------------------------------------------------------------------------- +-- Check module + +data CheckedModule = + CheckedModule { parsedSource :: ParsedSource, + -- ToDo: renamedSource + typecheckedSource :: Maybe TypecheckedSource, + checkedModuleInfo :: Maybe ModuleInfo + } + +type ParsedSource = Located (HsModule RdrName) +type TypecheckedSource = LHsBinds Id + +-- | This is the way to get access to parsed and typechecked source code +-- for a module. 'checkModule' loads all the dependencies of the specified +-- module in the Session, and then attempts to typecheck the module. If +-- successful, it returns the abstract syntax for the module. +checkModule :: Session -> Module -> (Messages -> IO ()) + -> IO (Maybe CheckedModule) +checkModule session@(Session ref) mod msg_act = do + -- load up the dependencies first + r <- load session (LoadDependenciesOf mod) + if (failed r) then return Nothing else do + + -- now parse & typecheck the module + hsc_env <- readIORef ref + let mg = hsc_mod_graph hsc_env + case [ ms | ms <- mg, ms_mod ms == mod ] of + [] -> return Nothing + (ms:_) -> do + r <- hscFileCheck hsc_env msg_act ms + case r of + HscFail -> + return Nothing + HscChecked parsed Nothing -> + return (Just (CheckedModule parsed Nothing Nothing)) + HscChecked parsed (Just (tc_binds, rdr_env, details)) -> do + let minf = ModuleInfo { + minf_details = details, + minf_rdr_env = Just rdr_env + } + return (Just (CheckedModule { + parsedSource = parsed, + typecheckedSource = Just tc_binds, + checkedModuleInfo = Just minf })) + +-- --------------------------------------------------------------------------- -- Unloading unload :: HscEnv -> [Linkable] -> IO () @@ -1416,11 +1478,6 @@ parseName s str = withSession s $ \hsc_env -> do -- ToDo: should return error messages #endif -allNamesInScope :: Session -> IO [Name] -allNamesInScope s = withSession s $ \hsc_env -> do - eps <- readIORef (hsc_EPS hsc_env) - return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) - -- | 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) @@ -1432,7 +1489,10 @@ lookupName s name = withSession s $ \hsc_env -> do return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name -- | Container for information about a 'Module'. -newtype ModuleInfo = ModuleInfo ModDetails +data ModuleInfo = ModuleInfo { + minf_details :: ModDetails, + minf_rdr_env :: Maybe GlobalRdrEnv + } -- ToDo: this should really contain the ModIface too -- We don't want HomeModInfo here, because a ModuleInfo applies -- to package modules too. @@ -1442,13 +1502,25 @@ 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 - Just hmi -> return (Just (ModuleInfo (hm_details hmi))) + Just hmi -> + return (Just (ModuleInfo { + minf_details = hm_details hmi, + minf_rdr_env = mi_globals $! hm_iface hmi + })) + -- ToDo: we should be able to call getModuleInfo on a package module, -- even one that isn't loaded yet. -- | The list of top-level entities defined in a module modInfoTyThings :: ModuleInfo -> [TyThing] -modInfoTyThings (ModuleInfo md) = typeEnvElts (md_types md) +modInfoTyThings minf = typeEnvElts (md_types (minf_details 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) isDictonaryId :: Id -> Bool isDictonaryId id @@ -1581,6 +1653,11 @@ moduleIsInterpreted s modl = withSession s $ \h -> getInfo :: Session -> String -> IO [GetInfoResult] getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id +-- | Returns all names in scope in the current interactive context +getNamesInScope :: Session -> IO [Name] +getNamesInScope s = withSession s $ \hsc_env -> do + return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) + -- ----------------------------------------------------------------------------- -- Getting the type of an expression diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 9c87db2..0c3e183 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -137,7 +137,9 @@ data HscResult = HscFail -- In IDE mode: we just do the static/dynamic checks - | HscChecked (Located (HsModule RdrName)) (Maybe (LHsBinds Id, GlobalRdrEnv)) + | HscChecked + (Located (HsModule RdrName)) + (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails)) -- Concluded that it wasn't necessary | HscNoRecomp ModDetails -- new details (HomeSymbolTable additions) @@ -318,10 +320,19 @@ hscFileCheck hsc_env msg_act mod_summary = do { ; msg_act tc_msgs ; case maybe_tc_result of { Nothing -> return (HscChecked rdr_module Nothing); - Just tc_result -> return (HscChecked rdr_module + Just tc_result -> do + let md = ModDetails { + md_types = tcg_type_env tc_result, + md_exports = tcg_exports tc_result, + md_insts = tcg_insts tc_result, + md_rules = [panic "no rules"] } + -- rules are IdCoreRules, not the + -- RuleDecls we get out of the typechecker + return (HscChecked rdr_module (Just (tcg_binds tc_result, - tcg_rdr_env tc_result))) - }}}} + tcg_rdr_env tc_result, + md))) + }}}} ------------------------------ hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult @@ -334,9 +345,10 @@ hscBootBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result) mkIface hsc_env (ms_location mod_summary) maybe_checked_iface ds_result - ; let { final_details = ModDetails { md_types = mg_types ds_result, - md_insts = mg_insts ds_result, - md_rules = mg_rules ds_result } } + ; let { final_details = ModDetails { md_types = mg_types ds_result, + md_exports = mg_exports ds_result, + md_insts = mg_insts ds_result, + md_rules = mg_rules ds_result } } -- And the answer is ... ; dumpIfaceStats hsc_env @@ -429,9 +441,10 @@ hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result) ; final_details <- if one_shot then return (error "no final details") else return $! ModDetails { - md_types = mg_types tidy_result, - md_insts = mg_insts tidy_result, - md_rules = mg_rules tidy_result } + md_types = mg_types tidy_result, + md_exports = mg_exports tidy_result, + md_insts = mg_insts tidy_result, + md_rules = mg_rules tidy_result } ------------------- -- CONVERT TO STG and COMPLETE CODE GENERATION diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 114f6c0..726c020 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -360,11 +360,13 @@ data ModDetails = ModDetails { -- The next three fields are created by the typechecker md_types :: !TypeEnv, + md_exports :: NameSet, md_insts :: ![DFunId], -- Dfun-ids for the instances in this module md_rules :: ![IdCoreRule] -- Domain may include Ids from other modules } emptyModDetails = ModDetails { md_types = emptyTypeEnv, + md_exports = emptyNameSet, md_insts = [], md_rules = [] } -- 1.7.10.4