\begin{code}
module CompManager (
cmInit, -- :: GhciMode -> IO CmState
+
cmLoadModule, -- :: CmState -> FilePath -> IO (CmState, [String])
+
cmUnload, -- :: CmState -> IO CmState
+
cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
cmSetContext, -- :: CmState -> String -> IO CmState
+
cmGetContext, -- :: CmState -> IO String
+
#ifdef GHCI
cmRunStmt, -- :: CmState -> DynFlags -> String -> IO (CmState, [Name])
+
+ cmTypeOfExpr, -- :: CmState -> DynFlags -> String
+ -- -> IO (CmState, Maybe String)
+
+ cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
+
+ cmCompileExpr,-- :: CmState -> DynFlags -> String
+ -- -> IO (CmState, Maybe HValue)#endif
#endif
CmState, emptyCmState -- abstract
)
-- cmRunStmt: Run a statement/expr.
#ifdef GHCI
-cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, [Name])
+cmRunStmt :: CmState -> DynFlags -> String
+ -> IO (CmState, -- new state
+ [Name]) -- names bound by this evaluation
cmRunStmt cmstate dflags expr
= do
- let icontext = ic cmstate
- InteractiveContext {
+ let InteractiveContext {
ic_rn_env = rn_env,
ic_type_env = type_env,
ic_module = this_mod } = icontext
- (new_pcs, maybe_stuff) <- hscStmt dflags hst hit pcs icontext expr
+ (new_pcs, maybe_stuff)
+ <- hscStmt dflags hst hit pcs icontext expr
+
case maybe_stuff of
Nothing -> return (cmstate{ pcs=new_pcs }, [])
Just (ids, bcos) -> do
+
+ -- update the interactive context
let
new_rn_env = extendLocalRdrEnv rn_env (map idName ids)
new_ic = icontext { ic_rn_env = new_rn_env,
ic_type_env = new_type_env }
+ -- link it
hval <- linkExpr pls bcos
- hvals <- unsafeCoerce# hval :: IO [HValue]
+
+ -- run it!
+ let thing_to_run = unsafeCoerce# hval :: IO [HValue]
+ hvals <- thing_to_run
+
+ -- get the newly bound things, and bind them
let names = map idName ids
new_pls <- updateClosureEnv pls (zip names hvals)
- return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
- -- ToDo: check that the module we passed in is sane/exists?
+ return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
where
- CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls } = cmstate
+ CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
+#endif
+
+-----------------------------------------------------------------------------
+-- cmTypeOfExpr: returns a string representing the type of an expression
+
+#ifdef GHCI
+cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String)
+cmTypeOfExpr cmstate dflags expr
+ = do (new_cmstate, names)
+ <- cmRunStmt cmstate dflags ("let __cmTypeOfExpr=" ++ expr)
+ case names of
+ [name] -> do maybe_tystr <- cmTypeOfName new_cmstate name
+ return (new_cmstate, maybe_tystr)
+ _other -> pprPanic "cmTypeOfExpr" (ppr names)
#endif
-----------------------------------------------------------------------------
--- cmTypeOf: returns a string representing the type of a name.
+-- cmTypeOfName: returns a string representing the type of a name.
+#ifdef GHCI
cmTypeOfName :: CmState -> Name -> IO (Maybe String)
cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name
= case lookupNameEnv (ic_type_env ic) name of
in return (Just str)
_ -> panic "cmTypeOfName"
+#endif
+
+-----------------------------------------------------------------------------
+-- cmCompileExpr: compile an expression and deliver an HValue
+
+#ifdef GHCI
+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
+
+ (new_pcs, maybe_stuff)
+ <- hscStmt dflags hst hit pcs icontext
+ ("let __cmCompileExpr="++expr)
+
+ case maybe_stuff of
+ Nothing -> return (cmstate{ pcs=new_pcs }, Nothing)
+ Just (ids, bcos) -> do
+
+ -- link it
+ hval <- linkExpr pls bcos
+
+ -- run it!
+ let thing_to_run = unsafeCoerce# hval :: IO [HValue]
+ hvals <- thing_to_run
+
+ case (ids,hvals) of
+ ([id],[hv]) -> return (cmstate{ pcs=new_pcs }, Just hv)
+ _ -> panic "cmCompileExpr"
+
+ where
+ CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
+#endif
-----------------------------------------------------------------------------
-- cmInfo: return "info" about an expression. The info might be:
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.52 2001/02/26 15:06:58 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.53 2001/02/27 15:26:04 simonmar Exp $
--
-- GHC Interactive User Interface
--
builtin_commands = [
("add", keepGoing addModule),
("cd", keepGoing changeDirectory),
--- ("def", keepGoing defineMacro),
+ ("def", keepGoing defineMacro),
("help", keepGoing help),
("?", keepGoing help),
("load", keepGoing loadModule),
dflags <- getDynFlags
-{-
- (cmstate, _) <- cmRunStmt cmstate dflags False prel
- "PrelHandle.hFlush PrelHandle.stdout"
- case maybe_stuff of
- Nothing -> return ()
- Just (hv,_,_) -> writeIORef flush_stdout hv
-
- (cmstate, _) <- cmGetExpr cmstate dflags False prel
- "PrelHandle.hFlush PrelHandle.stdout"
- case maybe_stuff of
- Nothing -> return ()
- Just (hv,_,_) -> writeIORef flush_stderr hv
--}
-
+ (cmstate, maybe_hval)
+ <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
+ case maybe_hval of
+ Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
+ _ -> panic "interactiveUI:stderr"
+
+ (cmstate, maybe_hval)
+ <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
+ case maybe_hval of
+ Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
+ _ -> panic "interactiveUI:stdout"
+
(unGHCi runGHCi) GHCiState{ target = mod,
cmstate = cmstate,
options = [ShowTiming] }
flushEverything :: GHCi ()
flushEverything
- = io $ {-do flush_so <- readIORef flush_stdout
- cmRunExpr flush_so
+ = io $ do flush_so <- readIORef flush_stdout
+ flush_so
flush_se <- readIORef flush_stdout
- cmRunExpr flush_se
- -} (return ())
+ flush_se
+ return ()
specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
changeDirectory :: String -> GHCi ()
changeDirectory d = io (setCurrentDirectory d)
-{-
defineMacro :: String -> GHCi ()
defineMacro s = do
let (macro_name, definition) = break isSpace s
else do
if (macro_name `elem` map fst cmds)
then throwDyn (OtherError
- ("command `" ++ macro_name ++ "' already defined"))
+ ("command `" ++ macro_name ++ "' is already defined"))
else do
-- give the expression a type signature, so we can be sure we're getting
-- compile the expression
st <- getGHCiState
dflags <- io (getDynFlags)
- (new_cmstate, maybe_stuff) <-
- io (cmGetExpr (cmstate st) dflags new_expr)
+ (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
setGHCiState st{cmstate = new_cmstate}
- case maybe_stuff of
- Nothing -> return ()
- Just (hv, unqual, ty)
- -> io (writeIORef commands
- ((macro_name, keepGoing (runMacro hv)) : cmds))
--}
+ case maybe_hv of
+ Nothing -> return ()
+ Just hv ->
+ do funs <- io (unsafeCoerce# hv :: IO [HValue])
+ case funs of
+ [fun] -> io (writeIORef commands
+ ((macro_name, keepGoing (runMacro fun))
+ : cmds))
+ _ -> throwDyn (OtherError "defineMacro: bizarre")
runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
runMacro fun s = do
typeOfExpr str
= do st <- getGHCiState
dflags <- io (getDynFlags)
- (new_cmstate, names)
- <- io (cmRunStmt (cmstate st) dflags ("let it=" ++ str))
+ (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
setGHCiState st{cmstate = new_cmstate}
- case names of
- [name] -> do maybe_tystr <- io (cmTypeOfName new_cmstate name)
- case maybe_tystr of
- Nothing -> return ()
- Just tystr -> io (putStrLn (":: " ++ tystr))
- _other -> pprPanic "typeOfExpr" (ppr names)
+ case maybe_tystr of
+ Nothing -> return ()
+ Just tystr -> io (putStrLn tystr)
quit :: String -> GHCi Bool
quit _ = return True
| RevertCAFs -- revert CAFs after every evaluation
deriving Eq
-GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
-GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
+GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
+GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
projects / ghc-hetmet.git / commitdiff