-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.2 2000/11/16 11:39:37 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.14 2000/11/22 17:51:16 simonmar Exp $
--
-- GHC Interactive User Interface
--
module InteractiveUI (interactiveUI) where
+#include "HsVersions.h"
+
import CompManager
import CmStaticInfo
+import DriverFlags
import DriverUtil
import DriverState
import Linker
import Module
-import Panic
+import Outputable
import Util
import Exception
commands :: [(String, String -> GHCi ())]
commands = [
+ ("add", addModule),
("cd", changeDirectory),
("help", help),
("?", help),
("load", loadModule),
+ ("module", setContext),
("reload", reloadModule),
("set", setOptions),
("type", typeOfExpr),
- ("quit", quit),
- ("!", shellEscape)
+ ("quit", quit)
]
shortHelpText = "use :? for help.\n"
helpText = "\
\ <expr> evaluate <expr>\n\
+\ :add <filename> add a module to the current set\n\
\ :cd <dir> change directory to <dir>\n\
-\ :help display this list of commands\n\
-\ :? display this list of commands\n\
+\ :help, :? display this list of commands\n\
\ :load <filename> load a module (and it dependents)\n\
-\ :reload reload the current program\n\
-\ :set <opetion> ... set options\n\
+\ :module <mod> set the context for expression evaluation to <mod>\n\
+\ :reload reload the current module set\n\
+\ :set <option> ... set options\n\
\ :type <expr> show the type of <expr>\n\
\ :quit exit GHCi\n\
\ :!<command> run the shell command <command>\n\
\"
-interactiveUI :: CmState -> IO ()
-interactiveUI st = do
+interactiveUI :: CmState -> [ModuleName] -> IO ()
+interactiveUI st mods = do
hPutStrLn stdout ghciWelcomeMsg
hFlush stdout
hSetBuffering stdout NoBuffering
#ifndef NO_READLINE
Readline.initialize
#endif
- _ <- (unGHCi uiLoop) GHCiState{ current_module = mkModuleName "Prelude",
- target = Nothing,
- cmstate = st }
+ let this_mod = case mods of
+ [] -> defaultCurrentModule
+ m:ms -> m
+
+ (unGHCi uiLoop) GHCiState{ modules = mods,
+ current_module = this_mod,
+ target = Nothing,
+ cmstate = st }
return ()
uiLoop :: GHCi ()
uiLoop = do
st <- getGHCiState
#ifndef NO_READLINE
- l <- io (readline (moduleNameUserString (current_module st) ++ ">"))
+ l <- io (readline (moduleNameUserString (current_module st) ++ "> "))
#else
l <- io (hGetLine stdin)
#endif
case l of
- Nothing -> return ()
+ Nothing -> exitGHCi
Just "" -> uiLoop
Just l -> do
#ifndef NO_READLINE
runCommand l
uiLoop
-runCommand c = myCatch (doCommand c)
- (\e -> io (hPutStr stdout ("Error: " ++ show e)))
+exitGHCi = io $ do putStrLn "Leaving GHCi."; exitWith ExitSuccess
+
+-- Top level exception handler, just prints out the exception
+-- and carries on.
+runCommand c =
+ ghciHandle ( \other_exception ->io (putStrLn (show other_exception) )) $
+ 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)))
+ ) $
+ doCommand c
doCommand (':' : command) = specialCommand command
-doCommand expr = do
- io (hPutStrLn stdout ("Run expression: " ++ expr))
+doCommand expr
+ = do st <- getGHCiState
+ dflags <- io (getDynFlags)
+ (new_cmstate, maybe_hvalue) <-
+ io (cmGetExpr (cmstate st) dflags (current_module st) expr)
+ setGHCiState st{cmstate = new_cmstate}
+ case maybe_hvalue of
+ Nothing -> return ()
+ Just hv -> io (cmRunExpr hv)
+{-
+ let (mod,'.':str) = break (=='.') expr
+ case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
+ Nothing -> io (putStrLn "nothing.")
+ Just e -> io (
return ()
+-}
+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 ("uknown command `:" ++ cmd ++ "'\n"
+ [] -> io $ hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
++ shortHelpText)
- [(_,f)] -> f rest
+ [(_,f)] -> f (dropWhile isSpace rest)
cs -> io $ hPutStrLn stdout ("prefix " ++ cmd ++
" matches multiple commands (" ++
- foldr1 (\a b -> a ++ ',':b) (map fst cs) ++ ")")
+ foldr1 (\a b -> a ++ ',':b) (map fst cs)
+ ++ ")")
noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
-----------------------------------------------------------------------------
-- Commands
--- ToDo: don't forget to catch errors
-
help :: String -> GHCi ()
help _ = io (putStr helpText)
+addModule :: String -> GHCi ()
+addModule _ = throwDyn (OtherError ":add not implemented")
+
+setContext :: String -> GHCi ()
+setContext ""
+ = throwDyn (OtherError "syntax: `:m <module>'")
+setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
+ = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
+setContext m
+ = do st <- getGHCiState
+ setGHCiState st{current_module = mkModuleName m}
+
changeDirectory :: String -> GHCi ()
changeDirectory = io . setCurrentDirectory
loadModule :: String -> GHCi ()
loadModule path = do
state <- getGHCiState
- (new_cmstate, mod) <- io (cmLoadModule (cmstate state) ({-ToDo!!-}mkModuleName path))
- setGHCiState state{cmstate=new_cmstate, target=Just path}
+ cmstate1 <- io (cmUnload (cmstate state))
+ (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
+
+ let new_state = GHCiState {
+ cmstate = cmstate2,
+ modules = mods,
+ current_module = case mods of
+ [] -> defaultCurrentModule
+ xs -> last xs,
+ target = Just path
+ }
+ setGHCiState new_state
+
+ let mod_commas
+ | null mods = text "none."
+ | otherwise = hsep (
+ punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
+ case ok of
+ False ->
+ io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
+ True ->
+ io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
reloadModule :: String -> GHCi ()
reloadModule "" = do
state <- getGHCiState
case target state of
- Nothing -> io (putStr "no current target\n")
- Just path -> do (new_cmstate, mod) <- io (cmLoadModule (cmstate state) (mkModuleName path))
- setGHCiState state{cmstate=new_cmstate}
+ Nothing -> io (putStr "no current target\n")
+ Just path
+ -> do (new_cmstate, ok, mod) <- io (cmLoadModule (cmstate state) path)
+ setGHCiState state{cmstate=new_cmstate}
reloadModule _ = noArgs ":reload"
+-- set options in the interpreter. Syntax is exactly the same as the
+-- ghc command line, except that certain options aren't available (-C,
+-- -E etc.)
+--
+-- This is pretty fragile: most options won't work as expected. ToDo:
+-- figure out which ones & disallow them.
setOptions :: String -> GHCi ()
-setOptions = panic "setOptions"
+setOptions str =
+ io (do leftovers <- processArgs static_flags (words str) []
+ dyn_flags <- readIORef v_InitDynFlags
+ writeIORef v_DynFlags dyn_flags
+ leftovers <- processArgs dynamic_flags leftovers []
+ dyn_flags <- readIORef v_DynFlags
+ writeIORef v_InitDynFlags dyn_flags
+ if (not (null leftovers))
+ then throwDyn (OtherError ("unrecognised flags: " ++
+ unwords leftovers))
+ else return ()
+ )
typeOfExpr :: String -> GHCi ()
-typeOfExpr = panic "typeOfExpr"
+typeOfExpr str
+ = do st <- getGHCiState
+ dflags <- io (getDynFlags)
+ (st, maybe_ty) <- io (cmTypeExpr (cmstate st) dflags
+ (current_module st) str)
+ case maybe_ty of
+ Nothing -> return ()
+ Just (unqual, ty) -> io (printForUser stdout unqual (ppr ty))
quit :: String -> GHCi ()
-quit _ = return ()
+quit _ = exitGHCi
shellEscape :: String -> GHCi ()
shellEscape str = io (system str >> return ())
data GHCiState = GHCiState
{
+ modules :: [ModuleName],
current_module :: ModuleName,
target :: Maybe FilePath,
cmstate :: CmState
}
+defaultCurrentModule = mkModuleName "Prelude"
+
newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
instance Monad GHCi where
io m = GHCi $ \s -> m >>= \a -> return (s,a)
-myCatch (GHCi m) h = GHCi $ \s -> Exception.catch (m s) (\e -> unGHCi (h e) s)
+ghciHandle h (GHCi m) = GHCi $ \s ->
+ Exception.catch (m s) (\e -> unGHCi (h e) s)
+ghciHandleDyn h (GHCi m) = GHCi $ \s ->
+ Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
-----------------------------------------------------------------------------
-- package loader
let path = d ++ '/':obj
b <- doesFileExist path
if b then return path else findFile ds obj
-
-
projects / ghc-hetmet.git / blobdiff