1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.43 2001/02/12 12:25:50 simonmar Exp $
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2000
8 -----------------------------------------------------------------------------
10 {-# OPTIONS -#include "Linker.h" #-}
11 module InteractiveUI (interactiveUI) where
13 #include "HsVersions.h"
27 import PprType {- instance Outputable Type; do not delete -}
28 import Panic ( GhcException(..) )
47 import PrelGHC ( unsafeCoerce# )
49 -----------------------------------------------------------------------------
53 \ / _ \\ /\\ /\\/ __(_)\n\
54 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", For Haskell 98.\n\
55 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
56 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
58 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
60 builtin_commands :: [(String, String -> GHCi Bool)]
62 ("add", keepGoing addModule),
63 ("cd", keepGoing changeDirectory),
64 ("def", keepGoing defineMacro),
65 ("help", keepGoing help),
66 ("?", keepGoing help),
67 ("load", keepGoing loadModule),
68 ("module", keepGoing setContext),
69 ("reload", keepGoing reloadModule),
70 ("set", keepGoing setOptions),
71 ("type", keepGoing typeOfExpr),
72 ("unset", keepGoing unsetOptions),
73 ("undef", keepGoing undefineMacro),
77 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
78 keepGoing a str = a str >> return False
80 shortHelpText = "use :? for help.\n"
83 \ Commands available from the prompt:\n\
85 \ <expr> evaluate <expr>\n\
86 \ :add <filename> add a module to the current set\n\
87 \ :cd <dir> change directory to <dir>\n\
88 \ :help, :? display this list of commands\n\
89 \ :load <filename> load a module (and it dependents)\n\
90 \ :module <mod> set the context for expression evaluation to <mod>\n\
91 \ :reload reload the current module set\n\
92 \ :set <option> ... set options\n\
93 \ :unset <option> ... unset options\n\
94 \ :type <expr> show the type of <expr>\n\
96 \ :!<command> run the shell command <command>\n\
98 \ Options for `:set' and `:unset':\n\
100 \ +s print timing/memory stats after each evaluation\n\
101 \ +t print type after evaluation\n\
102 \ +r revert top-level expressions after each evaluation\n\
103 \ -<flags> most GHC command line flags can also be set here\n\
104 \ (eg. -v2, -fglasgow-exts, etc.)\n\
107 interactiveUI :: CmState -> Maybe FilePath -> IO ()
108 interactiveUI cmstate mod = do
109 hPutStrLn stdout ghciWelcomeMsg
111 hSetBuffering stdout NoBuffering
113 -- link in the available packages
114 pkgs <- getPackageInfo
116 linkPackages (reverse pkgs)
118 (cmstate, ok, mods) <-
120 Nothing -> return (cmstate, True, [])
121 Just m -> cmLoadModule cmstate m
127 prel <- moduleNameToModule defaultCurrentModuleName
128 writeIORef defaultCurrentModule prel
130 dflags <- getDynFlags
132 (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
133 "PrelHandle.hFlush PrelHandle.stdout"
136 Just (hv,_,_) -> writeIORef flush_stdout hv
138 (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
139 "PrelHandle.hFlush PrelHandle.stdout"
142 Just (hv,_,_) -> writeIORef flush_stderr hv
144 let this_mod = case mods of
148 (unGHCi runGHCi) GHCiState{ modules = mods,
149 current_module = this_mod,
152 options = [ShowTiming],
160 dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
163 Right hdl -> fileLoop hdl False
166 home <- io (IO.try (getEnv "HOME"))
170 dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
173 Right hdl -> fileLoop hdl False
175 -- read commands from stdin
183 io $ do putStrLn "Leaving GHCi."
186 fileLoop :: Handle -> Bool -> GHCi ()
187 fileLoop hdl prompt = do
189 when prompt (io (hPutStr hdl (moduleUserString (current_module st) ++ "> ")))
190 l <- io (IO.try (hGetLine hdl))
192 Left e | isEOFError e -> return ()
193 | otherwise -> throw e
195 case remove_spaces l of
196 "" -> fileLoop hdl prompt
197 l -> do quit <- runCommand l
198 if quit then return () else fileLoop hdl prompt
200 stringLoop :: [String] -> GHCi ()
201 stringLoop [] = return ()
202 stringLoop (s:ss) = do
204 case remove_spaces s of
206 l -> do quit <- runCommand l
207 if quit then return () else stringLoop ss
210 readlineLoop :: GHCi ()
213 l <- io (readline (moduleUserString (current_module st) ++ "> "))
217 case remove_spaces l of
222 if quit then return () else readlineLoop
225 -- Top level exception handler, just prints out the exception
227 runCommand :: String -> GHCi Bool
229 ghciHandle ( \exception ->
232 case fromDynamic dyn of
233 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
236 PhaseFailed phase code ->
237 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
238 ++ show code ++ ")"))
239 Interrupted -> io (putStrLn "Interrupted.")
240 other -> io (putStrLn (show (ghc_ex :: GhcException)))
242 other -> io (putStrLn ("*** Exception: " ++ show exception))
249 doCommand (':' : command) = specialCommand command
250 doCommand ('-':'-':_) = return False -- comments, useful in scripts
252 = do expr_expanded <- expandExpr expr
253 -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter: " ++ expr_expanded))
254 expr_ok <- timeIt (do stuff <- evalExpr expr_expanded
255 finishEvalExpr stuff)
256 when expr_ok (rememberExpr expr_expanded)
259 -- possibly print the type and revert CAFs after evaluating an expression
260 finishEvalExpr Nothing = return False
261 finishEvalExpr (Just (unqual,ty))
262 = do b <- isOptionSet ShowType
263 io (when b (printForUser stdout unqual (text "::" <+> ppr ty)))
264 b <- isOptionSet RevertCAFs
265 io (when b revertCAFs)
268 -- Returned Bool indicates whether or not the expr was successfully
269 -- parsed, renamed and typechecked.
270 evalExpr :: String -> GHCi (Maybe (PrintUnqualified,Type))
272 | null (filter (not.isSpace) expr)
275 = do st <- getGHCiState
276 dflags <- io (getDynFlags)
277 (new_cmstate, maybe_stuff) <-
278 io (cmGetExpr (cmstate st) dflags True (current_module st) expr)
279 setGHCiState st{cmstate = new_cmstate}
281 Nothing -> return Nothing
282 Just (hv, unqual, ty) -> do io (cmRunExpr hv)
284 return (Just (unqual,ty))
286 flushEverything :: GHCi ()
288 = io $ do flush_so <- readIORef flush_stdout
290 flush_se <- readIORef flush_stdout
293 specialCommand :: String -> GHCi Bool
294 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
295 specialCommand str = do
296 let (cmd,rest) = break isSpace str
297 cmds <- io (readIORef commands)
298 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
299 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
300 ++ shortHelpText) >> return False)
301 [(_,f)] -> f (dropWhile isSpace rest)
302 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
303 " matches multiple commands (" ++
304 foldr1 (\a b -> a ++ ',':b) (map fst cs)
305 ++ ")") >> return False)
307 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
309 -----------------------------------------------------------------------------
312 help :: String -> GHCi ()
313 help _ = io (putStr helpText)
315 addModule :: String -> GHCi ()
316 addModule _ = throwDyn (OtherError ":add not implemented")
318 setContext :: String -> GHCi ()
320 = throwDyn (OtherError "syntax: `:m <module>'")
321 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
322 = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
324 = do m <- io (moduleNameToModule (mkModuleName mn))
326 if (isHomeModule m && m `notElem` modules st)
327 then throwDyn (OtherError (showSDoc (quotes (ppr (moduleName m))
328 <+> text "is not currently loaded, use :load")))
329 else setGHCiState st{current_module = m}
331 moduleNameToModule :: ModuleName -> IO Module
332 moduleNameToModule mn
333 = do maybe_stuff <- findModule mn
335 Nothing -> throwDyn (OtherError ("can't find module `"
336 ++ moduleNameUserString mn ++ "'"))
337 Just (m,_) -> return m
339 changeDirectory :: String -> GHCi ()
340 changeDirectory d = io (setCurrentDirectory d)
342 defineMacro :: String -> GHCi ()
344 let (macro_name, definition) = break isSpace s
345 cmds <- io (readIORef commands)
347 then throwDyn (OtherError "invalid macro name")
349 if (macro_name `elem` map fst cmds)
350 then throwDyn (OtherError
351 ("command `" ++ macro_name ++ "' already defined"))
354 -- give the expression a type signature, so we can be sure we're getting
355 -- something of the right type.
356 let new_expr = '(' : definition ++ ") :: String -> IO String"
358 -- compile the expression
360 dflags <- io (getDynFlags)
361 (new_cmstate, maybe_stuff) <-
362 io (cmGetExpr (cmstate st) dflags False (current_module st) new_expr)
363 setGHCiState st{cmstate = new_cmstate}
366 Just (hv, unqual, ty)
367 -> io (writeIORef commands
368 ((macro_name, keepGoing (runMacro hv)) : cmds))
370 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
372 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
373 stringLoop (lines str)
375 undefineMacro :: String -> GHCi ()
376 undefineMacro macro_name = do
377 cmds <- io (readIORef commands)
378 if (macro_name `elem` map fst builtin_commands)
379 then throwDyn (OtherError
380 ("command `" ++ macro_name ++ "' cannot be undefined"))
382 if (macro_name `notElem` map fst cmds)
383 then throwDyn (OtherError
384 ("command `" ++ macro_name ++ "' not defined"))
386 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
388 loadModule :: String -> GHCi ()
389 loadModule path = timeIt (loadModule' path)
391 loadModule' path = do
392 state <- getGHCiState
393 cmstate1 <- io (cmUnload (cmstate state))
394 io (revertCAFs) -- always revert CAFs on load.
395 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
397 def_mod <- io (readIORef defaultCurrentModule)
399 let new_state = state{
402 current_module = case mods of
407 setGHCiState new_state
410 | null mods = text "none."
412 punctuate comma (map (text.moduleUserString) mods)) <> text "."
415 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
417 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
419 reloadModule :: String -> GHCi ()
421 state <- getGHCiState
423 Nothing -> io (putStr "no current target\n")
425 -> do io (revertCAFs) -- always revert CAFs on reload.
426 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
427 def_mod <- io (readIORef defaultCurrentModule)
429 state{cmstate=new_cmstate,
431 current_module = case mods of
436 reloadModule _ = noArgs ":reload"
438 typeOfExpr :: String -> GHCi ()
440 = do st <- getGHCiState
441 dflags <- io (getDynFlags)
442 (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False
443 (current_module st) str)
444 setGHCiState st{cmstate = new_cmstate}
447 Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
449 quit :: String -> GHCi Bool
452 shellEscape :: String -> GHCi Bool
453 shellEscape str = io (system str >> return False)
455 ----------------------------------------------------------------------------
458 -- set options in the interpreter. Syntax is exactly the same as the
459 -- ghc command line, except that certain options aren't available (-C,
462 -- This is pretty fragile: most options won't work as expected. ToDo:
463 -- figure out which ones & disallow them.
465 setOptions :: String -> GHCi ()
467 = do st <- getGHCiState
468 let opts = options st
469 io $ putStrLn (showSDoc (
470 text "options currently set: " <>
473 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
476 = do -- first, deal with the GHCi opts (+s, +t, etc.)
478 (minus_opts, rest1) = partition isMinus opts
479 (plus_opts, rest2) = partition isPlus rest1
481 if (not (null rest2))
482 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
485 mapM setOpt plus_opts
487 -- now, the GHC flags
488 io (do -- first, static flags
489 leftovers <- processArgs static_flags minus_opts []
491 -- then, dynamic flags
492 dyn_flags <- readIORef v_InitDynFlags
493 writeIORef v_DynFlags dyn_flags
494 leftovers <- processArgs dynamic_flags leftovers []
495 dyn_flags <- readIORef v_DynFlags
496 writeIORef v_InitDynFlags dyn_flags
498 if (not (null leftovers))
499 then throwDyn (OtherError ("unrecognised flags: " ++
504 unsetOptions :: String -> GHCi ()
506 = do -- first, deal with the GHCi opts (+s, +t, etc.)
508 (minus_opts, rest1) = partition isMinus opts
509 (plus_opts, rest2) = partition isPlus rest1
511 if (not (null rest2))
512 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
515 mapM unsetOpt plus_opts
517 -- can't do GHC flags for now
518 if (not (null minus_opts))
519 then throwDyn (OtherError "can't unset GHC command-line flags")
522 isMinus ('-':s) = True
525 isPlus ('+':s) = True
529 = case strToGHCiOpt str of
530 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
531 Just o -> setOption o
534 = case strToGHCiOpt str of
535 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
536 Just o -> unsetOption o
538 strToGHCiOpt :: String -> (Maybe GHCiOption)
539 strToGHCiOpt "s" = Just ShowTiming
540 strToGHCiOpt "t" = Just ShowType
541 strToGHCiOpt "r" = Just RevertCAFs
542 strToGHCiOpt _ = Nothing
544 optToStr :: GHCiOption -> String
545 optToStr ShowTiming = "s"
546 optToStr ShowType = "t"
547 optToStr RevertCAFs = "r"
549 -----------------------------------------------------------------------------
550 -- Code to do last-expression-entered stuff. (a.k.a the $$ facility)
552 -- Take a string and replace $$s in it with the last expr, if any.
553 expandExpr :: String -> GHCi String
555 = do mle <- getLastExpr
556 return (outside mle str)
558 outside mle ('$':'$':cs)
560 Just le -> " (" ++ le ++ ") " ++ outside mle cs
561 Nothing -> outside mle cs
564 outside mle ('"':str) = '"' : inside2 mle str -- "
565 outside mle ('\'':str) = '\'' : inside1 mle str -- '
566 outside mle (c:cs) = c : outside mle cs
568 inside2 mle ('"':cs) = '"' : outside mle cs -- "
569 inside2 mle (c:cs) = c : inside2 mle cs
572 inside1 mle ('\'':cs) = '\'': outside mle cs
573 inside1 mle (c:cs) = c : inside1 mle cs
577 rememberExpr :: String -> GHCi ()
579 = do let cleaned = (clean . reverse . clean . reverse) str
580 let forget_me_not | null cleaned = Nothing
581 | otherwise = Just cleaned
582 setLastExpr forget_me_not
584 clean = dropWhile isSpace
587 -----------------------------------------------------------------------------
590 data GHCiState = GHCiState
593 current_module :: Module,
594 target :: Maybe FilePath,
596 options :: [GHCiOption],
597 last_expr :: Maybe String
601 = ShowTiming -- show time/allocs after evaluation
602 | ShowType -- show the type of expressions
603 | RevertCAFs -- revert CAFs after every evaluation
606 defaultCurrentModuleName = mkModuleName "Prelude"
607 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
609 GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
610 GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
612 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
614 instance Monad GHCi where
615 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
616 return a = GHCi $ \s -> return (s,a)
618 getGHCiState = GHCi $ \s -> return (s,s)
619 setGHCiState s = GHCi $ \_ -> return (s,())
621 isOptionSet :: GHCiOption -> GHCi Bool
623 = do st <- getGHCiState
624 return (opt `elem` options st)
626 setOption :: GHCiOption -> GHCi ()
628 = do st <- getGHCiState
629 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
631 unsetOption :: GHCiOption -> GHCi ()
633 = do st <- getGHCiState
634 setGHCiState (st{ options = filter (/= opt) (options st) })
636 getLastExpr :: GHCi (Maybe String)
638 = do st <- getGHCiState ; return (last_expr st)
640 setLastExpr :: Maybe String -> GHCi ()
641 setLastExpr last_expr
642 = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
644 io m = GHCi $ \s -> m >>= \a -> return (s,a)
646 -----------------------------------------------------------------------------
647 -- recursive exception handlers
649 -- Don't forget to unblock async exceptions in the handler, or if we're
650 -- in an exception loop (eg. let a = error a in a) the ^C exception
651 -- may never be delivered. Thanks to Marcin for pointing out the bug.
653 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
654 ghciHandle h (GHCi m) = GHCi $ \s ->
655 Exception.catch (m s)
656 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
658 ghciUnblock :: GHCi a -> GHCi a
659 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
661 -----------------------------------------------------------------------------
664 linkPackages :: [Package] -> IO ()
665 linkPackages pkgs = mapM_ linkPackage pkgs
667 linkPackage :: Package -> IO ()
668 -- ignore rts and gmp for now (ToDo; better?)
669 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
671 putStr ("Loading package " ++ name pkg ++ " ... ")
672 let dirs = library_dirs pkg
673 let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
674 mapM (linkOneObj dirs) objs
675 putStr "resolving ... "
679 linkOneObj dirs obj = do
680 filename <- findFile dirs obj
683 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
684 findFile (d:ds) obj = do
685 let path = d ++ '/':obj
686 b <- doesFileExist path
687 if b then return path else findFile ds obj
689 -----------------------------------------------------------------------------
690 -- timing & statistics
692 timeIt :: GHCi a -> GHCi a
694 = do b <- isOptionSet ShowTiming
697 else do allocs1 <- io $ getAllocations
698 time1 <- io $ getCPUTime
700 allocs2 <- io $ getAllocations
701 time2 <- io $ getCPUTime
702 io $ printTimes (allocs2 - allocs1) (time2 - time1)
705 foreign import "getAllocations" getAllocations :: IO Int
707 printTimes :: Int -> Integer -> IO ()
708 printTimes allocs psecs
709 = do let secs = (fromIntegral psecs / (10^12)) :: Float
710 secs_str = showFFloat (Just 2) secs
712 parens (text (secs_str "") <+> text "secs" <> comma <+>
713 int allocs <+> text "bytes")))
715 -----------------------------------------------------------------------------
718 foreign import revertCAFs :: IO () -- make it "safe", just in case