1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.54 2001/03/12 14:06:46 simonpj 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"
25 import Panic ( GhcException(..) )
44 import PrelGHC ( unsafeCoerce# )
45 import Foreign ( nullPtr )
46 import CString ( peekCString )
48 -----------------------------------------------------------------------------
52 \ / _ \\ /\\ /\\/ __(_)\n\
53 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", For Haskell 98.\n\
54 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
55 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
57 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
59 builtin_commands :: [(String, String -> GHCi Bool)]
61 ("add", keepGoing addModule),
62 ("cd", keepGoing changeDirectory),
63 ("def", keepGoing defineMacro),
64 ("help", keepGoing help),
65 ("?", keepGoing help),
66 ("load", keepGoing loadModule),
67 ("module", keepGoing setContext),
68 ("reload", keepGoing reloadModule),
69 ("set", keepGoing setOptions),
70 ("type", keepGoing typeOfExpr),
71 ("unset", keepGoing unsetOptions),
72 ("undef", keepGoing undefineMacro),
76 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
77 keepGoing a str = a str >> return False
79 shortHelpText = "use :? for help.\n"
82 \ Commands available from the prompt:\n\
84 \ <stmt> evaluate/run <stmt>\n\
85 \ :add <filename> add a module to the current set\n\
86 \ :cd <dir> change directory to <dir>\n\
87 \ :help, :? display this list of commands\n\
88 \ :load <filename> load a module (and it dependents)\n\
89 \ :module <mod> set the context for expression evaluation to <mod>\n\
90 \ :reload reload the current module set\n\
91 \ :set <option> ... set options\n\
92 \ :unset <option> ... unset options\n\
93 \ :type <expr> show the type of <expr>\n\
95 \ :!<command> run the shell command <command>\n\
97 \ Options for `:set' and `:unset':\n\
99 \ +s print timing/memory stats after each evaluation\n\
100 \ +t print type after evaluation\n\
101 \ +r revert top-level expressions after each evaluation\n\
102 \ -<flags> most GHC command line flags can also be set here\n\
103 \ (eg. -v2, -fglasgow-exts, etc.)\n\
106 interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO ()
107 interactiveUI cmstate mod cmdline_libs = do
109 hSetBuffering stdout NoBuffering
111 -- link in the available packages
112 pkgs <- getPackageInfo
114 linkPackages cmdline_libs (reverse pkgs)
116 (cmstate, ok, mods) <-
118 Nothing -> return (cmstate, True, [])
119 Just m -> cmLoadModule cmstate m
125 dflags <- getDynFlags
127 (cmstate, maybe_hval)
128 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
130 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
131 _ -> panic "interactiveUI:stderr"
133 (cmstate, maybe_hval)
134 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
136 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
137 _ -> panic "interactiveUI:stdout"
139 (unGHCi runGHCi) GHCiState{ target = mod,
141 options = [ShowTiming] }
148 dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
151 Right hdl -> fileLoop hdl False
154 home <- io (IO.try (getEnv "HOME"))
158 dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
161 Right hdl -> fileLoop hdl False
163 -- read commands from stdin
171 io $ do putStrLn "Leaving GHCi."
174 fileLoop :: Handle -> Bool -> GHCi ()
175 fileLoop hdl prompt = do
177 mod <- io (cmGetContext (cmstate st))
178 when prompt (io (hPutStr hdl (mod ++ "> ")))
179 l <- io (IO.try (hGetLine hdl))
181 Left e | isEOFError e -> return ()
182 | otherwise -> throw e
184 case remove_spaces l of
185 "" -> fileLoop hdl prompt
186 l -> do quit <- runCommand l
187 if quit then return () else fileLoop hdl prompt
189 stringLoop :: [String] -> GHCi ()
190 stringLoop [] = return ()
191 stringLoop (s:ss) = do
193 case remove_spaces s of
195 l -> do quit <- runCommand l
196 if quit then return () else stringLoop ss
199 readlineLoop :: GHCi ()
202 mod <- io (cmGetContext (cmstate st))
203 l <- io (readline (mod ++ "> "))
207 case remove_spaces l of
212 if quit then return () else readlineLoop
215 -- Top level exception handler, just prints out the exception
217 runCommand :: String -> GHCi Bool
219 ghciHandle ( \exception ->
222 case fromDynamic dyn of
223 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
226 PhaseFailed phase code ->
227 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
228 ++ show code ++ ")"))
229 Interrupted -> io (putStrLn "Interrupted.")
230 other -> io (putStrLn (show (ghc_ex :: GhcException)))
232 other -> io (putStrLn ("*** Exception: " ++ show exception))
239 doCommand (':' : command) = specialCommand command
240 doCommand ('-':'-':_) = return False -- comments, useful in scripts
242 = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
245 -- Returns True if the expr was successfully parsed, renamed and
247 runStmt :: String -> GHCi (Maybe [Name])
249 | null (filter (not.isSpace) stmt)
252 = do st <- getGHCiState
253 dflags <- io (getDynFlags)
254 (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags stmt)
255 setGHCiState st{cmstate = new_cmstate}
258 -- possibly print the type and revert CAFs after evaluating an expression
259 finishEvalExpr Nothing = return False
260 finishEvalExpr (Just names)
261 = do b <- isOptionSet ShowType
263 when b (mapM_ (showTypeOfName (cmstate st)) names)
265 b <- isOptionSet RevertCAFs
266 io (when b revertCAFs)
270 showTypeOfName :: CmState -> Name -> GHCi ()
271 showTypeOfName cmstate n
272 = do maybe_str <- io (cmTypeOfName cmstate n)
275 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
277 flushEverything :: GHCi ()
279 = io $ do flush_so <- readIORef flush_stdout
281 flush_se <- readIORef flush_stdout
285 specialCommand :: String -> GHCi Bool
286 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
287 specialCommand str = do
288 let (cmd,rest) = break isSpace str
289 cmds <- io (readIORef commands)
290 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
291 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
292 ++ shortHelpText) >> return False)
293 [(_,f)] -> f (dropWhile isSpace rest)
294 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
295 " matches multiple commands (" ++
296 foldr1 (\a b -> a ++ ',':b) (map fst cs)
297 ++ ")") >> return False)
299 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
301 -----------------------------------------------------------------------------
304 help :: String -> GHCi ()
305 help _ = io (putStr helpText)
307 addModule :: String -> GHCi ()
308 addModule _ = throwDyn (OtherError ":add not implemented")
310 setContext :: String -> GHCi ()
312 = throwDyn (OtherError "syntax: `:m <module>'")
313 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
314 = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
316 = do st <- getGHCiState
317 new_cmstate <- io (cmSetContext (cmstate st) str)
318 setGHCiState st{cmstate=new_cmstate}
320 changeDirectory :: String -> GHCi ()
321 changeDirectory d = io (setCurrentDirectory d)
323 defineMacro :: String -> GHCi ()
325 let (macro_name, definition) = break isSpace s
326 cmds <- io (readIORef commands)
328 then throwDyn (OtherError "invalid macro name")
330 if (macro_name `elem` map fst cmds)
331 then throwDyn (OtherError
332 ("command `" ++ macro_name ++ "' is already defined"))
335 -- give the expression a type signature, so we can be sure we're getting
336 -- something of the right type.
337 let new_expr = '(' : definition ++ ") :: String -> IO String"
339 -- compile the expression
341 dflags <- io (getDynFlags)
342 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
343 setGHCiState st{cmstate = new_cmstate}
347 do funs <- io (unsafeCoerce# hv :: IO [HValue])
349 [fun] -> io (writeIORef commands
350 ((macro_name, keepGoing (runMacro fun))
352 _ -> throwDyn (OtherError "defineMacro: bizarre")
354 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
356 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
357 stringLoop (lines str)
359 undefineMacro :: String -> GHCi ()
360 undefineMacro macro_name = do
361 cmds <- io (readIORef commands)
362 if (macro_name `elem` map fst builtin_commands)
363 then throwDyn (OtherError
364 ("command `" ++ macro_name ++ "' cannot be undefined"))
366 if (macro_name `notElem` map fst cmds)
367 then throwDyn (OtherError
368 ("command `" ++ macro_name ++ "' not defined"))
370 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
372 loadModule :: String -> GHCi ()
373 loadModule path = timeIt (loadModule' path)
375 loadModule' path = do
376 state <- getGHCiState
377 cmstate1 <- io (cmUnload (cmstate state))
378 io (revertCAFs) -- always revert CAFs on load.
379 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
380 let new_state = state{ cmstate = cmstate2,
383 setGHCiState new_state
384 modulesLoadedMsg ok mods
386 reloadModule :: String -> GHCi ()
388 state <- getGHCiState
390 Nothing -> io (putStr "no current target\n")
392 -> do io (revertCAFs) -- always revert CAFs on reload.
393 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
394 setGHCiState state{ cmstate=new_cmstate }
395 modulesLoadedMsg ok mods
397 reloadModule _ = noArgs ":reload"
400 modulesLoadedMsg ok mods = do
402 | null mods = text "none."
404 punctuate comma (map text mods)) <> text "."
407 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
409 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
412 typeOfExpr :: String -> GHCi ()
414 = do st <- getGHCiState
415 dflags <- io (getDynFlags)
416 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
417 setGHCiState st{cmstate = new_cmstate}
420 Just tystr -> io (putStrLn tystr)
422 quit :: String -> GHCi Bool
425 shellEscape :: String -> GHCi Bool
426 shellEscape str = io (system str >> return False)
428 ----------------------------------------------------------------------------
431 -- set options in the interpreter. Syntax is exactly the same as the
432 -- ghc command line, except that certain options aren't available (-C,
435 -- This is pretty fragile: most options won't work as expected. ToDo:
436 -- figure out which ones & disallow them.
438 setOptions :: String -> GHCi ()
440 = do st <- getGHCiState
441 let opts = options st
442 io $ putStrLn (showSDoc (
443 text "options currently set: " <>
446 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
449 = do -- first, deal with the GHCi opts (+s, +t, etc.)
451 (minus_opts, rest1) = partition isMinus opts
452 (plus_opts, rest2) = partition isPlus rest1
454 if (not (null rest2))
455 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
458 mapM setOpt plus_opts
460 -- now, the GHC flags
461 io (do -- first, static flags
462 leftovers <- processArgs static_flags minus_opts []
464 -- then, dynamic flags
465 dyn_flags <- readIORef v_InitDynFlags
466 writeIORef v_DynFlags dyn_flags
467 leftovers <- processArgs dynamic_flags leftovers []
468 dyn_flags <- readIORef v_DynFlags
469 writeIORef v_InitDynFlags dyn_flags
471 if (not (null leftovers))
472 then throwDyn (OtherError ("unrecognised flags: " ++
477 unsetOptions :: String -> GHCi ()
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 unsetOpt plus_opts
490 -- can't do GHC flags for now
491 if (not (null minus_opts))
492 then throwDyn (OtherError "can't unset GHC command-line flags")
495 isMinus ('-':s) = True
498 isPlus ('+':s) = True
502 = case strToGHCiOpt str of
503 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
504 Just o -> setOption o
507 = case strToGHCiOpt str of
508 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
509 Just o -> unsetOption o
511 strToGHCiOpt :: String -> (Maybe GHCiOption)
512 strToGHCiOpt "s" = Just ShowTiming
513 strToGHCiOpt "t" = Just ShowType
514 strToGHCiOpt "r" = Just RevertCAFs
515 strToGHCiOpt _ = Nothing
517 optToStr :: GHCiOption -> String
518 optToStr ShowTiming = "s"
519 optToStr ShowType = "t"
520 optToStr RevertCAFs = "r"
522 -----------------------------------------------------------------------------
525 data GHCiState = GHCiState
527 target :: Maybe FilePath,
529 options :: [GHCiOption]
533 = ShowTiming -- show time/allocs after evaluation
534 | ShowType -- show the type of expressions
535 | RevertCAFs -- revert CAFs after every evaluation
538 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
539 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
541 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
543 instance Monad GHCi where
544 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
545 return a = GHCi $ \s -> return (s,a)
547 getGHCiState = GHCi $ \s -> return (s,s)
548 setGHCiState s = GHCi $ \_ -> return (s,())
550 isOptionSet :: GHCiOption -> GHCi Bool
552 = do st <- getGHCiState
553 return (opt `elem` options st)
555 setOption :: GHCiOption -> GHCi ()
557 = do st <- getGHCiState
558 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
560 unsetOption :: GHCiOption -> GHCi ()
562 = do st <- getGHCiState
563 setGHCiState (st{ options = filter (/= opt) (options st) })
565 io m = GHCi $ \s -> m >>= \a -> return (s,a)
567 -----------------------------------------------------------------------------
568 -- recursive exception handlers
570 -- Don't forget to unblock async exceptions in the handler, or if we're
571 -- in an exception loop (eg. let a = error a in a) the ^C exception
572 -- may never be delivered. Thanks to Marcin for pointing out the bug.
574 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
575 ghciHandle h (GHCi m) = GHCi $ \s ->
576 Exception.catch (m s)
577 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
579 ghciUnblock :: GHCi a -> GHCi a
580 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
582 -----------------------------------------------------------------------------
585 -- Left: full path name of a .o file, including trailing .o
586 -- Right: "unadorned" name of a .DLL/.so
587 -- e.g. On unix "qt" denotes "libqt.so"
588 -- On WinDoze "burble" denotes "burble.DLL"
589 -- addDLL is platform-specific and adds the lib/.so/.DLL
590 -- prefixes plaform-dependently; we don't do that here.
592 = Either FilePath String
594 showLS (Left nm) = "(static) " ++ nm
595 showLS (Right nm) = "(dynamic) " ++ nm
597 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
598 linkPackages cmdline_lib_specs pkgs
599 = do mapM_ linkPackage pkgs
600 mapM_ preloadLib cmdline_lib_specs
603 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
606 -> do b <- doesFileExist static_ish
608 then do putStr "not found.\n"
610 else do loadObj static_ish
613 -> do maybe_errmsg <- addDLL dll_unadorned
614 if maybe_errmsg == nullPtr
615 then putStr "done.\n"
616 else do str <- peekCString maybe_errmsg
617 putStr ("failed (" ++ str ++ ")\n")
620 croak = throwDyn (OtherError "user specified .o/.so/.DLL could not be loaded.")
623 linkPackage :: PackageConfig -> IO ()
624 -- ignore rts and gmp for now (ToDo; better?)
626 | name pkg `elem` ["rts", "gmp"]
629 = do putStr ("Loading package " ++ name pkg ++ " ... ")
630 -- For each obj, try obj.o and if that fails, obj.so.
631 -- Complication: all the .so's must be loaded before any of the .o's.
632 let dirs = library_dirs pkg
633 let objs = hs_libraries pkg ++ extra_libraries pkg
634 classifieds <- mapM (locateOneObj dirs) objs
635 let sos_first = filter isRight classifieds
636 ++ filter (not.isRight) classifieds
637 mapM loadClassified sos_first
638 putStr "linking ... "
642 isRight (Right _) = True
643 isRight (Left _) = False
645 loadClassified :: LibrarySpec -> IO ()
646 loadClassified (Left obj_absolute_filename)
647 = do loadObj obj_absolute_filename
648 loadClassified (Right dll_unadorned)
649 = do maybe_errmsg <- addDLL dll_unadorned
650 if maybe_errmsg == nullPtr
652 else do str <- peekCString maybe_errmsg
653 throwDyn (OtherError ("can't find .o or .so/.DLL for: "
654 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
656 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
658 = return (Right obj) -- we assume
659 locateOneObj (d:ds) obj
660 = do let path = d ++ '/':obj ++ ".o"
661 b <- doesFileExist path
662 if b then return (Left path) else locateOneObj ds obj
664 -----------------------------------------------------------------------------
665 -- timing & statistics
667 timeIt :: GHCi a -> GHCi a
669 = do b <- isOptionSet ShowTiming
672 else do allocs1 <- io $ getAllocations
673 time1 <- io $ getCPUTime
675 allocs2 <- io $ getAllocations
676 time2 <- io $ getCPUTime
677 io $ printTimes (allocs2 - allocs1) (time2 - time1)
680 foreign import "getAllocations" getAllocations :: IO Int
682 printTimes :: Int -> Integer -> IO ()
683 printTimes allocs psecs
684 = do let secs = (fromIntegral psecs / (10^12)) :: Float
685 secs_str = showFFloat (Just 2) secs
687 parens (text (secs_str "") <+> text "secs" <> comma <+>
688 int allocs <+> text "bytes")))
690 -----------------------------------------------------------------------------
693 foreign import revertCAFs :: IO () -- make it "safe", just in case