From a29fe41700438c08e4b24f4d31e57896d414d2b6 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 27 Feb 2001 15:26:05 +0000 Subject: [PATCH] [project @ 2001-02-27 15:26:04 by simonmar] - make flushing and :def work again in the interpreter --- ghc/compiler/compMan/CompManager.lhs | 92 ++++++++++++++++++++++++++++++---- ghc/compiler/ghci/InteractiveUI.hs | 75 +++++++++++++-------------- 2 files changed, 118 insertions(+), 49 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index ad14b26..8dc68d1 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -6,14 +6,27 @@ \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 ) @@ -165,19 +178,24 @@ moduleNameToModule mn -- 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) @@ -190,20 +208,40 @@ cmRunStmt cmstate dflags expr 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 @@ -219,6 +257,42 @@ cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name 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: diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 8f0795f..68147c0 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -60,7 +60,7 @@ builtin_commands :: [(String, String -> GHCi Bool)] builtin_commands = [ ("add", keepGoing addModule), ("cd", keepGoing changeDirectory), --- ("def", keepGoing defineMacro), + ("def", keepGoing defineMacro), ("help", keepGoing help), ("?", keepGoing help), ("load", keepGoing loadModule), @@ -124,20 +124,18 @@ interactiveUI cmstate mod cmdline_libs = do 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] } @@ -278,11 +276,11 @@ showTypeOfName cmstate n 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) @@ -322,7 +320,6 @@ setContext str changeDirectory :: String -> GHCi () changeDirectory d = io (setCurrentDirectory d) -{- defineMacro :: String -> GHCi () defineMacro s = do let (macro_name, definition) = break isSpace s @@ -332,7 +329,7 @@ defineMacro s = do 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 @@ -342,15 +339,17 @@ defineMacro s = do -- 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 @@ -414,15 +413,11 @@ typeOfExpr :: String -> GHCi () 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 @@ -540,8 +535,8 @@ data GHCiOption | 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) } -- 1.7.10.4