1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.49 2001/02/13 18:37:53 qrczak Exp $
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2000
8 -----------------------------------------------------------------------------
10 {-# OPTIONS -#include "Linker.h" #-}
11 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
13 #include "HsVersions.h"
27 import PprType {- instance Outputable Type; do not delete -}
28 import Panic ( GhcException(..) )
47 import PrelGHC ( unsafeCoerce# )
48 import PrelPack ( packString )
50 import Foreign ( Ptr, nullPtr )
52 -----------------------------------------------------------------------------
56 \ / _ \\ /\\ /\\/ __(_)\n\
57 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", For Haskell 98.\n\
58 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
59 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
61 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
63 builtin_commands :: [(String, String -> GHCi Bool)]
65 ("add", keepGoing addModule),
66 ("cd", keepGoing changeDirectory),
67 ("def", keepGoing defineMacro),
68 ("help", keepGoing help),
69 ("?", keepGoing help),
70 ("load", keepGoing loadModule),
71 ("module", keepGoing setContext),
72 ("reload", keepGoing reloadModule),
73 ("set", keepGoing setOptions),
74 ("type", keepGoing typeOfExpr),
75 ("unset", keepGoing unsetOptions),
76 ("undef", keepGoing undefineMacro),
80 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
81 keepGoing a str = a str >> return False
83 shortHelpText = "use :? for help.\n"
86 \ Commands available from the prompt:\n\
88 \ <expr> evaluate <expr>\n\
89 \ :add <filename> add a module to the current set\n\
90 \ :cd <dir> change directory to <dir>\n\
91 \ :help, :? display this list of commands\n\
92 \ :load <filename> load a module (and it dependents)\n\
93 \ :module <mod> set the context for expression evaluation to <mod>\n\
94 \ :reload reload the current module set\n\
95 \ :set <option> ... set options\n\
96 \ :unset <option> ... unset options\n\
97 \ :type <expr> show the type of <expr>\n\
99 \ :!<command> run the shell command <command>\n\
101 \ Options for `:set' and `:unset':\n\
103 \ +s print timing/memory stats after each evaluation\n\
104 \ +t print type after evaluation\n\
105 \ +r revert top-level expressions after each evaluation\n\
106 \ -<flags> most GHC command line flags can also be set here\n\
107 \ (eg. -v2, -fglasgow-exts, etc.)\n\
110 interactiveUI :: CmState -> Maybe FilePath -> [String] -> IO ()
111 interactiveUI cmstate mod cmdline_libs = do
113 hSetBuffering stdout NoBuffering
115 -- link in the available packages
116 pkgs <- getPackageInfo
118 linkPackages cmdline_libs (reverse pkgs)
120 (cmstate, ok, mods) <-
122 Nothing -> return (cmstate, True, [])
123 Just m -> cmLoadModule cmstate m
129 prel <- moduleNameToModule defaultCurrentModuleName
130 writeIORef defaultCurrentModule prel
132 dflags <- getDynFlags
134 (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
135 "PrelHandle.hFlush PrelHandle.stdout"
138 Just (hv,_,_) -> writeIORef flush_stdout hv
140 (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
141 "PrelHandle.hFlush PrelHandle.stdout"
144 Just (hv,_,_) -> writeIORef flush_stderr hv
146 let this_mod = case mods of
150 (unGHCi runGHCi) GHCiState{ modules = mods,
151 current_module = this_mod,
154 options = [ShowTiming],
162 dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
165 Right hdl -> fileLoop hdl False
168 home <- io (IO.try (getEnv "HOME"))
172 dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
175 Right hdl -> fileLoop hdl False
177 -- read commands from stdin
185 io $ do putStrLn "Leaving GHCi."
188 fileLoop :: Handle -> Bool -> GHCi ()
189 fileLoop hdl prompt = do
191 when prompt (io (hPutStr hdl (moduleUserString (current_module st) ++ "> ")))
192 l <- io (IO.try (hGetLine hdl))
194 Left e | isEOFError e -> return ()
195 | otherwise -> throw e
197 case remove_spaces l of
198 "" -> fileLoop hdl prompt
199 l -> do quit <- runCommand l
200 if quit then return () else fileLoop hdl prompt
202 stringLoop :: [String] -> GHCi ()
203 stringLoop [] = return ()
204 stringLoop (s:ss) = do
206 case remove_spaces s of
208 l -> do quit <- runCommand l
209 if quit then return () else stringLoop ss
212 readlineLoop :: GHCi ()
215 l <- io (readline (moduleUserString (current_module st) ++ "> "))
219 case remove_spaces l of
224 if quit then return () else readlineLoop
227 -- Top level exception handler, just prints out the exception
229 runCommand :: String -> GHCi Bool
231 ghciHandle ( \exception ->
234 case fromDynamic dyn of
235 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
238 PhaseFailed phase code ->
239 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
240 ++ show code ++ ")"))
241 Interrupted -> io (putStrLn "Interrupted.")
242 other -> io (putStrLn (show (ghc_ex :: GhcException)))
244 other -> io (putStrLn ("*** Exception: " ++ show exception))
251 doCommand (':' : command) = specialCommand command
252 doCommand ('-':'-':_) = return False -- comments, useful in scripts
254 = do expr_expanded <- expandExpr expr
255 -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter: " ++ expr_expanded))
256 expr_ok <- timeIt (do stuff <- evalExpr expr_expanded
257 finishEvalExpr expr_expanded stuff)
258 when expr_ok (rememberExpr expr_expanded)
261 -- Returns True if the expr was successfully parsed, renamed and
263 evalExpr :: String -> GHCi Bool
265 | null (filter (not.isSpace) expr)
268 = do st <- getGHCiState
269 dflags <- io (getDynFlags)
270 (new_cmstate, maybe_stuff) <-
271 io (cmGetExpr (cmstate st) dflags True (current_module st) expr)
272 setGHCiState st{cmstate = new_cmstate}
274 Nothing -> return False
275 Just (hv, unqual, ty) ->
279 -- possibly print the type and revert CAFs after evaluating an expression
280 finishEvalExpr _ False = return False
281 finishEvalExpr expr True
282 = do b <- isOptionSet ShowType
283 -- re-typecheck, don't wrap with print this time
284 when b (io (putStr ":: ") >> typeOfExpr expr)
285 b <- isOptionSet RevertCAFs
286 io (when b revertCAFs)
290 flushEverything :: GHCi ()
292 = io $ do flush_so <- readIORef flush_stdout
294 flush_se <- readIORef flush_stdout
297 specialCommand :: String -> GHCi Bool
298 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
299 specialCommand str = do
300 let (cmd,rest) = break isSpace str
301 cmds <- io (readIORef commands)
302 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
303 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
304 ++ shortHelpText) >> return False)
305 [(_,f)] -> f (dropWhile isSpace rest)
306 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
307 " matches multiple commands (" ++
308 foldr1 (\a b -> a ++ ',':b) (map fst cs)
309 ++ ")") >> return False)
311 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
313 -----------------------------------------------------------------------------
316 help :: String -> GHCi ()
317 help _ = io (putStr helpText)
319 addModule :: String -> GHCi ()
320 addModule _ = throwDyn (OtherError ":add not implemented")
322 setContext :: String -> GHCi ()
324 = throwDyn (OtherError "syntax: `:m <module>'")
325 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
326 = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
328 = do st <- getGHCiState
330 let mn = mkModuleName str
331 m <- case [ m | m <- modules st, moduleName m == mn ] of
333 [] -> io (moduleNameToModule mn)
335 if (isHomeModule m && m `notElem` modules st)
336 then throwDyn (OtherError (showSDoc (quotes (ppr (moduleName m))
337 <+> text "is not currently loaded, use :load")))
338 else setGHCiState st{current_module = m}
340 moduleNameToModule :: ModuleName -> IO Module
341 moduleNameToModule mn
342 = do maybe_stuff <- findModule mn
344 Nothing -> throwDyn (OtherError ("can't find module `"
345 ++ moduleNameUserString mn ++ "'"))
346 Just (m,_) -> return m
348 changeDirectory :: String -> GHCi ()
349 changeDirectory d = io (setCurrentDirectory d)
351 defineMacro :: String -> GHCi ()
353 let (macro_name, definition) = break isSpace s
354 cmds <- io (readIORef commands)
356 then throwDyn (OtherError "invalid macro name")
358 if (macro_name `elem` map fst cmds)
359 then throwDyn (OtherError
360 ("command `" ++ macro_name ++ "' already defined"))
363 -- give the expression a type signature, so we can be sure we're getting
364 -- something of the right type.
365 let new_expr = '(' : definition ++ ") :: String -> IO String"
367 -- compile the expression
369 dflags <- io (getDynFlags)
370 (new_cmstate, maybe_stuff) <-
371 io (cmGetExpr (cmstate st) dflags False (current_module st) new_expr)
372 setGHCiState st{cmstate = new_cmstate}
375 Just (hv, unqual, ty)
376 -> io (writeIORef commands
377 ((macro_name, keepGoing (runMacro hv)) : cmds))
379 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
381 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
382 stringLoop (lines str)
384 undefineMacro :: String -> GHCi ()
385 undefineMacro macro_name = do
386 cmds <- io (readIORef commands)
387 if (macro_name `elem` map fst builtin_commands)
388 then throwDyn (OtherError
389 ("command `" ++ macro_name ++ "' cannot be undefined"))
391 if (macro_name `notElem` map fst cmds)
392 then throwDyn (OtherError
393 ("command `" ++ macro_name ++ "' not defined"))
395 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
397 loadModule :: String -> GHCi ()
398 loadModule path = timeIt (loadModule' path)
400 loadModule' path = do
401 state <- getGHCiState
402 cmstate1 <- io (cmUnload (cmstate state))
403 io (revertCAFs) -- always revert CAFs on load.
404 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
406 def_mod <- io (readIORef defaultCurrentModule)
408 let new_state = state{
411 current_module = case mods of
416 setGHCiState new_state
419 | null mods = text "none."
421 punctuate comma (map (text.moduleUserString) mods)) <> text "."
424 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
426 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
428 reloadModule :: String -> GHCi ()
430 state <- getGHCiState
432 Nothing -> io (putStr "no current target\n")
434 -> do io (revertCAFs) -- always revert CAFs on reload.
435 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
436 def_mod <- io (readIORef defaultCurrentModule)
438 state{cmstate=new_cmstate,
440 current_module = case mods of
445 reloadModule _ = noArgs ":reload"
447 typeOfExpr :: String -> GHCi ()
449 = do st <- getGHCiState
450 dflags <- io (getDynFlags)
451 (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False
452 (current_module st) str)
453 setGHCiState st{cmstate = new_cmstate}
456 Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
458 quit :: String -> GHCi Bool
461 shellEscape :: String -> GHCi Bool
462 shellEscape str = io (system str >> return False)
464 ----------------------------------------------------------------------------
467 -- set options in the interpreter. Syntax is exactly the same as the
468 -- ghc command line, except that certain options aren't available (-C,
471 -- This is pretty fragile: most options won't work as expected. ToDo:
472 -- figure out which ones & disallow them.
474 setOptions :: String -> GHCi ()
476 = do st <- getGHCiState
477 let opts = options st
478 io $ putStrLn (showSDoc (
479 text "options currently set: " <>
482 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
485 = do -- first, deal with the GHCi opts (+s, +t, etc.)
487 (minus_opts, rest1) = partition isMinus opts
488 (plus_opts, rest2) = partition isPlus rest1
490 if (not (null rest2))
491 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
494 mapM setOpt plus_opts
496 -- now, the GHC flags
497 io (do -- first, static flags
498 leftovers <- processArgs static_flags minus_opts []
500 -- then, dynamic flags
501 dyn_flags <- readIORef v_InitDynFlags
502 writeIORef v_DynFlags dyn_flags
503 leftovers <- processArgs dynamic_flags leftovers []
504 dyn_flags <- readIORef v_DynFlags
505 writeIORef v_InitDynFlags dyn_flags
507 if (not (null leftovers))
508 then throwDyn (OtherError ("unrecognised flags: " ++
513 unsetOptions :: String -> GHCi ()
515 = do -- first, deal with the GHCi opts (+s, +t, etc.)
517 (minus_opts, rest1) = partition isMinus opts
518 (plus_opts, rest2) = partition isPlus rest1
520 if (not (null rest2))
521 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
524 mapM unsetOpt plus_opts
526 -- can't do GHC flags for now
527 if (not (null minus_opts))
528 then throwDyn (OtherError "can't unset GHC command-line flags")
531 isMinus ('-':s) = True
534 isPlus ('+':s) = True
538 = case strToGHCiOpt str of
539 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
540 Just o -> setOption o
543 = case strToGHCiOpt str of
544 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
545 Just o -> unsetOption o
547 strToGHCiOpt :: String -> (Maybe GHCiOption)
548 strToGHCiOpt "s" = Just ShowTiming
549 strToGHCiOpt "t" = Just ShowType
550 strToGHCiOpt "r" = Just RevertCAFs
551 strToGHCiOpt _ = Nothing
553 optToStr :: GHCiOption -> String
554 optToStr ShowTiming = "s"
555 optToStr ShowType = "t"
556 optToStr RevertCAFs = "r"
558 -----------------------------------------------------------------------------
559 -- Code to do last-expression-entered stuff. (a.k.a the $$ facility)
561 -- Take a string and replace $$s in it with the last expr, if any.
562 expandExpr :: String -> GHCi String
564 = do mle <- getLastExpr
565 return (outside mle str)
567 outside mle ('$':'$':cs)
569 Just le -> " (" ++ le ++ ") " ++ outside mle cs
570 Nothing -> outside mle cs
573 outside mle ('"':str) = '"' : inside2 mle str -- "
574 outside mle ('\'':str) = '\'' : inside1 mle str -- '
575 outside mle (c:cs) = c : outside mle cs
577 inside2 mle ('"':cs) = '"' : outside mle cs -- "
578 inside2 mle (c:cs) = c : inside2 mle cs
581 inside1 mle ('\'':cs) = '\'': outside mle cs
582 inside1 mle (c:cs) = c : inside1 mle cs
586 rememberExpr :: String -> GHCi ()
588 = do let cleaned = (clean . reverse . clean . reverse) str
589 let forget_me_not | null cleaned = Nothing
590 | otherwise = Just cleaned
591 setLastExpr forget_me_not
593 clean = dropWhile isSpace
596 -----------------------------------------------------------------------------
599 data GHCiState = GHCiState
602 current_module :: Module,
603 target :: Maybe FilePath,
605 options :: [GHCiOption],
606 last_expr :: Maybe String
610 = ShowTiming -- show time/allocs after evaluation
611 | ShowType -- show the type of expressions
612 | RevertCAFs -- revert CAFs after every evaluation
615 defaultCurrentModuleName = mkModuleName "Prelude"
616 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
618 GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
619 GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
621 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
623 instance Monad GHCi where
624 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
625 return a = GHCi $ \s -> return (s,a)
627 getGHCiState = GHCi $ \s -> return (s,s)
628 setGHCiState s = GHCi $ \_ -> return (s,())
630 isOptionSet :: GHCiOption -> GHCi Bool
632 = do st <- getGHCiState
633 return (opt `elem` options st)
635 setOption :: GHCiOption -> GHCi ()
637 = do st <- getGHCiState
638 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
640 unsetOption :: GHCiOption -> GHCi ()
642 = do st <- getGHCiState
643 setGHCiState (st{ options = filter (/= opt) (options st) })
645 getLastExpr :: GHCi (Maybe String)
647 = do st <- getGHCiState ; return (last_expr st)
649 setLastExpr :: Maybe String -> GHCi ()
650 setLastExpr last_expr
651 = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
653 io m = GHCi $ \s -> m >>= \a -> return (s,a)
655 -----------------------------------------------------------------------------
656 -- recursive exception handlers
658 -- Don't forget to unblock async exceptions in the handler, or if we're
659 -- in an exception loop (eg. let a = error a in a) the ^C exception
660 -- may never be delivered. Thanks to Marcin for pointing out the bug.
662 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
663 ghciHandle h (GHCi m) = GHCi $ \s ->
664 Exception.catch (m s)
665 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
667 ghciUnblock :: GHCi a -> GHCi a
668 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
670 -----------------------------------------------------------------------------
673 linkPackages :: [String] -> [Package] -> IO ()
674 linkPackages cmdline_libs pkgs
675 = do mapM preloadLib cmdline_libs
676 mapM_ linkPackage pkgs
679 = do putStr ("Loading object " ++ orig_name ++ " ... ")
680 case classify orig_name of
682 -> do b <- doesFileExist static_ish
684 then do putStr "not found.\n"
686 else do loadObj static_ish
689 -> do dll_ok <- addDLL dll_unadorned
691 then putStr "done.\n"
692 else do putStr "not found.\n"
695 croak = throwDyn (OtherError "user specified .o/.so/.DLL cannot be found.")
698 = let a_libr = reverse a_lib
700 case map toLower a_libr of
704 -> (Right . zap_leading_lib
705 . reverse . drop 3 . reverse) a_lib
707 -> (Right . reverse . drop 4 . reverse) a_lib
709 -> -- Main.beginInteractive should not have let this through
710 pprPanic "linkPackages" (text (show a_lib))
713 = if take 3 str == "lib" then drop 3 str else str
716 linkPackage :: Package -> IO ()
717 -- ignore rts and gmp for now (ToDo; better?)
719 | name pkg `elem` ["rts", "gmp"]
722 = do putStr ("Loading package " ++ name pkg ++ " ... ")
723 -- For each obj, try obj.o and if that fails, obj.so.
724 -- Complication: all the .so's must be loaded before any of the .o's.
725 let dirs = library_dirs pkg
726 let objs = hs_libraries pkg ++ extra_libraries pkg
727 classifieds <- mapM (locateOneObj dirs) objs
728 let sos_first = filter isRight classifieds
729 ++ filter (not.isRight) classifieds
730 mapM loadClassified sos_first
731 putStr "linking ... "
735 isRight (Right _) = True
736 isRight (Left _) = False
738 loadClassified :: Either FilePath String -> IO ()
739 loadClassified (Left obj_absolute_filename)
740 = do loadObj obj_absolute_filename
741 loadClassified (Right dll_unadorned)
742 = do dll_ok <- addDLL dll_unadorned
745 else throwDyn (OtherError ("can't find .o or .so/.DLL for: "
748 locateOneObj :: [FilePath] -> String -> IO (Either FilePath String)
750 = return (Right obj) -- we assume
751 locateOneObj (d:ds) obj
752 = do let path = d ++ '/':obj ++ ".o"
753 b <- doesFileExist path
754 if b then return (Left path) else locateOneObj ds obj
756 -----------------------------------------------------------------------------
757 -- timing & statistics
759 timeIt :: GHCi a -> GHCi a
761 = do b <- isOptionSet ShowTiming
764 else do allocs1 <- io $ getAllocations
765 time1 <- io $ getCPUTime
767 allocs2 <- io $ getAllocations
768 time2 <- io $ getCPUTime
769 io $ printTimes (allocs2 - allocs1) (time2 - time1)
772 foreign import "getAllocations" getAllocations :: IO Int
774 printTimes :: Int -> Integer -> IO ()
775 printTimes allocs psecs
776 = do let secs = (fromIntegral psecs / (10^12)) :: Float
777 secs_str = showFFloat (Just 2) secs
779 parens (text (secs_str "") <+> text "secs" <> comma <+>
780 int allocs <+> text "bytes")))
782 -----------------------------------------------------------------------------
785 foreign import revertCAFs :: IO () -- make it "safe", just in case