1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.45 2001/02/13 13:09:36 sewardj 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# )
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 -> IO ()
111 interactiveUI cmstate mod = do
112 hPutStrLn stdout ghciWelcomeMsg
114 hSetBuffering stdout NoBuffering
116 -- link in the available packages
117 pkgs <- getPackageInfo
119 linkPackages (reverse pkgs)
121 (cmstate, ok, mods) <-
123 Nothing -> return (cmstate, True, [])
124 Just m -> cmLoadModule cmstate m
130 prel <- moduleNameToModule defaultCurrentModuleName
131 writeIORef defaultCurrentModule prel
133 dflags <- getDynFlags
135 (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
136 "PrelHandle.hFlush PrelHandle.stdout"
139 Just (hv,_,_) -> writeIORef flush_stdout hv
141 (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
142 "PrelHandle.hFlush PrelHandle.stdout"
145 Just (hv,_,_) -> writeIORef flush_stderr hv
147 let this_mod = case mods of
151 (unGHCi runGHCi) GHCiState{ modules = mods,
152 current_module = this_mod,
155 options = [ShowTiming],
163 dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
166 Right hdl -> fileLoop hdl False
169 home <- io (IO.try (getEnv "HOME"))
173 dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
176 Right hdl -> fileLoop hdl False
178 -- read commands from stdin
186 io $ do putStrLn "Leaving GHCi."
189 fileLoop :: Handle -> Bool -> GHCi ()
190 fileLoop hdl prompt = do
192 when prompt (io (hPutStr hdl (moduleUserString (current_module st) ++ "> ")))
193 l <- io (IO.try (hGetLine hdl))
195 Left e | isEOFError e -> return ()
196 | otherwise -> throw e
198 case remove_spaces l of
199 "" -> fileLoop hdl prompt
200 l -> do quit <- runCommand l
201 if quit then return () else fileLoop hdl prompt
203 stringLoop :: [String] -> GHCi ()
204 stringLoop [] = return ()
205 stringLoop (s:ss) = do
207 case remove_spaces s of
209 l -> do quit <- runCommand l
210 if quit then return () else stringLoop ss
213 readlineLoop :: GHCi ()
216 l <- io (readline (moduleUserString (current_module st) ++ "> "))
220 case remove_spaces l of
225 if quit then return () else readlineLoop
228 -- Top level exception handler, just prints out the exception
230 runCommand :: String -> GHCi Bool
232 ghciHandle ( \exception ->
235 case fromDynamic dyn of
236 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
239 PhaseFailed phase code ->
240 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
241 ++ show code ++ ")"))
242 Interrupted -> io (putStrLn "Interrupted.")
243 other -> io (putStrLn (show (ghc_ex :: GhcException)))
245 other -> io (putStrLn ("*** Exception: " ++ show exception))
252 doCommand (':' : command) = specialCommand command
253 doCommand ('-':'-':_) = return False -- comments, useful in scripts
255 = do expr_expanded <- expandExpr expr
256 -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter: " ++ expr_expanded))
257 expr_ok <- timeIt (do stuff <- evalExpr expr_expanded
258 finishEvalExpr stuff)
259 when expr_ok (rememberExpr expr_expanded)
262 -- possibly print the type and revert CAFs after evaluating an expression
263 finishEvalExpr Nothing = return False
264 finishEvalExpr (Just (unqual,ty))
265 = do b <- isOptionSet ShowType
266 io (when b (printForUser stdout unqual (text "::" <+> ppr ty)))
267 b <- isOptionSet RevertCAFs
268 io (when b revertCAFs)
271 -- Returned Maybe indicates whether or not the expr was successfully
272 -- parsed, renamed and typechecked.
273 evalExpr :: String -> GHCi (Maybe (PrintUnqualified,Type))
275 | null (filter (not.isSpace) expr)
278 = do st <- getGHCiState
279 dflags <- io (getDynFlags)
280 (new_cmstate, maybe_stuff) <-
281 io (cmGetExpr (cmstate st) dflags True (current_module st) expr)
282 setGHCiState st{cmstate = new_cmstate}
284 Nothing -> return Nothing
285 Just (hv, unqual, ty) -> do io (cmRunExpr hv)
287 return (Just (unqual,ty))
289 flushEverything :: GHCi ()
291 = io $ do flush_so <- readIORef flush_stdout
293 flush_se <- readIORef flush_stdout
296 specialCommand :: String -> GHCi Bool
297 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
298 specialCommand str = do
299 let (cmd,rest) = break isSpace str
300 cmds <- io (readIORef commands)
301 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
302 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
303 ++ shortHelpText) >> return False)
304 [(_,f)] -> f (dropWhile isSpace rest)
305 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
306 " matches multiple commands (" ++
307 foldr1 (\a b -> a ++ ',':b) (map fst cs)
308 ++ ")") >> return False)
310 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
312 -----------------------------------------------------------------------------
315 help :: String -> GHCi ()
316 help _ = io (putStr helpText)
318 addModule :: String -> GHCi ()
319 addModule _ = throwDyn (OtherError ":add not implemented")
321 setContext :: String -> GHCi ()
323 = throwDyn (OtherError "syntax: `:m <module>'")
324 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
325 = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
327 = do m <- io (moduleNameToModule (mkModuleName mn))
329 if (isHomeModule m && m `notElem` modules st)
330 then throwDyn (OtherError (showSDoc (quotes (ppr (moduleName m))
331 <+> text "is not currently loaded, use :load")))
332 else setGHCiState st{current_module = m}
334 moduleNameToModule :: ModuleName -> IO Module
335 moduleNameToModule mn
336 = do maybe_stuff <- findModule mn
338 Nothing -> throwDyn (OtherError ("can't find module `"
339 ++ moduleNameUserString mn ++ "'"))
340 Just (m,_) -> return m
342 changeDirectory :: String -> GHCi ()
343 changeDirectory d = io (setCurrentDirectory d)
345 defineMacro :: String -> GHCi ()
347 let (macro_name, definition) = break isSpace s
348 cmds <- io (readIORef commands)
350 then throwDyn (OtherError "invalid macro name")
352 if (macro_name `elem` map fst cmds)
353 then throwDyn (OtherError
354 ("command `" ++ macro_name ++ "' already defined"))
357 -- give the expression a type signature, so we can be sure we're getting
358 -- something of the right type.
359 let new_expr = '(' : definition ++ ") :: String -> IO String"
361 -- compile the expression
363 dflags <- io (getDynFlags)
364 (new_cmstate, maybe_stuff) <-
365 io (cmGetExpr (cmstate st) dflags False (current_module st) new_expr)
366 setGHCiState st{cmstate = new_cmstate}
369 Just (hv, unqual, ty)
370 -> io (writeIORef commands
371 ((macro_name, keepGoing (runMacro hv)) : cmds))
373 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
375 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
376 stringLoop (lines str)
378 undefineMacro :: String -> GHCi ()
379 undefineMacro macro_name = do
380 cmds <- io (readIORef commands)
381 if (macro_name `elem` map fst builtin_commands)
382 then throwDyn (OtherError
383 ("command `" ++ macro_name ++ "' cannot be undefined"))
385 if (macro_name `notElem` map fst cmds)
386 then throwDyn (OtherError
387 ("command `" ++ macro_name ++ "' not defined"))
389 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
391 loadModule :: String -> GHCi ()
392 loadModule path = timeIt (loadModule' path)
394 loadModule' path = do
395 state <- getGHCiState
396 cmstate1 <- io (cmUnload (cmstate state))
397 io (revertCAFs) -- always revert CAFs on load.
398 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
400 def_mod <- io (readIORef defaultCurrentModule)
402 let new_state = state{
405 current_module = case mods of
410 setGHCiState new_state
413 | null mods = text "none."
415 punctuate comma (map (text.moduleUserString) mods)) <> text "."
418 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
420 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
422 reloadModule :: String -> GHCi ()
424 state <- getGHCiState
426 Nothing -> io (putStr "no current target\n")
428 -> do io (revertCAFs) -- always revert CAFs on reload.
429 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
430 def_mod <- io (readIORef defaultCurrentModule)
432 state{cmstate=new_cmstate,
434 current_module = case mods of
439 reloadModule _ = noArgs ":reload"
441 typeOfExpr :: String -> GHCi ()
443 = do st <- getGHCiState
444 dflags <- io (getDynFlags)
445 (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False
446 (current_module st) str)
447 setGHCiState st{cmstate = new_cmstate}
450 Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
452 quit :: String -> GHCi Bool
455 shellEscape :: String -> GHCi Bool
456 shellEscape str = io (system str >> return False)
458 ----------------------------------------------------------------------------
461 -- set options in the interpreter. Syntax is exactly the same as the
462 -- ghc command line, except that certain options aren't available (-C,
465 -- This is pretty fragile: most options won't work as expected. ToDo:
466 -- figure out which ones & disallow them.
468 setOptions :: String -> GHCi ()
470 = do st <- getGHCiState
471 let opts = options st
472 io $ putStrLn (showSDoc (
473 text "options currently set: " <>
476 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
479 = do -- first, deal with the GHCi opts (+s, +t, etc.)
481 (minus_opts, rest1) = partition isMinus opts
482 (plus_opts, rest2) = partition isPlus rest1
484 if (not (null rest2))
485 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
488 mapM setOpt plus_opts
490 -- now, the GHC flags
491 io (do -- first, static flags
492 leftovers <- processArgs static_flags minus_opts []
494 -- then, dynamic flags
495 dyn_flags <- readIORef v_InitDynFlags
496 writeIORef v_DynFlags dyn_flags
497 leftovers <- processArgs dynamic_flags leftovers []
498 dyn_flags <- readIORef v_DynFlags
499 writeIORef v_InitDynFlags dyn_flags
501 if (not (null leftovers))
502 then throwDyn (OtherError ("unrecognised flags: " ++
507 unsetOptions :: String -> GHCi ()
509 = do -- first, deal with the GHCi opts (+s, +t, etc.)
511 (minus_opts, rest1) = partition isMinus opts
512 (plus_opts, rest2) = partition isPlus rest1
514 if (not (null rest2))
515 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
518 mapM unsetOpt plus_opts
520 -- can't do GHC flags for now
521 if (not (null minus_opts))
522 then throwDyn (OtherError "can't unset GHC command-line flags")
525 isMinus ('-':s) = True
528 isPlus ('+':s) = True
532 = case strToGHCiOpt str of
533 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
534 Just o -> setOption o
537 = case strToGHCiOpt str of
538 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
539 Just o -> unsetOption o
541 strToGHCiOpt :: String -> (Maybe GHCiOption)
542 strToGHCiOpt "s" = Just ShowTiming
543 strToGHCiOpt "t" = Just ShowType
544 strToGHCiOpt "r" = Just RevertCAFs
545 strToGHCiOpt _ = Nothing
547 optToStr :: GHCiOption -> String
548 optToStr ShowTiming = "s"
549 optToStr ShowType = "t"
550 optToStr RevertCAFs = "r"
552 -----------------------------------------------------------------------------
553 -- Code to do last-expression-entered stuff. (a.k.a the $$ facility)
555 -- Take a string and replace $$s in it with the last expr, if any.
556 expandExpr :: String -> GHCi String
558 = do mle <- getLastExpr
559 return (outside mle str)
561 outside mle ('$':'$':cs)
563 Just le -> " (" ++ le ++ ") " ++ outside mle cs
564 Nothing -> outside mle cs
567 outside mle ('"':str) = '"' : inside2 mle str -- "
568 outside mle ('\'':str) = '\'' : inside1 mle str -- '
569 outside mle (c:cs) = c : outside mle cs
571 inside2 mle ('"':cs) = '"' : outside mle cs -- "
572 inside2 mle (c:cs) = c : inside2 mle cs
575 inside1 mle ('\'':cs) = '\'': outside mle cs
576 inside1 mle (c:cs) = c : inside1 mle cs
580 rememberExpr :: String -> GHCi ()
582 = do let cleaned = (clean . reverse . clean . reverse) str
583 let forget_me_not | null cleaned = Nothing
584 | otherwise = Just cleaned
585 setLastExpr forget_me_not
587 clean = dropWhile isSpace
590 -----------------------------------------------------------------------------
593 data GHCiState = GHCiState
596 current_module :: Module,
597 target :: Maybe FilePath,
599 options :: [GHCiOption],
600 last_expr :: Maybe String
604 = ShowTiming -- show time/allocs after evaluation
605 | ShowType -- show the type of expressions
606 | RevertCAFs -- revert CAFs after every evaluation
609 defaultCurrentModuleName = mkModuleName "Prelude"
610 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
612 GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
613 GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
615 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
617 instance Monad GHCi where
618 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
619 return a = GHCi $ \s -> return (s,a)
621 getGHCiState = GHCi $ \s -> return (s,s)
622 setGHCiState s = GHCi $ \_ -> return (s,())
624 isOptionSet :: GHCiOption -> GHCi Bool
626 = do st <- getGHCiState
627 return (opt `elem` options st)
629 setOption :: GHCiOption -> GHCi ()
631 = do st <- getGHCiState
632 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
634 unsetOption :: GHCiOption -> GHCi ()
636 = do st <- getGHCiState
637 setGHCiState (st{ options = filter (/= opt) (options st) })
639 getLastExpr :: GHCi (Maybe String)
641 = do st <- getGHCiState ; return (last_expr st)
643 setLastExpr :: Maybe String -> GHCi ()
644 setLastExpr last_expr
645 = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
647 io m = GHCi $ \s -> m >>= \a -> return (s,a)
649 -----------------------------------------------------------------------------
650 -- recursive exception handlers
652 -- Don't forget to unblock async exceptions in the handler, or if we're
653 -- in an exception loop (eg. let a = error a in a) the ^C exception
654 -- may never be delivered. Thanks to Marcin for pointing out the bug.
656 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
657 ghciHandle h (GHCi m) = GHCi $ \s ->
658 Exception.catch (m s)
659 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
661 ghciUnblock :: GHCi a -> GHCi a
662 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
664 -----------------------------------------------------------------------------
667 linkPackages :: [Package] -> IO ()
668 linkPackages pkgs = mapM_ linkPackage pkgs
670 linkPackage :: Package -> IO ()
671 -- ignore rts and gmp for now (ToDo; better?)
673 | name pkg `elem` ["rts", "gmp"]
676 = do putStr ("Loading package " ++ name pkg ++ " ... ")
677 -- For each obj, try obj.o and if that fails, obj.so.
678 -- Complication: all the .so's must be loaded before any of the .o's.
679 let dirs = library_dirs pkg
680 let objs = hs_libraries pkg ++ extra_libraries pkg
681 classifieds <- mapM (locateOneObj dirs) objs
682 let sos_first = filter isRight classifieds
683 ++ filter (not.isRight) classifieds
684 mapM loadClassified sos_first
685 putStr "linking ... "
689 isRight (Right _) = True
690 isRight (Left _) = False
693 loadClassified :: Either FilePath String -> IO ()
694 loadClassified (Left obj_absolute_filename)
695 = do --putStr ("Left " ++ obj_absolute_filename ++ "\n")
696 loadObj obj_absolute_filename
697 loadClassified (Right dll_unadorned)
698 = do --putStr ("Right " ++ dll_unadorned ++ "\n")
699 dll_ok <- ocAddDLL (packString dll_unadorned)
701 then throwDyn (OtherError ("can't find .o or .so/.DLL for: "
705 locateOneObj :: [FilePath] -> String -> IO (Either FilePath String)
707 = return (Right obj) -- we assume
708 locateOneObj (d:ds) obj
709 = do let path = d ++ '/':obj ++ ".o"
710 b <- doesFileExist path
711 if b then return (Left path) else locateOneObj ds obj
714 type PackedString = ByteArray Int
715 foreign import "ocAddDLL" unsafe ocAddDLL :: PackedString -> IO Int
717 -----------------------------------------------------------------------------
718 -- timing & statistics
720 timeIt :: GHCi a -> GHCi a
722 = do b <- isOptionSet ShowTiming
725 else do allocs1 <- io $ getAllocations
726 time1 <- io $ getCPUTime
728 allocs2 <- io $ getAllocations
729 time2 <- io $ getCPUTime
730 io $ printTimes (allocs2 - allocs1) (time2 - time1)
733 foreign import "getAllocations" getAllocations :: IO Int
735 printTimes :: Int -> Integer -> IO ()
736 printTimes allocs psecs
737 = do let secs = (fromIntegral psecs / (10^12)) :: Float
738 secs_str = showFFloat (Just 2) secs
740 parens (text (secs_str "") <+> text "secs" <> comma <+>
741 int allocs <+> text "bytes")))
743 -----------------------------------------------------------------------------
746 foreign import revertCAFs :: IO () -- make it "safe", just in case