cmSetContext, -- :: CmState -> DynFlags -> [String] -> [String] -> IO CmState
cmGetContext, -- :: CmState -> IO ([String],[String])
- cmInfoThing, -- :: CmState -> DynFlags -> String -> IO (Maybe TyThing)
+ cmInfoThing, -- :: CmState -> DynFlags -> String
+ -- -> IO (CmState, [(TyThing,Fixity)])
CmRunResult(..),
cmRunStmt, -- :: CmState -> DynFlags -> String
HValue,
cmCompileExpr, -- :: CmState -> DynFlags -> String
-- -> IO (CmState, Maybe HValue)
+
+ cmGetModuleGraph, -- :: CmState -> ModuleGraph
+ cmGetLinkables, -- :: CmState -> [Linkable]
+
+ cmGetBindings, -- :: CmState -> [TyThing]
+ cmGetPrintUnqual, -- :: CmState -> PrintUnqualified
#endif
+
+ -- utils
+ showModMsg, --
)
where
#include "HsVersions.h"
+import MkIface --tmp
+import HsSyn -- tmp
+
import CmLink
import CmTypes
import DriverPipeline
#endif
import HscTypes
import Name ( Name, NamedThing(..), nameRdrName, nameModule,
- isHomePackageName )
+ isHomePackageName, isGlobalName )
import Rename ( mkGlobalContext )
import RdrName ( emptyRdrEnv )
import Module
cmInit mode = emptyCmState mode
-----------------------------------------------------------------------------
+-- Grab information from the CmState
+
+cmGetModuleGraph = mg
+cmGetLinkables = ui
+
+cmGetBindings cmstate = nameEnvElts (ic_type_env (ic cmstate))
+cmGetPrintUnqual cmstate = ic_print_unqual (ic cmstate)
+
+-----------------------------------------------------------------------------
-- 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.
-- and type constructor), so we return a list of all the possible TyThings.
#ifdef GHCI
-cmInfoThing :: CmState -> DynFlags -> String
- -> IO (CmState, PrintUnqualified, [(TyThing,Fixity)])
+cmInfoThing :: CmState -> DynFlags -> String -> IO (CmState, [(TyThing,Fixity)])
cmInfoThing cmstate dflags id
= do (new_pcs, things) <- hscThing dflags hst hit pcs icontext id
let pairs = map (\x -> (x, getFixity new_pcs (getName x))) things
- return (cmstate{ pcs=new_pcs }, unqual, pairs)
- where
+ return (cmstate{ pcs=new_pcs }, pairs)
+ where
CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
- unqual = ic_print_unqual icontext
getFixity :: PersistentCompilerState -> Name -> Fixity
getFixity pcs name
- | Just iface <- lookupModuleEnv iface_table (nameModule name),
+ | isGlobalName name,
+ Just iface <- lookupModuleEnv iface_table (nameModule name),
Just fixity <- lookupNameEnv (mi_fixities iface) name
= fixity
| otherwise
{-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.108 2002/01/22 16:50:29 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.109 2002/01/23 16:50:49 simonmar Exp $
--
-- GHC Interactive User Interface
--
#include "HsVersions.h"
import Packages
+
import CompManager
-import HscTypes ( TyThing(..) )
+import CmTypes ( Linkable, isObjectLinkable, ModSummary(..) )
+import CmLink ( findModuleLinkable_maybe )
+
+import HscTypes ( TyThing(..), showModMsg, InteractiveContext(..) )
import MkIface ( ifaceTyThing )
import DriverFlags
import DriverState
import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon )
import FieldLabel ( fieldLabelTyCon )
import SrcLoc ( isGoodSrcLoc )
+import Module ( moduleName )
+import NameEnv ( nameEnvElts )
import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
NamedThing(..) )
import OccName ( isSymOcc )
import BasicTypes ( defaultFixity )
import Outputable
-import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags,
- dopt_unset )
+import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags,
+ restoreDynFlags, dopt_unset )
import Panic ( GhcException(..), showGhcException )
import Config
import Directory
import IO
import Char
-import Monad ( when, join )
+import Monad
import PrelGHC ( unsafeCoerce# )
import Foreign ( nullPtr )
("help", keepGoing help),
("?", keepGoing help),
("info", keepGoing info),
- ("import", keepGoing importModules),
("load", keepGoing loadModule),
("module", keepGoing setContext),
("reload", keepGoing reloadModule),
("set", keepGoing setCmd),
+ ("show", keepGoing showCmd),
("type", keepGoing typeOfExpr),
("unset", keepGoing unsetOptions),
("undef", keepGoing undefineMacro),
\ :load <filename> ... load module(s) and their dependents\n\
\ :module <mod> set the context for expression evaluation to <mod>\n\
\ :reload reload the current module set\n\
+\\n\
\ :set <option> ... set options\n\
\ :set args <arg> ... set the arguments returned by System.getArgs\n\
\ :set prog <progname> set the value returned by System.getProgName\n\
-\ :undef <cmd> undefine user-defined command :<cmd>\n\
+\\n\
+\ :show modules show the currently loaded modules\n\
+\ :show bindings show the current bindings made at the prompt\n\
+\\n\
\ :type <expr> show the type of <expr>\n\
+\ :undef <cmd> undefine user-defined command :<cmd>\n\
\ :unset <option> ... unset options\n\
\ :quit exit GHCi\n\
\ :!<command> run the shell command <command>\n\
fileLoop :: Handle -> Bool -> GHCi ()
fileLoop hdl prompt = do
- st <- getGHCiState
- (mod,imports) <- io (cmGetContext (cmstate st))
+ cmstate <- getCmState
+ (mod,imports) <- io (cmGetContext cmstate)
when prompt (io (putStr (mkPrompt mod imports)))
l <- io (IO.try (hGetLine hdl))
case l of
stringLoop :: [String] -> GHCi ()
stringLoop [] = return ()
stringLoop (s:ss) = do
- st <- getGHCiState
case remove_spaces s of
"" -> stringLoop ss
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 "")
- ++ "> "
+ = concat (intersperse " " (toplevs ++ map ('*':) exports)) ++ "> "
#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
readlineLoop :: GHCi ()
readlineLoop = do
- st <- getGHCiState
- (mod,imports) <- io (cmGetContext (cmstate st))
+ cmstate <- getCmState
+ (mod,imports) <- io (cmGetContext cmstate)
io yield
l <- io (readline (mkPrompt mod imports))
case l of
-- possibly print the type and revert CAFs after evaluating an expression
finishEvalExpr names
= do b <- isOptionSet ShowType
- st <- getGHCiState
- when b (mapM_ (showTypeOfName (cmstate st)) names)
+ cmstate <- getCmState
+ when b (mapM_ (showTypeOfName cmstate) names)
b <- isOptionSet RevertCAFs
io (when b revertCAFs)
info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
info s = do
let names = words s
- state <- getGHCiState
+ init_cms <- getCmState
dflags <- io getDynFlags
let
infoThings cms [] = return cms
infoThings cms (name:names) = do
- (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
+ (cms, stuff) <- io (cmInfoThing cms dflags name)
io (putStrLn (showSDocForUser unqual (
vcat (intersperse (text "") (map showThing stuff))))
)
infoThings cms names
+ unqual = cmGetPrintUnqual init_cms
+
showThing (ty_thing, fixity)
= vcat [ text "-- " <> showTyThing ty_thing,
showFixity fixity (getName ty_thing),
= empty
where loc = nameSrcLoc name
- cms <- infoThings (cmstate state) names
- setGHCiState state{ cmstate = cms }
+ cms <- infoThings init_cms names
+ setCmState cms
return ()
addModule :: String -> GHCi ()
let new_expr = '(' : definition ++ ") :: String -> IO String"
-- compile the expression
- st <- getGHCiState
+ cms <- getCmState
dflags <- io getDynFlags
- (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
- setGHCiState st{cmstate = new_cmstate}
+ (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
+ setCmState new_cmstate
case maybe_hv of
Nothing -> return ()
Just hv -> io (writeIORef commands --
io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
-importModules :: String -> GHCi ()
-importModules str = return ()
-
-
loadModule :: String -> GHCi ()
loadModule str = timeIt (loadModule' str)
reloadModule _ = noArgs ":reload"
setContextAfterLoad [] = setContext prel
-setContextAfterLoad (m:_) = setContext m
+setContextAfterLoad (m:_) = do
+ cmstate <- getCmState
+ b <- io (cmModuleIsInterpreted cmstate m)
+ if b then setContext m else setContext ('*':m)
modulesLoadedMsg ok mods = do
let mod_commas
typeOfExpr :: String -> GHCi ()
typeOfExpr str
- = do st <- getGHCiState
+ = do cms <- getCmState
dflags <- io getDynFlags
- (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
- setGHCiState st{cmstate = new_cmstate}
+ (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
+ setCmState new_cmstate
case maybe_tystr of
Nothing -> return ()
Just tystr -> io (putStrLn tystr)
-- 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
+ | all sensible mods = fn mods
+ | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
+ where
+ (fn, mods) = case str of
+ '+':stuff -> (addToContext, words stuff)
+ '-':stuff -> (removeFromContext, words stuff)
+ stuff -> (newContext, words stuff)
+
+ sensible ('*':c:cs) = isUpper c && all isAlphaNumEx cs
+ 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
+ cms <- getCmState
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 [] []
+ (as,bs) <- separate cms 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'}
-
+ cms' <- io (cmSetContext cms dflags as bs')
+ setCmState cms'
+
+separate cmstate [] as bs = return (as,bs)
+separate cmstate (('*':m):ms) as bs = separate cmstate ms as (m:bs)
+separate cmstate (m:ms) as bs = do
+ b <- io (cmModuleIsInterpreted cmstate m)
+ if b then separate cmstate ms (m:as) bs
+ else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
+
prel = "Prelude"
-adjustContext mods = do
- state@GHCiState{cmstate=cmstate} <- getGHCiState
+
+addToContext mods = do
+ cms <- getCmState
dflags <- io getDynFlags
+ (as,bs) <- io (cmGetContext cms)
- 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'}
+ (as',bs') <- separate cms mods [] []
+
+ let as_to_add = as' \\ (as ++ bs)
+ bs_to_add = bs' \\ (as ++ bs)
+
+ cms' <- io (cmSetContext cms dflags
+ (as ++ as_to_add) (bs ++ bs_to_add))
+ setCmState cms'
+
+
+removeFromContext mods = do
+ cms <- getCmState
+ dflags <- io getDynFlags
+ (as,bs) <- io (cmGetContext cms)
+
+ (as_to_remove,bs_to_remove) <- separate cms mods [] []
+
+ let as' = as \\ (as_to_remove ++ bs_to_remove)
+ bs' = bs \\ (as_to_remove ++ bs_to_remove)
+
+ cms' <- io (cmSetContext cms dflags as' bs')
+ setCmState cms'
----------------------------------------------------------------------------
-- Code for `:set'
mapM_ linkPackage (reverse new_pkg_info)
-----------------------------------------------------------------------------
+-- code for `:show'
+
+showCmd str =
+ case words str of
+ ["modules" ] -> showModules
+ ["bindings"] -> showBindings
+ _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
+
+showModules = do
+ cms <- getCmState
+ let mg = cmGetModuleGraph cms
+ ls = cmGetLinkables cms
+ maybe_linkables = map (findModuleLinkable_maybe ls)
+ (map (moduleName.ms_mod) mg)
+ zipWithM showModule mg maybe_linkables
+ return ()
+
+showModule :: ModSummary -> Maybe Linkable -> GHCi ()
+showModule m (Just l) = do
+ io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
+showModule _ Nothing = panic "missing linkable"
+
+showBindings = do
+ cms <- getCmState
+ let
+ unqual = cmGetPrintUnqual cms
+ showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
+
+ io (mapM showBinding (cmGetBindings cms))
+ return ()
+
+-----------------------------------------------------------------------------
-- GHCi monad
data GHCiState = GHCiState
getGHCiState = GHCi $ \r -> readIORef r
setGHCiState s = GHCi $ \r -> writeIORef r s
+-- for convenience...
+getCmState = getGHCiState >>= return . cmstate
+setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
+
isOptionSet :: GHCiOption -> GHCi Bool
isOptionSet opt
= do st <- getGHCiState
import Type ( Type )
import Id ( Id, idName, setGlobalIdDetails )
import IdInfo ( GlobalIdDetails(VanillaGlobal) )
-import HscTypes ( InteractiveContext(..) )
+import Name ( isLocalName )
+import NameEnv ( lookupNameEnv )
import PrelNames ( iNTERACTIVE )
import StringBuffer ( stringToStringBuffer )
import FastString ( mkFastString )
= do {
when (verbosity dflags >= 1) $
hPutStrLn stderr ("Skipping " ++
- compMsg have_object mod location);
+ showModMsg have_object mod location);
-- CLOSURE
(pcs_cl, closure_errs, cl_hs_decls)
return (HscNoRecomp pcs_tc new_details old_iface)
}}}
-compMsg use_object mod location =
- mod_str ++ replicate (max 0 (16 - length mod_str)) ' '
- ++" ( " ++ unJust "hscRecomp" (ml_hs_file location) ++ ", "
- ++ (if use_object
- then unJust "hscRecomp" (ml_obj_file location)
- else "interpreted")
- ++ " )"
- where mod_str = moduleUserString mod
-
-
hscRecomp ghci_mode dflags have_object
mod location maybe_checked_iface hst hit pcs_ch
= do {
; when (ghci_mode /= OneShot && verbosity dflags >= 1) $
hPutStrLn stderr ("Compiling " ++
- compMsg (not toInterp) mod location);
+ showModMsg (not toInterp) mod location);
-------------------
-- PARSE
-> IO ( PersistentCompilerState,
[TyThing] )
-hscThing dflags hst hit pcs0 icontext str
+hscThing dflags hst hit pcs0 ic str
= do maybe_rdr_name <- myParseIdentifier dflags str
case maybe_rdr_name of {
Nothing -> return (pcs0, []);
tccls_name = setRdrNameOcc rdr_name tccls_occ
(pcs, unqual, maybe_rn_result) <-
- renameRdrName dflags hit hst pcs0 icontext rdr_names
+ renameRdrName dflags hit hst pcs0 ic rdr_names
case maybe_rn_result of {
Nothing -> return (pcs, []);
case maybe_pcs of {
Nothing -> return (pcs, []);
Just pcs ->
- let maybe_ty_things = map (lookupType hst (pcs_PTE pcs)) names
+ let do_lookup n
+ | isLocalName n = lookupNameEnv (ic_type_env ic) n
+ | otherwise = lookupType hst (pcs_PTE pcs) n
+
+ maybe_ty_things = map do_lookup names
in
return (pcs, catMaybes maybe_ty_things) }
}}}
projects / ghc-hetmet.git / commitdiff