1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.56 2001/03/23 12:12:18 simonmar 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 \ :cd <dir> change directory to <dir>\n\
86 \ :def <cmd> <expr> define a macro :<cmd>\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 \ :type <expr> show the type of <expr>\n\
93 \ :unset <option> ... unset options\n\
95 \ :!<command> run the shell command <command>\n\
97 \ Options for `:set' and `:unset':\n\
99 \ +r revert top-level expressions after each evaluation\n\
100 \ +s print timing/memory stats after each evaluation\n\
101 \ +t print type after evaluation\n\
102 \ -<flags> most GHC command line flags can also be set here\n\
103 \ (eg. -v2, -fglasgow-exts, etc.)\n\
105 --ToDo :add <filename> add a module to the current set\n\
107 interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO ()
108 interactiveUI cmstate mod cmdline_libs = do
110 hSetBuffering stdout NoBuffering
112 -- link in the available packages
113 pkgs <- getPackageInfo
115 linkPackages cmdline_libs (reverse pkgs)
117 (cmstate, ok, mods) <-
119 Nothing -> return (cmstate, True, [])
120 Just m -> cmLoadModule cmstate m
126 dflags <- getDynFlags
128 (cmstate, maybe_hval)
129 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
131 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
132 _ -> panic "interactiveUI:stderr"
134 (cmstate, maybe_hval)
135 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
137 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
138 _ -> panic "interactiveUI:stdout"
140 (unGHCi runGHCi) GHCiState{ target = mod,
142 options = [ShowTiming] }
149 dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
152 Right hdl -> fileLoop hdl False
155 home <- io (IO.try (getEnv "HOME"))
159 dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
162 Right hdl -> fileLoop hdl False
164 -- read commands from stdin
172 io $ do putStrLn "Leaving GHCi."
175 fileLoop :: Handle -> Bool -> GHCi ()
176 fileLoop hdl prompt = do
178 mod <- io (cmGetContext (cmstate st))
179 when prompt (io (hPutStr hdl (mod ++ "> ")))
180 l <- io (IO.try (hGetLine hdl))
182 Left e | isEOFError e -> return ()
183 | otherwise -> throw e
185 case remove_spaces l of
186 "" -> fileLoop hdl prompt
187 l -> do quit <- runCommand l
188 if quit then return () else fileLoop hdl prompt
190 stringLoop :: [String] -> GHCi ()
191 stringLoop [] = return ()
192 stringLoop (s:ss) = do
194 case remove_spaces s of
196 l -> do quit <- runCommand l
197 if quit then return () else stringLoop ss
200 readlineLoop :: GHCi ()
203 mod <- io (cmGetContext (cmstate st))
204 l <- io (readline (mod ++ "> "))
208 case remove_spaces l of
213 if quit then return () else readlineLoop
216 -- Top level exception handler, just prints out the exception
218 runCommand :: String -> GHCi Bool
220 ghciHandle ( \exception ->
223 case fromDynamic dyn of
224 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
227 PhaseFailed phase code ->
228 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
229 ++ show code ++ ")"))
230 Interrupted -> io (putStrLn "Interrupted.")
231 other -> io (putStrLn (show (ghc_ex :: GhcException)))
233 other -> io (putStrLn ("*** Exception: " ++ show exception))
240 doCommand (':' : command) = specialCommand command
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) = do
322 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
323 io (setCurrentDirectory (tilde ++ '/':d))
324 changeDirectory d = io (setCurrentDirectory d)
326 defineMacro :: String -> GHCi ()
328 let (macro_name, definition) = break isSpace s
329 cmds <- io (readIORef commands)
331 then throwDyn (OtherError "invalid macro name")
333 if (macro_name `elem` map fst cmds)
334 then throwDyn (OtherError
335 ("command `" ++ macro_name ++ "' is already defined"))
338 -- give the expression a type signature, so we can be sure we're getting
339 -- something of the right type.
340 let new_expr = '(' : definition ++ ") :: String -> IO String"
342 -- compile the expression
344 dflags <- io (getDynFlags)
345 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
346 setGHCiState st{cmstate = new_cmstate}
349 Just hv -> io (writeIORef commands --
350 ((macro_name, keepGoing (runMacro hv)) : cmds))
352 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
354 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
355 stringLoop (lines str)
357 undefineMacro :: String -> GHCi ()
358 undefineMacro macro_name = do
359 cmds <- io (readIORef commands)
360 if (macro_name `elem` map fst builtin_commands)
361 then throwDyn (OtherError
362 ("command `" ++ macro_name ++ "' cannot be undefined"))
364 if (macro_name `notElem` map fst cmds)
365 then throwDyn (OtherError
366 ("command `" ++ macro_name ++ "' not defined"))
368 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
370 loadModule :: String -> GHCi ()
371 loadModule path = timeIt (loadModule' path)
373 loadModule' path = do
374 state <- getGHCiState
375 cmstate1 <- io (cmUnload (cmstate state))
376 io (revertCAFs) -- always revert CAFs on load.
377 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
378 let new_state = state{ cmstate = cmstate2,
381 setGHCiState new_state
382 modulesLoadedMsg ok mods
384 reloadModule :: String -> GHCi ()
386 state <- getGHCiState
388 Nothing -> io (putStr "no current target\n")
390 -> do io (revertCAFs) -- always revert CAFs on reload.
391 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
392 setGHCiState state{ cmstate=new_cmstate }
393 modulesLoadedMsg ok mods
395 reloadModule _ = noArgs ":reload"
398 modulesLoadedMsg ok mods = do
400 | null mods = text "none."
402 punctuate comma (map text mods)) <> text "."
405 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
407 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
410 typeOfExpr :: String -> GHCi ()
412 = do st <- getGHCiState
413 dflags <- io (getDynFlags)
414 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
415 setGHCiState st{cmstate = new_cmstate}
418 Just tystr -> io (putStrLn tystr)
420 quit :: String -> GHCi Bool
423 shellEscape :: String -> GHCi Bool
424 shellEscape str = io (system str >> return False)
426 ----------------------------------------------------------------------------
429 -- set options in the interpreter. Syntax is exactly the same as the
430 -- ghc command line, except that certain options aren't available (-C,
433 -- This is pretty fragile: most options won't work as expected. ToDo:
434 -- figure out which ones & disallow them.
436 setOptions :: String -> GHCi ()
438 = do st <- getGHCiState
439 let opts = options st
440 io $ putStrLn (showSDoc (
441 text "options currently set: " <>
444 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
447 = do -- first, deal with the GHCi opts (+s, +t, etc.)
449 (minus_opts, rest1) = partition isMinus opts
450 (plus_opts, rest2) = partition isPlus rest1
452 if (not (null rest2))
453 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
456 mapM setOpt plus_opts
458 -- now, the GHC flags
459 io (do -- first, static flags
460 leftovers <- processArgs static_flags minus_opts []
462 -- then, dynamic flags
463 dyn_flags <- readIORef v_InitDynFlags
464 writeIORef v_DynFlags dyn_flags
465 leftovers <- processArgs dynamic_flags leftovers []
466 dyn_flags <- readIORef v_DynFlags
467 writeIORef v_InitDynFlags dyn_flags
469 if (not (null leftovers))
470 then throwDyn (OtherError ("unrecognised flags: " ++
475 unsetOptions :: String -> GHCi ()
477 = do -- first, deal with the GHCi opts (+s, +t, etc.)
479 (minus_opts, rest1) = partition isMinus opts
480 (plus_opts, rest2) = partition isPlus rest1
482 if (not (null rest2))
483 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
486 mapM unsetOpt plus_opts
488 -- can't do GHC flags for now
489 if (not (null minus_opts))
490 then throwDyn (OtherError "can't unset GHC command-line flags")
493 isMinus ('-':s) = True
496 isPlus ('+':s) = True
500 = case strToGHCiOpt str of
501 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
502 Just o -> setOption o
505 = case strToGHCiOpt str of
506 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
507 Just o -> unsetOption o
509 strToGHCiOpt :: String -> (Maybe GHCiOption)
510 strToGHCiOpt "s" = Just ShowTiming
511 strToGHCiOpt "t" = Just ShowType
512 strToGHCiOpt "r" = Just RevertCAFs
513 strToGHCiOpt _ = Nothing
515 optToStr :: GHCiOption -> String
516 optToStr ShowTiming = "s"
517 optToStr ShowType = "t"
518 optToStr RevertCAFs = "r"
520 -----------------------------------------------------------------------------
523 data GHCiState = GHCiState
525 target :: Maybe FilePath,
527 options :: [GHCiOption]
531 = ShowTiming -- show time/allocs after evaluation
532 | ShowType -- show the type of expressions
533 | RevertCAFs -- revert CAFs after every evaluation
536 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
537 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
539 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
541 instance Monad GHCi where
542 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
543 return a = GHCi $ \s -> return (s,a)
545 getGHCiState = GHCi $ \s -> return (s,s)
546 setGHCiState s = GHCi $ \_ -> return (s,())
548 isOptionSet :: GHCiOption -> GHCi Bool
550 = do st <- getGHCiState
551 return (opt `elem` options st)
553 setOption :: GHCiOption -> GHCi ()
555 = do st <- getGHCiState
556 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
558 unsetOption :: GHCiOption -> GHCi ()
560 = do st <- getGHCiState
561 setGHCiState (st{ options = filter (/= opt) (options st) })
563 io m = GHCi $ \s -> m >>= \a -> return (s,a)
565 -----------------------------------------------------------------------------
566 -- recursive exception handlers
568 -- Don't forget to unblock async exceptions in the handler, or if we're
569 -- in an exception loop (eg. let a = error a in a) the ^C exception
570 -- may never be delivered. Thanks to Marcin for pointing out the bug.
572 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
573 ghciHandle h (GHCi m) = GHCi $ \s ->
574 Exception.catch (m s)
575 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
577 ghciUnblock :: GHCi a -> GHCi a
578 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
580 -----------------------------------------------------------------------------
583 -- Left: full path name of a .o file, including trailing .o
584 -- Right: "unadorned" name of a .DLL/.so
585 -- e.g. On unix "qt" denotes "libqt.so"
586 -- On WinDoze "burble" denotes "burble.DLL"
587 -- addDLL is platform-specific and adds the lib/.so/.DLL
588 -- prefixes plaform-dependently; we don't do that here.
590 = Either FilePath String
592 showLS (Left nm) = "(static) " ++ nm
593 showLS (Right nm) = "(dynamic) " ++ nm
595 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
596 linkPackages cmdline_lib_specs pkgs
597 = do mapM_ linkPackage pkgs
598 mapM_ preloadLib cmdline_lib_specs
601 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
604 -> do b <- doesFileExist static_ish
606 then do putStr "not found.\n"
608 else do loadObj static_ish
611 -> do maybe_errmsg <- addDLL dll_unadorned
612 if maybe_errmsg == nullPtr
613 then putStr "done.\n"
614 else do str <- peekCString maybe_errmsg
615 putStr ("failed (" ++ str ++ ")\n")
618 croak = throwDyn (OtherError "user specified .o/.so/.DLL could not be loaded.")
621 linkPackage :: PackageConfig -> IO ()
622 -- ignore rts and gmp for now (ToDo; better?)
624 | name pkg `elem` ["rts", "gmp"]
627 = do putStr ("Loading package " ++ name pkg ++ " ... ")
628 -- For each obj, try obj.o and if that fails, obj.so.
629 -- Complication: all the .so's must be loaded before any of the .o's.
630 let dirs = library_dirs pkg
631 let objs = hs_libraries pkg ++ extra_libraries pkg
632 classifieds <- mapM (locateOneObj dirs) objs
633 let sos_first = filter isRight classifieds
634 ++ filter (not.isRight) classifieds
635 mapM loadClassified sos_first
636 putStr "linking ... "
640 isRight (Right _) = True
641 isRight (Left _) = False
643 loadClassified :: LibrarySpec -> IO ()
644 loadClassified (Left obj_absolute_filename)
645 = do loadObj obj_absolute_filename
646 loadClassified (Right dll_unadorned)
647 = do maybe_errmsg <- addDLL dll_unadorned
648 if maybe_errmsg == nullPtr
650 else do str <- peekCString maybe_errmsg
651 throwDyn (OtherError ("can't find .o or .so/.DLL for: "
652 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
654 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
656 = return (Right obj) -- we assume
657 locateOneObj (d:ds) obj
658 = do let path = d ++ '/':obj ++ ".o"
659 b <- doesFileExist path
660 if b then return (Left path) else locateOneObj ds obj
662 -----------------------------------------------------------------------------
663 -- timing & statistics
665 timeIt :: GHCi a -> GHCi a
667 = do b <- isOptionSet ShowTiming
670 else do allocs1 <- io $ getAllocations
671 time1 <- io $ getCPUTime
673 allocs2 <- io $ getAllocations
674 time2 <- io $ getCPUTime
675 io $ printTimes (allocs2 - allocs1) (time2 - time1)
678 foreign import "getAllocations" getAllocations :: IO Int
680 printTimes :: Int -> Integer -> IO ()
681 printTimes allocs psecs
682 = do let secs = (fromIntegral psecs / (10^12)) :: Float
683 secs_str = showFFloat (Just 2) secs
685 parens (text (secs_str "") <+> text "secs" <> comma <+>
686 int allocs <+> text "bytes")))
688 -----------------------------------------------------------------------------
691 foreign import revertCAFs :: IO () -- make it "safe", just in case