1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.60 2001/03/28 16:51:03 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 CmdLineOpts ( DynFlag(..), dopt_unset )
26 import Panic ( GhcException(..) )
45 import PrelGHC ( unsafeCoerce# )
46 import Foreign ( nullPtr )
47 import CString ( peekCString )
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 \ <stmt> evaluate/run <stmt>\n\
86 \ :cd <dir> change directory to <dir>\n\
87 \ :def <cmd> <expr> define a command :<cmd>\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 \ :undef <name> undefine user-defined command :<name>\n\
94 \ :type <expr> show the type of <expr>\n\
95 \ :unset <option> ... unset options\n\
97 \ :!<command> run the shell command <command>\n\
99 \ Options for `:set' and `:unset':\n\
101 \ +r revert top-level expressions after each evaluation\n\
102 \ +s print timing/memory stats after each evaluation\n\
103 \ +t print type after evaluation\n\
104 \ -<flags> most GHC command line flags can also be set here\n\
105 \ (eg. -v2, -fglasgow-exts, etc.)\n\
107 --ToDo :add <filename> add a module to the current set\n\
109 interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO ()
110 interactiveUI cmstate mod cmdline_libs = do
112 hSetBuffering stdout NoBuffering
114 -- link in the available packages
115 pkgs <- getPackageInfo
117 linkPackages cmdline_libs (reverse pkgs)
119 (cmstate, ok, mods) <-
121 Nothing -> return (cmstate, True, [])
122 Just m -> cmLoadModule cmstate m
128 dflags <- getDynFlags
130 (cmstate, maybe_hval)
131 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
133 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
134 _ -> panic "interactiveUI:stderr"
136 (cmstate, maybe_hval)
137 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
139 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
140 _ -> panic "interactiveUI:stdout"
142 (unGHCi runGHCi) GHCiState{ target = mod,
144 options = [ShowTiming] }
151 dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
154 Right hdl -> fileLoop hdl False
157 home <- io (IO.try (getEnv "HOME"))
161 cwd <- io (getCurrentDirectory)
162 when (dir /= cwd) $ do
163 dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
166 Right hdl -> fileLoop hdl False
168 -- read commands from stdin
176 io $ do putStrLn "Leaving GHCi."
179 fileLoop :: Handle -> Bool -> GHCi ()
180 fileLoop hdl prompt = do
182 mod <- io (cmGetContext (cmstate st))
183 when prompt (io (hPutStr hdl (mod ++ "> ")))
184 l <- io (IO.try (hGetLine hdl))
186 Left e | isEOFError e -> return ()
187 | otherwise -> throw e
189 case remove_spaces l of
190 "" -> fileLoop hdl prompt
191 l -> do quit <- runCommand l
192 if quit then return () else fileLoop hdl prompt
194 stringLoop :: [String] -> GHCi ()
195 stringLoop [] = return ()
196 stringLoop (s:ss) = do
198 case remove_spaces s of
200 l -> do quit <- runCommand l
201 if quit then return () else stringLoop ss
204 readlineLoop :: GHCi ()
207 mod <- io (cmGetContext (cmstate st))
208 l <- io (readline (mod ++ "> "))
212 case remove_spaces l of
217 if quit then return () else readlineLoop
220 -- Top level exception handler, just prints out the exception
222 runCommand :: String -> GHCi Bool
224 ghciHandle ( \exception ->
227 case fromDynamic dyn of
228 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
231 PhaseFailed phase code ->
232 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
233 ++ show code ++ ")"))
234 Interrupted -> io (putStrLn "Interrupted.")
235 -- omit the location for CmdLineError
236 CmdLineError s -> io (putStrLn s)
237 other -> io (putStrLn (show (ghc_ex :: GhcException)))
239 other -> io (putStrLn ("*** Exception: " ++ show exception))
246 doCommand (':' : command) = specialCommand command
248 = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
251 -- Returns True if the expr was successfully parsed, renamed and
253 runStmt :: String -> GHCi (Maybe [Name])
255 | null (filter (not.isSpace) stmt)
258 = do st <- getGHCiState
259 dflags <- io (getDynFlags)
260 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
261 (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
262 setGHCiState st{cmstate = new_cmstate}
265 -- possibly print the type and revert CAFs after evaluating an expression
266 finishEvalExpr Nothing = return False
267 finishEvalExpr (Just names)
268 = do b <- isOptionSet ShowType
270 when b (mapM_ (showTypeOfName (cmstate st)) names)
272 b <- isOptionSet RevertCAFs
273 io (when b revertCAFs)
277 showTypeOfName :: CmState -> Name -> GHCi ()
278 showTypeOfName cmstate n
279 = do maybe_str <- io (cmTypeOfName cmstate n)
282 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
284 flushEverything :: GHCi ()
286 = io $ do flush_so <- readIORef flush_stdout
288 flush_se <- readIORef flush_stdout
292 specialCommand :: String -> GHCi Bool
293 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
294 specialCommand str = do
295 let (cmd,rest) = break isSpace str
296 cmds <- io (readIORef commands)
297 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
298 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
299 ++ shortHelpText) >> return False)
300 [(_,f)] -> f (dropWhile isSpace rest)
301 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
302 " matches multiple commands (" ++
303 foldr1 (\a b -> a ++ ',':b) (map fst cs)
304 ++ ")") >> return False)
306 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
308 -----------------------------------------------------------------------------
311 help :: String -> GHCi ()
312 help _ = io (putStr helpText)
314 addModule :: String -> GHCi ()
315 addModule _ = throwDyn (InstallationError ":add not implemented")
317 setContext :: String -> GHCi ()
319 = throwDyn (CmdLineError "syntax: `:m <module>'")
320 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
321 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
323 = do st <- getGHCiState
324 new_cmstate <- io (cmSetContext (cmstate st) str)
325 setGHCiState st{cmstate=new_cmstate}
327 changeDirectory :: String -> GHCi ()
328 changeDirectory ('~':d) = do
329 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
330 io (setCurrentDirectory (tilde ++ '/':d))
331 changeDirectory d = io (setCurrentDirectory d)
333 defineMacro :: String -> GHCi ()
335 let (macro_name, definition) = break isSpace s
336 cmds <- io (readIORef commands)
338 then throwDyn (CmdLineError "invalid macro name")
340 if (macro_name `elem` map fst cmds)
341 then throwDyn (CmdLineError
342 ("command `" ++ macro_name ++ "' is already defined"))
345 -- give the expression a type signature, so we can be sure we're getting
346 -- something of the right type.
347 let new_expr = '(' : definition ++ ") :: String -> IO String"
349 -- compile the expression
351 dflags <- io (getDynFlags)
352 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
353 setGHCiState st{cmstate = new_cmstate}
356 Just hv -> io (writeIORef commands --
357 ((macro_name, keepGoing (runMacro hv)) : cmds))
359 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
361 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
362 stringLoop (lines str)
364 undefineMacro :: String -> GHCi ()
365 undefineMacro macro_name = do
366 cmds <- io (readIORef commands)
367 if (macro_name `elem` map fst builtin_commands)
368 then throwDyn (CmdLineError
369 ("command `" ++ macro_name ++ "' cannot be undefined"))
371 if (macro_name `notElem` map fst cmds)
372 then throwDyn (CmdLineError
373 ("command `" ++ macro_name ++ "' not defined"))
375 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
377 loadModule :: String -> GHCi ()
378 loadModule path = timeIt (loadModule' path)
380 loadModule' path = do
381 state <- getGHCiState
382 cmstate1 <- io (cmUnload (cmstate state))
383 io (revertCAFs) -- always revert CAFs on load.
384 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
385 let new_state = state{ cmstate = cmstate2,
388 setGHCiState new_state
389 modulesLoadedMsg ok mods
391 reloadModule :: String -> GHCi ()
393 state <- getGHCiState
395 Nothing -> io (putStr "no current target\n")
397 -> do io (revertCAFs) -- always revert CAFs on reload.
398 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
399 setGHCiState state{ cmstate=new_cmstate }
400 modulesLoadedMsg ok mods
402 reloadModule _ = noArgs ":reload"
405 modulesLoadedMsg ok mods = do
407 | null mods = text "none."
409 punctuate comma (map text mods)) <> text "."
412 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
414 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
417 typeOfExpr :: String -> GHCi ()
419 = do st <- getGHCiState
420 dflags <- io (getDynFlags)
421 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
422 setGHCiState st{cmstate = new_cmstate}
425 Just tystr -> io (putStrLn tystr)
427 quit :: String -> GHCi Bool
430 shellEscape :: String -> GHCi Bool
431 shellEscape str = io (system str >> return False)
433 ----------------------------------------------------------------------------
436 -- set options in the interpreter. Syntax is exactly the same as the
437 -- ghc command line, except that certain options aren't available (-C,
440 -- This is pretty fragile: most options won't work as expected. ToDo:
441 -- figure out which ones & disallow them.
443 setOptions :: String -> GHCi ()
445 = do st <- getGHCiState
446 let opts = options st
447 io $ putStrLn (showSDoc (
448 text "options currently set: " <>
451 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
454 = do -- first, deal with the GHCi opts (+s, +t, etc.)
456 (minus_opts, rest1) = partition isMinus opts
457 (plus_opts, rest2) = partition isPlus rest1
459 if (not (null rest2))
460 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
463 mapM setOpt plus_opts
465 -- now, the GHC flags
466 io (do -- first, static flags
467 leftovers <- processArgs static_flags minus_opts []
469 -- then, dynamic flags
470 dyn_flags <- readIORef v_InitDynFlags
471 writeIORef v_DynFlags dyn_flags
472 leftovers <- processArgs dynamic_flags leftovers []
473 dyn_flags <- readIORef v_DynFlags
474 writeIORef v_InitDynFlags dyn_flags
476 if (not (null leftovers))
477 then throwDyn (CmdLineError ("unrecognised flags: " ++
482 unsetOptions :: String -> GHCi ()
484 = do -- first, deal with the GHCi opts (+s, +t, etc.)
486 (minus_opts, rest1) = partition isMinus opts
487 (plus_opts, rest2) = partition isPlus rest1
489 if (not (null rest2))
490 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
493 mapM unsetOpt plus_opts
495 -- can't do GHC flags for now
496 if (not (null minus_opts))
497 then throwDyn (CmdLineError "can't unset GHC command-line flags")
500 isMinus ('-':s) = True
503 isPlus ('+':s) = True
507 = case strToGHCiOpt str of
508 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
509 Just o -> setOption o
512 = case strToGHCiOpt str of
513 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
514 Just o -> unsetOption o
516 strToGHCiOpt :: String -> (Maybe GHCiOption)
517 strToGHCiOpt "s" = Just ShowTiming
518 strToGHCiOpt "t" = Just ShowType
519 strToGHCiOpt "r" = Just RevertCAFs
520 strToGHCiOpt _ = Nothing
522 optToStr :: GHCiOption -> String
523 optToStr ShowTiming = "s"
524 optToStr ShowType = "t"
525 optToStr RevertCAFs = "r"
527 -----------------------------------------------------------------------------
530 data GHCiState = GHCiState
532 target :: Maybe FilePath,
534 options :: [GHCiOption]
538 = ShowTiming -- show time/allocs after evaluation
539 | ShowType -- show the type of expressions
540 | RevertCAFs -- revert CAFs after every evaluation
543 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
544 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
546 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
548 instance Monad GHCi where
549 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
550 return a = GHCi $ \s -> return (s,a)
552 getGHCiState = GHCi $ \s -> return (s,s)
553 setGHCiState s = GHCi $ \_ -> return (s,())
555 isOptionSet :: GHCiOption -> GHCi Bool
557 = do st <- getGHCiState
558 return (opt `elem` options st)
560 setOption :: GHCiOption -> GHCi ()
562 = do st <- getGHCiState
563 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
565 unsetOption :: GHCiOption -> GHCi ()
567 = do st <- getGHCiState
568 setGHCiState (st{ options = filter (/= opt) (options st) })
570 io m = GHCi $ \s -> m >>= \a -> return (s,a)
572 -----------------------------------------------------------------------------
573 -- recursive exception handlers
575 -- Don't forget to unblock async exceptions in the handler, or if we're
576 -- in an exception loop (eg. let a = error a in a) the ^C exception
577 -- may never be delivered. Thanks to Marcin for pointing out the bug.
579 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
580 ghciHandle h (GHCi m) = GHCi $ \s ->
581 Exception.catch (m s)
582 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
584 ghciUnblock :: GHCi a -> GHCi a
585 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
587 -----------------------------------------------------------------------------
590 -- Left: full path name of a .o file, including trailing .o
591 -- Right: "unadorned" name of a .DLL/.so
592 -- e.g. On unix "qt" denotes "libqt.so"
593 -- On WinDoze "burble" denotes "burble.DLL"
594 -- addDLL is platform-specific and adds the lib/.so/.DLL
595 -- prefixes plaform-dependently; we don't do that here.
597 = Either FilePath String
599 showLS (Left nm) = "(static) " ++ nm
600 showLS (Right nm) = "(dynamic) " ++ nm
602 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
603 linkPackages cmdline_lib_specs pkgs
604 = do mapM_ linkPackage pkgs
605 mapM_ preloadLib cmdline_lib_specs
608 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
611 -> do b <- doesFileExist static_ish
613 then do putStr "not found.\n"
615 else do loadObj static_ish
618 -> do maybe_errmsg <- addDLL dll_unadorned
619 if maybe_errmsg == nullPtr
620 then putStr "done.\n"
621 else do str <- peekCString maybe_errmsg
622 putStr ("failed (" ++ str ++ ")\n")
625 croak = throwDyn (CmdLineError "user specified .o/.so/.DLL could not be loaded.")
628 linkPackage :: PackageConfig -> IO ()
629 -- ignore rts and gmp for now (ToDo; better?)
631 | name pkg `elem` ["rts", "gmp"]
634 = do putStr ("Loading package " ++ name pkg ++ " ... ")
635 -- For each obj, try obj.o and if that fails, obj.so.
636 -- Complication: all the .so's must be loaded before any of the .o's.
637 let dirs = library_dirs pkg
638 let objs = hs_libraries pkg ++ extra_libraries pkg
639 classifieds <- mapM (locateOneObj dirs) objs
640 let sos_first = filter isRight classifieds
641 ++ filter (not.isRight) classifieds
642 mapM loadClassified sos_first
643 putStr "linking ... "
647 isRight (Right _) = True
648 isRight (Left _) = False
650 loadClassified :: LibrarySpec -> IO ()
651 loadClassified (Left obj_absolute_filename)
652 = do loadObj obj_absolute_filename
653 loadClassified (Right dll_unadorned)
654 = do maybe_errmsg <- addDLL dll_unadorned
655 if maybe_errmsg == nullPtr
657 else do str <- peekCString maybe_errmsg
658 throwDyn (CmdLineError ("can't find .o or .so/.DLL for: "
659 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
661 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
663 = return (Right obj) -- we assume
664 locateOneObj (d:ds) obj
665 = do let path = d ++ '/':obj ++ ".o"
666 b <- doesFileExist path
667 if b then return (Left path) else locateOneObj ds obj
669 -----------------------------------------------------------------------------
670 -- timing & statistics
672 timeIt :: GHCi a -> GHCi a
674 = do b <- isOptionSet ShowTiming
677 else do allocs1 <- io $ getAllocations
678 time1 <- io $ getCPUTime
680 allocs2 <- io $ getAllocations
681 time2 <- io $ getCPUTime
682 io $ printTimes (allocs2 - allocs1) (time2 - time1)
685 foreign import "getAllocations" getAllocations :: IO Int
687 printTimes :: Int -> Integer -> IO ()
688 printTimes allocs psecs
689 = do let secs = (fromIntegral psecs / (10^12)) :: Float
690 secs_str = showFFloat (Just 2) secs
692 parens (text (secs_str "") <+> text "secs" <> comma <+>
693 int allocs <+> text "bytes")))
695 -----------------------------------------------------------------------------
698 foreign import revertCAFs :: IO () -- make it "safe", just in case