X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=cf301f47fb68c7f00f05dbd8c055844a655e6057;hb=0ef29fb878dd6517d2716afb056bcf2536c2562e;hp=863176b5cd2eae0b13b84189c3752c7c48af5214;hpb=8fe9b1aff1871324e85189229ceb92d6d0c206e0;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 863176b..cf301f4 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.15 2000/11/24 17:09:52 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.28 2001/01/18 12:54:16 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -14,15 +14,18 @@ module InteractiveUI (interactiveUI) where import CompManager import CmStaticInfo import DriverFlags -import DriverUtil import DriverState import Linker import Module import Outputable import Util +import PprType {- instance Outputable Type; do not delete -} +import Panic ( GhcException(..) ) import Exception +#ifndef NO_READLINE import Readline +#endif import IOExts import Numeric @@ -32,6 +35,8 @@ import CPUTime import Directory import IO import Char +import Monad ( when ) + ----------------------------------------------------------------------------- @@ -43,21 +48,24 @@ ghciWelcomeMsg = "\ \|| || || || || (| Bug reports to: glasgow-haskell-bugs@haskell.org \n\ \(|___|| || || (|__|) \\\\______________________________________________________\n" -commands :: [(String, String -> GHCi ())] +commands :: [(String, String -> GHCi Bool)] commands = [ - ("add", addModule), - ("cd", changeDirectory), - ("help", help), - ("?", help), - ("load", loadModule), - ("module", setContext), - ("reload", reloadModule), - ("set", setOptions), - ("type", typeOfExpr), - ("unset", unsetOptions), + ("add", keepGoing addModule), + ("cd", keepGoing changeDirectory), + ("help", keepGoing help), + ("?", keepGoing help), + ("load", keepGoing loadModule), + ("module", keepGoing setContext), + ("reload", keepGoing reloadModule), + ("set", keepGoing setOptions), + ("type", keepGoing typeOfExpr), + ("unset", keepGoing unsetOptions), ("quit", quit) ] +keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) +keepGoing a str = a str >> return False + shortHelpText = "use :? for help.\n" helpText = "\ @@ -108,9 +116,10 @@ interactiveUI cmstate mod = do (unGHCi uiLoop) GHCiState{ modules = mods, current_module = this_mod, - target = Nothing, + target = mod, cmstate = cmstate', - options = [ShowTiming]} + options = [ShowTiming], + last_expr = Nothing} return () uiLoop :: GHCi () @@ -119,7 +128,8 @@ uiLoop = do #ifndef NO_READLINE l <- io (readline (moduleNameUserString (current_module st) ++ "> ")) #else - l <- io (hGetLine stdin) + l_ok <- io (hGetLine stdin) + let l = Just l_ok #endif case l of Nothing -> exitGHCi @@ -128,41 +138,60 @@ uiLoop = do #ifndef NO_READLINE io (addHistory l) #endif - runCommand l - uiLoop + quit <- runCommand l + if quit then exitGHCi else uiLoop -exitGHCi = io $ do putStrLn "Leaving GHCi."; exitWith ExitSuccess +exitGHCi = io $ do putStrLn "Leaving GHCi." -- Top level exception handler, just prints out the exception -- and carries on. +runCommand :: String -> GHCi Bool runCommand c = - ghciHandle ( \other_exception ->io (putStrLn (show other_exception) )) $ + ghciHandle ( + \other_exception + -> io (putStrLn (show other_exception)) >> return False + ) $ ghciHandleDyn (\dyn -> case dyn of PhaseFailed phase code -> io ( putStrLn ("Phase " ++ phase ++ " failed (code " ++ show code ++ ")")) Interrupted -> io (putStrLn "Interrupted.") - _ -> io (putStrLn (show (dyn :: BarfKind))) + _ -> io (putStrLn (show (dyn :: GhcException))) + >> return False ) $ doCommand c doCommand (':' : command) = specialCommand command -doCommand expr = timeIt (evalExpr expr) - +doCommand expr + = do expr_expanded <- expandExpr expr + -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter: " ++ expr_expanded)) + expr_ok <- timeIt (do ok <- evalExpr expr_expanded + when ok (evalExpr "PrelHandle.hFlush PrelHandle.stdout" >> return ()) + when ok (evalExpr "PrelHandle.hFlush PrelHandle.stderr" >> return ()) + return ok) + when expr_ok (rememberExpr expr_expanded) + return False + +-- Returned Bool indicates whether or not the expr was successfully +-- parsed, renamed and typechecked. +evalExpr :: String -> GHCi Bool evalExpr expr + | null (filter (not.isSpace) expr) + = return False + | otherwise = do st <- getGHCiState dflags <- io (getDynFlags) (new_cmstate, maybe_stuff) <- - io (cmGetExpr (cmstate st) dflags (current_module st) expr) + io (cmGetExpr (cmstate st) dflags (current_module st) expr True) setGHCiState st{cmstate = new_cmstate} case maybe_stuff of - Nothing -> return () + Nothing -> return False Just (hv, unqual, ty) -> do io (cmRunExpr hv) b <- isOptionSet ShowType - if b then io (printForUser stdout unqual (text "::" <+> ppr ty)) - else return () + io (when b (printForUser stdout unqual (text "::" <+> ppr ty))) + return True {- let (mod,'.':str) = break (=='.') expr @@ -172,17 +201,18 @@ evalExpr expr return () -} -specialCommand ('!':str) = shellEscape (dropWhile isSpace str) +specialCommand :: String -> GHCi Bool +specialCommand ('!':str) = shellEscape (dropWhile isSpace str) specialCommand str = do let (cmd,rest) = break isSpace str case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of - [] -> io $ hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n" - ++ shortHelpText) + [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n" + ++ shortHelpText) >> return False) [(_,f)] -> f (dropWhile isSpace rest) - cs -> io $ hPutStrLn stdout ("prefix " ++ cmd ++ - " matches multiple commands (" ++ + cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++ + " matches multiple commands (" ++ foldr1 (\a b -> a ++ ',':b) (map fst cs) - ++ ")") + ++ ")") >> return False) noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments")) @@ -205,7 +235,7 @@ setContext m setGHCiState st{current_module = mkModuleName m} changeDirectory :: String -> GHCi () -changeDirectory = io . setCurrentDirectory +changeDirectory d = io (setCurrentDirectory d) loadModule :: String -> GHCi () loadModule path = timeIt (loadModule' path) @@ -220,7 +250,7 @@ loadModule' path = do modules = mods, current_module = case mods of [] -> defaultCurrentModule - xs -> last xs, + xs -> head xs, target = Just path } setGHCiState new_state @@ -241,25 +271,34 @@ reloadModule "" = do case target state of Nothing -> io (putStr "no current target\n") Just path - -> do (new_cmstate, ok, mod) <- io (cmLoadModule (cmstate state) path) - setGHCiState state{cmstate=new_cmstate} + -> do (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path) + setGHCiState + state{cmstate=new_cmstate, + modules = mods, + current_module = case mods of + [] -> defaultCurrentModule + xs -> head xs + } + + reloadModule _ = noArgs ":reload" typeOfExpr :: String -> GHCi () typeOfExpr str = do st <- getGHCiState dflags <- io (getDynFlags) - (st, maybe_ty) <- io (cmGetExpr (cmstate st) dflags - (current_module st) str) + (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags + (current_module st) str False) + setGHCiState st{cmstate = new_cmstate} case maybe_ty of Nothing -> return () - Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty)) + Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty)) -quit :: String -> GHCi () -quit _ = exitGHCi +quit :: String -> GHCi Bool +quit _ = return True -shellEscape :: String -> GHCi () -shellEscape str = io (system str >> return ()) +shellEscape :: String -> GHCi Bool +shellEscape str = io (system str >> return False) ---------------------------------------------------------------------------- -- Code for `:set' @@ -349,6 +388,45 @@ optToStr :: GHCiOption -> String optToStr ShowTiming = "s" optToStr ShowType = "t" + +----------------------------------------------------------------------------- +-- Code to do last-expression-entered stuff. (a.k.a the $$ facility) + +-- Take a string and replace $$s in it with the last expr, if any. +expandExpr :: String -> GHCi String +expandExpr str + = do mle <- getLastExpr + return (outside mle str) + where + outside mle ('$':'$':cs) + = case mle of + Just le -> " (" ++ le ++ ") " ++ outside mle cs + Nothing -> outside mle cs + + outside mle [] = [] + outside mle ('"':str) = '"' : inside2 mle str -- " + outside mle ('\'':str) = '\'' : inside1 mle str -- ' + outside mle (c:cs) = c : outside mle cs + + inside2 mle ('"':cs) = '"' : outside mle cs -- " + inside2 mle (c:cs) = c : inside2 mle cs + inside2 mle [] = [] + + inside1 mle ('\'':cs) = '\'': outside mle cs + inside1 mle (c:cs) = c : inside1 mle cs + inside1 mle [] = [] + + +rememberExpr :: String -> GHCi () +rememberExpr str + = do let cleaned = (clean . reverse . clean . reverse) str + let forget_me_not | null cleaned = Nothing + | otherwise = Just cleaned + setLastExpr forget_me_not + where + clean = dropWhile isSpace + + ----------------------------------------------------------------------------- -- GHCi monad @@ -358,7 +436,8 @@ data GHCiState = GHCiState current_module :: ModuleName, target :: Maybe FilePath, cmstate :: CmState, - options :: [GHCiOption] + options :: [GHCiOption], + last_expr :: Maybe String } data GHCiOption = ShowTiming | ShowType deriving Eq @@ -389,6 +468,14 @@ unsetOption opt = do st <- getGHCiState setGHCiState (st{ options = filter (/= opt) (options st) }) +getLastExpr :: GHCi (Maybe String) +getLastExpr + = do st <- getGHCiState ; return (last_expr st) + +setLastExpr :: Maybe String -> GHCi () +setLastExpr last_expr + = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr}) + io m = GHCi $ \s -> m >>= \a -> return (s,a) ghciHandle h (GHCi m) = GHCi $ \s ->