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(..),
import HscTypes
import Name ( Name, NamedThing(..), nameRdrName, nameModule,
isHomePackageName )
+import Rename ( mkGlobalContext )
import RdrName ( emptyRdrEnv )
import Module
import GetImports
import NameEnv
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
-import RnEnv ( unQualInScope, mkIfaceGlobalRdrEnv )
import BasicTypes ( Fixity, defaultFixity )
import Interpreter ( HValue )
import HscMain ( hscStmt )
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,
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
-- 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
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
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-}
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
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
-----------------------------------------------------------------------------
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)
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
-- 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)
{-# 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
--
("help", keepGoing help),
("?", keepGoing help),
("info", keepGoing info),
+ ("import", keepGoing importModules),
("load", keepGoing loadModule),
("module", keepGoing setContext),
("reload", keepGoing reloadModule),
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
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 ()
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 ->
setGHCiState state{ cmstate = cms }
return ()
-
addModule :: String -> GHCi ()
addModule str = do
let files = words str
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 <module>'")
-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
else do
io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
+
+importModules :: String -> GHCi ()
+importModules str = return ()
+
+
loadModule :: String -> GHCi ()
loadModule str = timeIt (loadModule' str)
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
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
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'
-- 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)
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, []);
\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
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}
\begin{code}
module Rename (
- renameModule, renameStmt, renameRdrName,
+ renameModule, renameStmt, renameRdrName, mkGlobalContext,
closeIfaceDecls, checkOldIface
) where
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,
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 )
\end{code}
-
-
%*********************************************************
%* *
\subsection{The main wrappers}
renameStmt :: DynFlags
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
- -> Module -- current module
-> InteractiveContext
-> RdrNameStmt -- parsed stmt
-> IO ( PersistentCompilerState,
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) ->
:: DynFlags
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
- -> Module -- current module
-> InteractiveContext
-> [RdrName] -- name to rename
-> IO ( PersistentCompilerState,
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}
%*********************************************************
import RnMonad
import Name ( Name,
getSrcLoc, nameIsLocalOrFrom,
- mkLocalName, mkGlobalName, nameModule,
+ mkLocalName, mkGlobalName,
mkIPName, nameOccName, nameModule_maybe,
setNameModuleAndLoc
)
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}
projects / ghc-hetmet.git / commitdiff