From f587e76c3314fb89ba898b4c2aa2f5e5ef56c4f6 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 9 Jan 2002 12:41:47 +0000 Subject: [PATCH] [project @ 2002-01-09 12:41:45 by simonmar] First cut at enhancing the facilities for manipulating the scope in GHCi. The scope now consists of 1. the full top-level scope of zero or more interpreted modules 2. the exports from zero or more modules 3. the temporary bindings The sets 1 & 2 are manipulated using an extended :m command: eg :m +A will add module A to either set 1 or two depending on whether A is interpreted, and :m -A will remove it. The user interface may change, pending feedback from the punters on the mailing list. 'Prelude' is automatically added to the scope if set 1 is empty and set 2 doesn't already contain it. We now cache the GlobalRdrEnv for the current scope between evaluations in the InteractiveContext, and also the current PrintUnqualified setting (which also depends on the scope). Cvs: ---------------------------------------------------------------------- --- ghc/compiler/compMan/CompManager.lhs | 149 +++++++++++++++++----------------- ghc/compiler/ghci/InteractiveUI.hs | 107 +++++++++++++++++++----- ghc/compiler/main/HscMain.lhs | 5 +- ghc/compiler/main/HscTypes.lhs | 15 +++- ghc/compiler/prelude/PrelNames.lhs | 1 + ghc/compiler/rename/Rename.lhs | 114 ++++++++++++++++---------- ghc/compiler/rename/RnEnv.lhs | 14 +--- 7 files changed, 250 insertions(+), 155 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 96421dd..4fcafeb 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -19,11 +19,12 @@ module CompManager ( cmUnload, -- :: CmState -> DynFlags -> IO CmState - cmSetContext, -- :: CmState -> String -> IO CmState +#ifdef GHCI + cmModuleIsInterpreted, -- :: CmState -> String -> IO Bool - cmGetContext, -- :: CmState -> IO String + cmSetContext, -- :: CmState -> [String] -> [String] -> IO CmState + cmGetContext, -- :: CmState -> IO ([String],[String]) -#ifdef GHCI cmInfoThing, -- :: CmState -> DynFlags -> String -> IO (Maybe TyThing) CmRunResult(..), @@ -58,6 +59,7 @@ import HscMain ( initPersistentCompilerState ) import HscTypes import Name ( Name, NamedThing(..), nameRdrName, nameModule, isHomePackageName ) +import Rename ( mkGlobalContext ) import RdrName ( emptyRdrEnv ) import Module import GetImports @@ -79,7 +81,6 @@ import Id ( idType, idName ) import NameEnv import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) -import RnEnv ( unQualInScope, mkIfaceGlobalRdrEnv ) import BasicTypes ( Fixity, defaultFixity ) import Interpreter ( HValue ) import HscMain ( hscStmt ) @@ -117,8 +118,8 @@ data CmState pls :: PersistentLinkerState -- link's persistent state } -emptyCmState :: GhciMode -> Module -> IO CmState -emptyCmState gmode mod +emptyCmState :: GhciMode -> IO CmState +emptyCmState gmode = do pcs <- initPersistentCompilerState pls <- emptyPLS return (CmState { hst = emptySymbolTable, @@ -126,18 +127,18 @@ emptyCmState gmode mod ui = emptyUI, mg = emptyMG, gmode = gmode, - ic = emptyInteractiveContext mod, + ic = emptyInteractiveContext, pcs = pcs, pls = pls }) -emptyInteractiveContext mod - = InteractiveContext { ic_module = mod, - ic_rn_env = emptyRdrEnv, +emptyInteractiveContext + = InteractiveContext { ic_toplev_scope = [], + ic_exports = [], + ic_rn_gbl_env = emptyRdrEnv, + ic_print_unqual = alwaysQualify, + ic_rn_local_env = emptyRdrEnv, ic_type_env = emptyTypeEnv } -defaultCurrentModuleName = mkModuleName "Prelude" -GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module) - -- CM internal types type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really) emptyUI :: UnlinkedImage @@ -151,43 +152,64 @@ emptyMG = [] -- Produce an initial CmState. cmInit :: GhciMode -> IO CmState -cmInit mode = do - prel <- moduleNameToModule defaultCurrentModuleName - writeIORef defaultCurrentModule prel - emptyCmState mode prel +cmInit mode = emptyCmState mode ----------------------------------------------------------------------------- -- Setting the context doesn't throw away any bindings; the bindings -- we've built up in the InteractiveContext simply move to the new -- module. They always shadow anything in scope in the current context. -cmSetContext :: CmState -> String -> IO CmState -cmSetContext cmstate str - = do let mn = mkModuleName str - modules_loaded = [ (name_of_summary s, ms_mod s) | s <- mg cmstate ] - - m <- case lookup mn modules_loaded of - Just m -> return m - Nothing -> do - mod <- moduleNameToModule mn - if isHomeModule mod - then throwDyn (CmdLineError (showSDoc - (quotes (ppr (moduleName mod)) - <+> text "is not currently loaded"))) - else return mod - - return cmstate{ ic = (ic cmstate){ic_module=m} } - -cmGetContext :: CmState -> IO String -cmGetContext cmstate = return (moduleUserString (ic_module (ic cmstate))) - -moduleNameToModule :: ModuleName -> IO Module -moduleNameToModule mn - = do maybe_stuff <- findModule mn - case maybe_stuff of - Nothing -> throwDyn (CmdLineError ("can't find module `" +cmSetContext + :: CmState -> DynFlags + -> [String] -- take the top-level scopes of these modules + -> [String] -- and the just the exports from these + -> IO CmState +cmSetContext cmstate dflags toplevs exports = do + let CmState{ hit=hit, hst=hst, pcs=pcs, ic=old_ic } = cmstate + + toplev_mods <- mapM (getTopLevModule hit) (map mkModuleName toplevs) + export_mods <- mapM (moduleNameToModule hit) (map mkModuleName exports) + + (new_pcs, print_unqual, maybe_env) + <- mkGlobalContext dflags hit hst pcs toplev_mods export_mods + + case maybe_env of + Nothing -> return cmstate + Just env -> return cmstate{ pcs = new_pcs, + ic = old_ic{ ic_toplev_scope = toplev_mods, + ic_exports = export_mods, + ic_rn_gbl_env = env, + ic_print_unqual = print_unqual } } + +getTopLevModule hit mn = + case lookupModuleEnvByName hit mn of + Just iface + | Just _ <- mi_globals iface -> return (mi_module iface) + _other -> throwDyn (CmdLineError ( + "cannot enter the top-level scope of a compiled module (module `" ++ + moduleNameUserString mn ++ "')")) + +moduleNameToModule :: HomeIfaceTable -> ModuleName -> IO Module +moduleNameToModule hit mn = do + case lookupModuleEnvByName hit mn of + Just iface -> return (mi_module iface) + _not_a_home_module -> do + maybe_stuff <- findModule mn + case maybe_stuff of + Nothing -> throwDyn (CmdLineError ("can't find module `" ++ moduleNameUserString mn ++ "'")) - Just (m,_) -> return m + Just (m,_) -> return m + +cmGetContext :: CmState -> IO ([String],[String]) +cmGetContext CmState{ic=ic} = + return (map moduleUserString (ic_toplev_scope ic), + map moduleUserString (ic_exports ic)) + +cmModuleIsInterpreted :: CmState -> String -> IO Bool +cmModuleIsInterpreted cmstate str + = case lookupModuleEnvByName (hit cmstate) (mkModuleName str) of + Just iface -> return (not (isNothing (mi_globals iface))) + _not_a_home_module -> return False ----------------------------------------------------------------------------- -- cmInfoThing: convert a String to a TyThing @@ -204,7 +226,7 @@ cmInfoThing cmstate dflags id return (cmstate{ pcs=new_pcs }, unqual, pairs) where CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate - unqual = getUnqual pcs hit icontext + unqual = ic_print_unqual icontext getFixity :: PersistentCompilerState -> Name -> Fixity getFixity pcs name @@ -232,8 +254,8 @@ cmRunStmt cmstate@CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } dflags expr = do let InteractiveContext { - ic_rn_env = rn_env, - ic_type_env = type_env } = icontext + ic_rn_local_env = rn_env, + ic_type_env = type_env } = icontext (new_pcs, maybe_stuff) <- hscStmt dflags hst hit pcs icontext expr False{-stmt-} @@ -258,8 +280,8 @@ cmRunStmt cmstate@CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } new_type_env = extendNameEnvList filtered_type_env [ (getName id, AnId id) | id <- ids] - new_ic = icontext { ic_rn_env = new_rn_env, - ic_type_env = new_type_env } + new_ic = icontext { ic_rn_local_env = new_rn_env, + ic_type_env = new_type_env } -- link it hval <- linkExpr pls bcos @@ -334,21 +356,10 @@ cmTypeOfExpr cmstate dflags expr Just (_, ty, _) -> return (new_cmstate, Just str) where str = showSDocForUser unqual (ppr tidy_ty) - unqual = getUnqual pcs hit ic + unqual = ic_print_unqual ic tidy_ty = tidyType emptyTidyEnv ty where CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate - -getUnqual pcs hit ic - = case lookupIfaceByModName hit pit modname of - Nothing -> alwaysQualify - Just iface -> - case mi_globals iface of - Just env -> unQualInScope env - Nothing -> unQualInScope (mkIfaceGlobalRdrEnv (mi_exports iface)) - where - pit = pcs_PIT pcs - modname = moduleName (ic_module ic) #endif ----------------------------------------------------------------------------- @@ -361,7 +372,7 @@ cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name Nothing -> return Nothing Just (AnId id) -> return (Just str) where - unqual = getUnqual pcs hit ic + unqual = ic_print_unqual ic ty = tidyType emptyTidyEnv (idType id) str = showSDocForUser unqual (ppr ty) @@ -376,9 +387,8 @@ cmCompileExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe HValue) cmCompileExpr cmstate dflags expr = do let InteractiveContext { - ic_rn_env = rn_env, - ic_type_env = type_env, - ic_module = this_mod } = icontext + ic_rn_local_env = rn_env, + ic_type_env = type_env } = icontext (new_pcs, maybe_stuff) <- hscStmt dflags hst hit pcs icontext @@ -630,16 +640,9 @@ cmLoadFinish ok (LinkFailed pls) hst hit ui mods ghci_mode pcs = do -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. cmLoadFinish ok (LinkOK pls) hst hit ui mods ghci_mode pcs - = do def_mod <- readIORef defaultCurrentModule - let current_mod = case mods of - [] -> def_mod - (x:_) -> ms_mod x - - new_ic = emptyInteractiveContext current_mod - - new_cmstate = CmState{ hst=hst, hit=hit, ui=ui, mg=mods, + = do let new_cmstate = CmState{ hst=hst, hit=hit, ui=ui, mg=mods, gmode=ghci_mode, pcs=pcs, pls=pls, - ic = new_ic } + ic = emptyInteractiveContext } mods_loaded = map (moduleNameUserString.name_of_summary) mods return (new_cmstate, ok, mods_loaded) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index d1b6b77..040f2cc 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.105 2002/01/03 17:09:15 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.106 2002/01/09 12:41:47 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -83,6 +83,7 @@ builtin_commands = [ ("help", keepGoing help), ("?", keepGoing help), ("info", keepGoing info), + ("import", keepGoing importModules), ("load", keepGoing loadModule), ("module", keepGoing setContext), ("reload", keepGoing reloadModule), @@ -158,6 +159,9 @@ interactiveUI cmstate paths cmdline_libs = do Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ()) _ -> panic "interactiveUI:stdout" + -- initial context is just the Prelude + cmstate <- cmSetContext cmstate dflags [] ["Prelude"] + #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS Readline.initialize #endif @@ -268,8 +272,8 @@ checkPerms name = fileLoop :: Handle -> Bool -> GHCi () fileLoop hdl prompt = do st <- getGHCiState - mod <- io (cmGetContext (cmstate st)) - when prompt (io (putStr (mod ++ "> "))) + (mod,imports) <- io (cmGetContext (cmstate st)) + when prompt (io (putStr (mkPrompt mod imports))) l <- io (IO.try (hGetLine hdl)) case l of Left e | isEOFError e -> return () @@ -289,13 +293,20 @@ stringLoop (s:ss) = do l -> do quit <- runCommand l if quit then return () else stringLoop ss +mkPrompt toplevs exports + = concat (intersperse "," toplevs) + ++ (if not (null exports) + then "[" ++ concat (intersperse "," exports) ++ "]" + else "") + ++ "> " + #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS readlineLoop :: GHCi () readlineLoop = do st <- getGHCiState - mod <- io (cmGetContext (cmstate st)) + (mod,imports) <- io (cmGetContext (cmstate st)) io yield - l <- io (readline (mod ++ "> ")) + l <- io (readline (mkPrompt mod imports)) case l of Nothing -> return () Just l -> @@ -455,7 +466,6 @@ info s = do setGHCiState state{ cmstate = cms } return () - addModule :: String -> GHCi () addModule str = do let files = words str @@ -466,20 +476,9 @@ addModule str = do graph <- io (cmDepAnal (cmstate state) dflags new_targets) (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph) setGHCiState state{ cmstate = cmstate1, targets = new_targets } + setContextAfterLoad mods modulesLoadedMsg ok mods -setContext :: String -> GHCi () -setContext "" - = throwDyn (CmdLineError "syntax: `:m '") -setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m)) - = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'")) - where - isAlphaNumEx c = isAlphaNum c || c == '_' -setContext str - = do st <- getGHCiState - new_cmstate <- io (cmSetContext (cmstate st) str) - setGHCiState st{cmstate=new_cmstate} - changeDirectory :: String -> GHCi () changeDirectory ('~':d) = do tilde <- io (getEnv "HOME") -- will fail if HOME not defined @@ -530,6 +529,11 @@ undefineMacro macro_name = do else do io (writeIORef commands (filter ((/= macro_name) . fst) cmds)) + +importModules :: String -> GHCi () +importModules str = return () + + loadModule :: String -> GHCi () loadModule str = timeIt (loadModule' str) @@ -548,8 +552,9 @@ loadModule' str = do io (revertCAFs) -- always revert CAFs on load. (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph) - setGHCiState state{ cmstate = cmstate2, targets = files } + + setContextAfterLoad mods modulesLoadedMsg ok mods @@ -565,14 +570,16 @@ reloadModule "" = do graph <- io (cmDepAnal (cmstate state) dflags paths) io (revertCAFs) -- always revert CAFs on reload. - (new_cmstate, ok, mods) + (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph) - - setGHCiState state{ cmstate=new_cmstate } + setGHCiState state{ cmstate=cmstate1 } + setContextAfterLoad mods modulesLoadedMsg ok mods reloadModule _ = noArgs ":reload" +setContextAfterLoad [] = setContext prel +setContextAfterLoad (m:_) = setContext m modulesLoadedMsg ok mods = do let mod_commas @@ -602,6 +609,62 @@ quit _ = return True shellEscape :: String -> GHCi Bool shellEscape str = io (system str >> return False) +----------------------------------------------------------------------------- +-- Setting the module context + +setContext str + | all sensible mods = newContext mods -- default is to set the empty context + | all plusminus mods = adjustContext mods + | otherwise + = throwDyn (CmdLineError "syntax: :module M1 .. Mn | :module [+/-]M1 ... [+/-]Mn") + where + mods = words str + + sensible (c:cs) = isUpper c && all isAlphaNumEx cs + isAlphaNumEx c = isAlphaNum c || c == '_' + + plusminus ('-':mod) = sensible mod + plusminus ('+':mod) = sensible mod + plusminus _ = False + +newContext mods = do + state@GHCiState{cmstate=cmstate} <- getGHCiState + dflags <- io getDynFlags + + let separate [] as bs = return (as,bs) + separate (m:ms) as bs = do + b <- io (cmModuleIsInterpreted cmstate m) + if b then separate ms (m:as) bs + else separate ms as (m:bs) + + (as,bs) <- separate mods [] [] + let bs' = if null as && prel `notElem` bs then prel:bs else bs + cmstate' <- io (cmSetContext cmstate dflags as bs') + setGHCiState state{cmstate=cmstate'} + +prel = "Prelude" + +adjustContext mods = do + state@GHCiState{cmstate=cmstate} <- getGHCiState + dflags <- io getDynFlags + + let adjust [] as bs = return (as,bs) + adjust (('-':m) : ms) as bs + | m `elem` as = adjust ms (delete m as) bs + | m `elem` bs = adjust ms as (delete m bs) + | otherwise = throwDyn (CmdLineError ("module `" ++ m ++ "' is not currently in scope")) + adjust (('+':m) : ms) as bs + | m `elem` as || m `elem` bs = adjust ms as bs -- continue silently + | otherwise = do b <- io (cmModuleIsInterpreted cmstate m) + if b then adjust ms (m:as) bs + else adjust ms as (m:bs) + + (as,bs) <- io (cmGetContext cmstate) + (as,bs) <- adjust mods as bs + let bs' = if null as && prel `notElem` bs then prel:bs else bs + cmstate' <- io (cmSetContext cmstate dflags as bs') + setGHCiState state{cmstate=cmstate'} + ---------------------------------------------------------------------------- -- Code for `:set' diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 40edb3c..dd34117 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -527,8 +527,7 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr -- Rename it (pcs1, print_unqual, maybe_renamed_stmt) - <- renameStmt dflags hit hst pcs0 - iNTERACTIVE icontext parsed_stmt + <- renameStmt dflags hit hst pcs0 icontext parsed_stmt ; case maybe_renamed_stmt of Nothing -> return (pcs0, Nothing) @@ -644,7 +643,7 @@ hscThing dflags hst hit pcs0 icontext str tccls_name = setRdrNameOcc rdr_name tccls_occ (pcs, unqual, maybe_rn_result) <- - renameRdrName dflags hit hst pcs0 iNTERACTIVE icontext rdr_names + renameRdrName dflags hit hst pcs0 icontext rdr_names case maybe_rn_result of { Nothing -> return (pcs, []); diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index bf85769..9b8e819 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -292,10 +292,19 @@ lookupIfaceByModName hit pit mod \begin{code} data InteractiveContext = InteractiveContext { - ic_module :: Module, -- The current module in which - -- the user is sitting + ic_toplev_scope :: [Module], -- Include the "top-level" scope of + -- these modules - ic_rn_env :: LocalRdrEnv, -- Lexical context for variables bound + ic_exports :: [Module], -- Include just the exports of these + -- modules + + ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from + -- ic_toplev_scope and ic_exports + + ic_print_unqual :: PrintUnqualified, + -- cached PrintUnqualified, as above + + ic_rn_local_env :: LocalRdrEnv, -- Lexical context for variables bound -- during interaction ic_type_env :: TypeEnv -- Ditto for types diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index d79bd24..17920c9 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -249,6 +249,7 @@ pREL_ERR = mkPrelModule pREL_ERR_Name pREL_NUM = mkPrelModule pREL_NUM_Name pREL_REAL = mkPrelModule pREL_REAL_Name pREL_FLOAT = mkPrelModule pREL_FLOAT_Name +pRELUDE = mkPrelModule pRELUDE_Name iNTERACTIVE = mkHomeModule (mkModuleName "$Interactive") \end{code} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index b092251..c99a63a 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -5,7 +5,7 @@ \begin{code} module Rename ( - renameModule, renameStmt, renameRdrName, + renameModule, renameStmt, renameRdrName, mkGlobalContext, closeIfaceDecls, checkOldIface ) where @@ -33,13 +33,14 @@ import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps, import RnHiFiles ( readIface, loadInterface, loadExports, loadFixDecls, loadDeprecs, ) -import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv, +import RnEnv ( availsToNameSet, unitAvailEnv, availEnvElts, availNames, plusAvailEnv, groupAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, lookupSrcName, getImplicitStmtFVs, getImplicitModuleFVs, newGlobalName, unQualInScope, - ubiquitousNames, lookupOccRn + ubiquitousNames, lookupOccRn, + plusGlobalRdrEnv, mkGlobalRdrEnv ) import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, moduleName, @@ -49,7 +50,7 @@ import Name ( Name, nameModule ) import NameEnv import NameSet import RdrName ( foldRdrEnv, isQual ) -import PrelNames ( pRELUDE_Name ) +import PrelNames ( iNTERACTIVE, pRELUDE_Name ) import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, printErrorsAndWarnings, errorsFound ) import Bag ( bagToList ) @@ -64,8 +65,6 @@ import List ( partition, nub ) \end{code} - - %********************************************************* %* * \subsection{The main wrappers} @@ -90,7 +89,6 @@ renameModule dflags hit hst pcs this_module rdr_module renameStmt :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState - -> Module -- current module -> InteractiveContext -> RdrNameStmt -- parsed stmt -> IO ( PersistentCompilerState, @@ -98,15 +96,20 @@ renameStmt :: DynFlags Maybe ([Name], (RenamedStmt, [RenamedHsDecl])) ) -renameStmt dflags hit hst pcs this_module ic stmt - = renameSource dflags hit hst pcs this_module $ - extendTypeEnvRn (ic_type_env ic) $ +renameStmt dflags hit hst pcs ic stmt + = renameSource dflags hit hst pcs iNTERACTIVE $ -- load the context module - loadContextModule (ic_module ic) $ \ (rdr_env, print_unqual) -> + let InteractiveContext{ ic_rn_gbl_env = rdr_env, + ic_print_unqual = print_unqual, + ic_rn_local_env = local_rdr_env, + ic_type_env = type_env } = ic + in + + extendTypeEnvRn type_env $ -- Rename the stmt - initRnMS rdr_env emptyAvailEnv (ic_rn_env ic) emptyLocalFixityEnv CmdLineMode ( + initRnMS rdr_env emptyAvailEnv local_rdr_env emptyLocalFixityEnv CmdLineMode ( rnStmt stmt $ \ stmt' -> returnRn (([], stmt'), emptyFVs) ) `thenRn` \ ((binders, stmt), fvs) -> @@ -148,7 +151,6 @@ renameRdrName :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState - -> Module -- current module -> InteractiveContext -> [RdrName] -- name to rename -> IO ( PersistentCompilerState, @@ -156,57 +158,87 @@ renameRdrName Maybe ([Name], [RenamedHsDecl]) ) -renameRdrName dflags hit hst pcs this_module ic rdr_names = - renameSource dflags hit hst pcs this_module $ - extendTypeEnvRn (ic_type_env ic) $ - loadContextModule (ic_module ic) $ \ (rdr_env, print_unqual) -> +renameRdrName dflags hit hst pcs ic rdr_names = + renameSource dflags hit hst pcs iNTERACTIVE $ - -- rename the rdr_name - initRnMS rdr_env emptyAvailEnv (ic_rn_env ic) emptyLocalFixityEnv CmdLineMode + -- load the context module + let InteractiveContext{ ic_rn_gbl_env = rdr_env, + ic_print_unqual = print_unqual, + ic_rn_local_env = local_rdr_env, + ic_type_env = type_env } = ic + in + + extendTypeEnvRn type_env $ + + -- rename the rdr_name + initRnMS rdr_env emptyAvailEnv local_rdr_env emptyLocalFixityEnv CmdLineMode (mapRn (tryRn.lookupOccRn) rdr_names) `thenRn` \ maybe_names -> - let + let ok_names = [ a | Right a <- maybe_names ] - in - if null ok_names + in + if null ok_names then let errs = head [ e | Left e <- maybe_names ] in setErrsRn errs `thenRn_` doDump dflags ok_names [] `thenRn_` returnRn (print_unqual, Nothing) else - slurpImpDecls (mkNameSet ok_names) `thenRn` \ decls -> + slurpImpDecls (mkNameSet ok_names) `thenRn` \ decls -> - doDump dflags ok_names decls `thenRn_` - returnRn (print_unqual, Just (ok_names, decls)) + doDump dflags ok_names decls `thenRn_` + returnRn (print_unqual, Just (ok_names, decls)) where doDump :: DynFlags -> [Name] -> [RenamedHsDecl] -> RnMG (Either IOError ()) doDump dflags names decls = ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:" (vcat [ppr names, text "", vcat (map ppr decls)])) +\end{code} +%********************************************************* +%* * +\subsection{Make up an interactive context} +%* * +%********************************************************* --- Load the interface for the context module, so --- that we can get its top-level lexical environment --- Bale out if we fail to do this -loadContextModule scope_module thing_inside - = let doc = text "context for compiling expression" - in - loadInterface doc (moduleName scope_module) ImportByUser `thenRn` \ iface -> - - -- If this is a module we previously compiled, then mi_globals will - -- have its top-level environment. If it is an imported module, then - -- we must invent a top-level environment from its exports. - let rdr_env | Just env <- mi_globals iface = env - | otherwise = mkIfaceGlobalRdrEnv (mi_exports iface) - - print_unqual = unQualInScope rdr_env +\begin{code} +mkGlobalContext + :: DynFlags -> HomeIfaceTable -> HomeSymbolTable + -> PersistentCompilerState + -> [Module] -> [Module] + -> IO (PersistentCompilerState, PrintUnqualified, Maybe GlobalRdrEnv) +mkGlobalContext dflags hit hst pcs toplevs exports + = renameSource dflags hit hst pcs iNTERACTIVE $ + + mapRn getTopLevScope toplevs `thenRn` \ toplev_envs -> + mapRn getModuleExports exports `thenRn` \ export_envs -> + let full_env = foldr plusGlobalRdrEnv emptyRdrEnv + (toplev_envs ++ export_envs) + print_unqual = unQualInScope full_env in checkErrsRn `thenRn` \ no_errs_so_far -> if not no_errs_so_far then returnRn (print_unqual, Nothing) else - thing_inside (rdr_env, print_unqual) + returnRn (print_unqual, Just full_env) + +contextDoc = text "context for compiling statements" + +getTopLevScope :: Module -> RnM d GlobalRdrEnv +getTopLevScope mod = + loadInterface contextDoc (moduleName mod) ImportByUser `thenRn` \ iface -> + case mi_globals iface of + Nothing -> panic "getTopLevScope" + Just env -> returnRn env + +getModuleExports :: Module -> RnM d GlobalRdrEnv +getModuleExports mod = + loadInterface contextDoc (moduleName mod) ImportByUser `thenRn` \ iface -> + returnRn (foldl add emptyRdrEnv (mi_exports iface)) + where + prov_fn n = NonLocalDef ImplicitImport + add env (mod,avails) = + plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs) \end{code} %********************************************************* diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index da3ed88..6835f93 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -28,7 +28,7 @@ import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, import RnMonad import Name ( Name, getSrcLoc, nameIsLocalOrFrom, - mkLocalName, mkGlobalName, nameModule, + mkLocalName, mkGlobalName, mkIPName, nameOccName, nameModule_maybe, setNameModuleAndLoc ) @@ -717,18 +717,6 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs where occ = nameOccName name elt = GRE name (mk_provenance name) (lookupDeprec deprecs name) - -mkIfaceGlobalRdrEnv :: [(ModuleName,Avails)] -> GlobalRdrEnv --- Used to construct a GlobalRdrEnv for an interface that we've --- read from a .hi file. We can't construct the original top-level --- environment because we don't have enough info, but we compromise --- by making an environment from its exports -mkIfaceGlobalRdrEnv m_avails - = foldl add emptyRdrEnv m_avails - where - add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True - (\n -> LocalDef) avails NoDeprecs) - -- The NoDeprecs is a bit of a hack I suppose \end{code} \begin{code} -- 1.7.10.4