1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
18 import GHC ( Session, verbosity, dopt, DynFlag(..),
19 mkModule, pprModule, Type, Module, SuccessFlag(..),
20 TyThing(..), Name, LoadHowMuch(..), Phase,
21 GhcException(..), showGhcException,
25 -- following all needed for :info... ToDo: remove
26 import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
27 IfaceConDecl(..), IfaceType,
28 pprIfaceDeclHead, pprParendIfaceType,
29 pprIfaceForAllPart, pprIfaceType )
30 import FunDeps ( pprFundeps )
31 import SrcLoc ( SrcLoc, pprDefnLoc )
32 import OccName ( OccName, parenSymOcc, occNameUserString )
33 import BasicTypes ( StrictnessMark(..), defaultFixity, failed, successIf )
35 -- Other random utilities
36 import Panic ( panic, installSignalHandlers )
38 import StaticFlags ( opt_IgnoreDotGhci )
39 import Linker ( showLinkerState )
40 import Util ( removeSpaces, handle, global, toArgs,
41 looksLikeModuleName, prefixMatch )
42 import ErrUtils ( printErrorsAndWarnings )
44 #ifndef mingw32_HOST_OS
45 import Util ( handle )
47 #if __GLASGOW_HASKELL__ > 504
51 import GHC.ConsoleHandler ( flushConsole )
55 import Control.Concurrent ( yield ) -- Used in readline loop
56 import System.Console.Readline as Readline
61 import Control.Exception as Exception
63 -- import Control.Concurrent
67 import Data.Int ( Int64 )
68 import Data.Maybe ( isJust )
71 import System.Environment
72 import System.Exit ( exitWith, ExitCode(..) )
73 import System.Directory
75 import System.IO.Error as IO
77 import Control.Monad as Monad
78 import Foreign.StablePtr ( newStablePtr )
80 import GHC.Exts ( unsafeCoerce# )
81 import GHC.IOBase ( IOErrorType(InvalidArgument) )
83 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
85 import System.Posix.Internals ( setNonBlockingFD )
87 -----------------------------------------------------------------------------
91 " / _ \\ /\\ /\\/ __(_)\n"++
92 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
93 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
94 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
96 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
98 builtin_commands :: [(String, String -> GHCi Bool)]
100 ("add", keepGoingPaths addModule),
101 ("browse", keepGoing browseCmd),
102 ("cd", keepGoing changeDirectory),
103 ("def", keepGoing defineMacro),
104 ("help", keepGoing help),
105 ("?", keepGoing help),
106 ("info", keepGoing info),
107 ("load", keepGoingPaths loadModule_),
108 ("module", keepGoing setContext),
109 ("reload", keepGoing reloadModule),
110 ("check", keepGoing checkModule),
111 ("set", keepGoing setCmd),
112 ("show", keepGoing showCmd),
113 ("type", keepGoing typeOfExpr),
114 ("kind", keepGoing kindOfType),
115 ("unset", keepGoing unsetOptions),
116 ("undef", keepGoing undefineMacro),
120 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
121 keepGoing a str = a str >> return False
123 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
124 keepGoingPaths a str = a (toArgs str) >> return False
126 shortHelpText = "use :? for help.\n"
128 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
130 " Commands available from the prompt:\n" ++
132 " <stmt> evaluate/run <stmt>\n" ++
133 " :add <filename> ... add module(s) to the current target set\n" ++
134 " :browse [*]<module> display the names defined by <module>\n" ++
135 " :cd <dir> change directory to <dir>\n" ++
136 " :def <cmd> <expr> define a command :<cmd>\n" ++
137 " :help, :? display this list of commands\n" ++
138 " :info [<name> ...] display information about the given names\n" ++
139 " :load <filename> ... load module(s) and their dependents\n" ++
140 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
141 " :reload reload the current module set\n" ++
143 " :set <option> ... set options\n" ++
144 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
145 " :set prog <progname> set the value returned by System.getProgName\n" ++
147 " :show modules show the currently loaded modules\n" ++
148 " :show bindings show the current bindings made at the prompt\n" ++
150 " :type <expr> show the type of <expr>\n" ++
151 " :kind <type> show the kind of <type>\n" ++
152 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
153 " :unset <option> ... unset options\n" ++
154 " :quit exit GHCi\n" ++
155 " :!<command> run the shell command <command>\n" ++
157 " Options for ':set' and ':unset':\n" ++
159 " +r revert top-level expressions after each evaluation\n" ++
160 " +s print timing/memory stats after each evaluation\n" ++
161 " +t print type after evaluation\n" ++
162 " -<flags> most GHC command line flags can also be set here\n" ++
163 " (eg. -v2, -fglasgow-exts, etc.)\n"
166 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
167 interactiveUI session srcs maybe_expr = do
169 -- HACK! If we happen to get into an infinite loop (eg the user
170 -- types 'let x=x in x' at the prompt), then the thread will block
171 -- on a blackhole, and become unreachable during GC. The GC will
172 -- detect that it is unreachable and send it the NonTermination
173 -- exception. However, since the thread is unreachable, everything
174 -- it refers to might be finalized, including the standard Handles.
175 -- This sounds like a bug, but we don't have a good solution right
182 hSetBuffering stdout NoBuffering
184 -- Initialise buffering for the *interpreted* I/O system
185 initInterpBuffering session
187 -- We don't want the cmd line to buffer any input that might be
188 -- intended for the program, so unbuffer stdin.
189 hSetBuffering stdin NoBuffering
191 -- initial context is just the Prelude
192 GHC.setContext session [] [prelude_mod]
198 #if defined(mingw32_HOST_OS)
199 -- The win32 Console API mutates the first character of
200 -- type-ahead when reading from it in a non-buffered manner. Work
201 -- around this by flushing the input buffer of type-ahead characters.
203 GHC.ConsoleHandler.flushConsole stdin
205 startGHCi (runGHCi srcs maybe_expr)
206 GHCiState{ progname = "<interactive>",
212 Readline.resetTerminal Nothing
217 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
218 runGHCi paths maybe_expr = do
219 let read_dot_files = not opt_IgnoreDotGhci
221 when (read_dot_files) $ do
224 exists <- io (doesFileExist file)
226 dir_ok <- io (checkPerms ".")
227 file_ok <- io (checkPerms file)
228 when (dir_ok && file_ok) $ do
229 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
232 Right hdl -> fileLoop hdl False
234 when (read_dot_files) $ do
235 -- Read in $HOME/.ghci
236 either_dir <- io (IO.try (getEnv "HOME"))
240 cwd <- io (getCurrentDirectory)
241 when (dir /= cwd) $ do
242 let file = dir ++ "/.ghci"
243 ok <- io (checkPerms file)
245 either_hdl <- io (IO.try (openFile file ReadMode))
248 Right hdl -> fileLoop hdl False
250 -- Perform a :load for files given on the GHCi command line
251 -- When in -e mode, if the load fails then we want to stop
252 -- immediately rather than going on to evaluate the expression.
253 when (not (null paths)) $ do
254 ok <- ghciHandle (\e -> do showException e; return Failed) $
256 when (isJust maybe_expr && failed ok) $
257 io (exitWith (ExitFailure 1))
259 -- if verbosity is greater than 0, or we are connected to a
260 -- terminal, display the prompt in the interactive loop.
261 is_tty <- io (hIsTerminalDevice stdin)
262 dflags <- getDynFlags
263 let show_prompt = verbosity dflags > 0 || is_tty
267 -- enter the interactive loop
268 interactiveLoop is_tty show_prompt
270 -- just evaluate the expression we were given
275 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
278 interactiveLoop is_tty show_prompt = do
279 -- Ignore ^C exceptions caught here
280 ghciHandleDyn (\e -> case e of
281 Interrupted -> ghciUnblock (
282 #if defined(mingw32_HOST_OS)
285 interactiveLoop is_tty show_prompt)
286 _other -> return ()) $ do
288 -- read commands from stdin
292 else fileLoop stdin show_prompt
294 fileLoop stdin show_prompt
298 -- NOTE: We only read .ghci files if they are owned by the current user,
299 -- and aren't world writable. Otherwise, we could be accidentally
300 -- running code planted by a malicious third party.
302 -- Furthermore, We only read ./.ghci if . is owned by the current user
303 -- and isn't writable by anyone else. I think this is sufficient: we
304 -- don't need to check .. and ../.. etc. because "." always refers to
305 -- the same directory while a process is running.
307 checkPerms :: String -> IO Bool
309 #ifdef mingw32_HOST_OS
312 Util.handle (\_ -> return False) $ do
313 st <- getFileStatus name
315 if fileOwner st /= me then do
316 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
319 let mode = fileMode st
320 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
321 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
323 putStrLn $ "*** WARNING: " ++ name ++
324 " is writable by someone else, IGNORING!"
329 fileLoop :: Handle -> Bool -> GHCi ()
330 fileLoop hdl prompt = do
331 session <- getSession
332 (mod,imports) <- io (GHC.getContext session)
333 when prompt (io (putStr (mkPrompt mod imports)))
334 l <- io (IO.try (hGetLine hdl))
336 Left e | isEOFError e -> return ()
337 | InvalidArgument <- etype -> return ()
338 | otherwise -> io (ioError e)
339 where etype = ioeGetErrorType e
340 -- treat InvalidArgument in the same way as EOF:
341 -- this can happen if the user closed stdin, or
342 -- perhaps did getContents which closes stdin at
345 case removeSpaces l of
346 "" -> fileLoop hdl prompt
347 l -> do quit <- runCommand l
348 if quit then return () else fileLoop hdl prompt
350 stringLoop :: [String] -> GHCi ()
351 stringLoop [] = return ()
352 stringLoop (s:ss) = do
353 case removeSpaces s of
355 l -> do quit <- runCommand l
356 if quit then return () else stringLoop ss
358 mkPrompt toplevs exports
359 = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
360 <+> hsep (map pprModule exports)
364 readlineLoop :: GHCi ()
366 session <- getSession
367 (mod,imports) <- io (GHC.getContext session)
369 l <- io (readline (mkPrompt mod imports)
370 `finally` setNonBlockingFD 0)
371 -- readline sometimes puts stdin into blocking mode,
372 -- so we need to put it back for the IO library
376 case removeSpaces l of
381 if quit then return () else readlineLoop
384 runCommand :: String -> GHCi Bool
385 runCommand c = ghciHandle handler (doCommand c)
387 -- This version is for the GHC command-line option -e. The only difference
388 -- from runCommand is that it catches the ExitException exception and
389 -- exits, rather than printing out the exception.
390 runCommandEval c = ghciHandle handleEval (doCommand c)
392 handleEval (ExitException code) = io (exitWith code)
393 handleEval e = do showException e
394 io (exitWith (ExitFailure 1))
396 -- This is the exception handler for exceptions generated by the
397 -- user's code; it normally just prints out the exception. The
398 -- handler must be recursive, in case showing the exception causes
399 -- more exceptions to be raised.
401 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
402 -- raising another exception. We therefore don't put the recursive
403 -- handler arond the flushing operation, so if stderr is closed
404 -- GHCi will just die gracefully rather than going into an infinite loop.
405 handler :: Exception -> GHCi Bool
406 handler exception = do
408 io installSignalHandlers
409 ghciHandle handler (showException exception >> return False)
411 showException (DynException dyn) =
412 case fromDynamic dyn of
413 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
414 Just Interrupted -> io (putStrLn "Interrupted.")
415 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
416 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
417 Just other_ghc_ex -> io (print other_ghc_ex)
419 showException other_exception
420 = io (putStrLn ("*** Exception: " ++ show other_exception))
422 doCommand (':' : command) = specialCommand command
424 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
427 runStmt :: String -> GHCi [Name]
429 | null (filter (not.isSpace) stmt) = return []
431 = do st <- getGHCiState
432 session <- getSession
433 result <- io $ withProgName (progname st) $ withArgs (args st) $
434 GHC.runStmt session stmt
436 GHC.RunFailed -> return []
437 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
438 GHC.RunOk names -> return names
440 -- possibly print the type and revert CAFs after evaluating an expression
442 = do b <- isOptionSet ShowType
443 session <- getSession
444 when b (mapM_ (showTypeOfName session) names)
447 io installSignalHandlers
448 b <- isOptionSet RevertCAFs
449 io (when b revertCAFs)
452 showTypeOfName :: Session -> Name -> GHCi ()
453 showTypeOfName session n
454 = do maybe_tything <- io (GHC.lookupName session n)
455 case maybe_tything of
457 Just thing -> showTyThing thing
459 showForUser :: SDoc -> GHCi String
461 session <- getSession
462 unqual <- io (GHC.getPrintUnqual session)
463 return $! showSDocForUser unqual doc
465 specialCommand :: String -> GHCi Bool
466 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
467 specialCommand str = do
468 let (cmd,rest) = break isSpace str
469 cmds <- io (readIORef commands)
470 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
471 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
472 ++ shortHelpText) >> return False)
473 [(_,f)] -> f (dropWhile isSpace rest)
474 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
475 " matches multiple commands (" ++
476 foldr1 (\a b -> a ++ ',':b) (map fst cs)
477 ++ ")") >> return False)
479 noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
482 -----------------------------------------------------------------------------
483 -- To flush buffers for the *interpreted* computation we need
484 -- to refer to *its* stdout/stderr handles
486 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
487 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
489 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
490 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
491 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
493 initInterpBuffering :: Session -> IO ()
494 initInterpBuffering session
495 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
498 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
499 other -> panic "interactiveUI:setBuffering"
501 maybe_hval <- GHC.compileExpr session flush_cmd
503 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
504 _ -> panic "interactiveUI:flush"
506 turnOffBuffering -- Turn it off right now
511 flushInterpBuffers :: GHCi ()
513 = io $ do Monad.join (readIORef flush_interp)
516 turnOffBuffering :: IO ()
518 = do Monad.join (readIORef turn_off_buffering)
521 -----------------------------------------------------------------------------
524 help :: String -> GHCi ()
525 help _ = io (putStr helpText)
527 info :: String -> GHCi ()
528 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
529 info s = do { let names = words s
530 ; session <- getSession
531 ; dflags <- getDynFlags
532 ; let exts = dopt Opt_GlasgowExts dflags
533 ; mapM_ (infoThing exts session) names }
535 infoThing exts session name
536 = do { stuff <- io (GHC.getInfo session name)
537 ; unqual <- io (GHC.getPrintUnqual session)
538 ; io (putStrLn (showSDocForUser unqual $
539 vcat (intersperse (text "") (map (showThing exts) stuff)))) }
541 showThing :: Bool -> GHC.GetInfoResult -> SDoc
542 showThing exts (wanted_str, thing, fixity, src_loc, insts)
543 = vcat [ showWithLoc src_loc (showDecl exts want_name thing),
545 vcat (map show_inst insts)]
547 want_name occ = wanted_str == occNameUserString occ
550 | fix == defaultFixity = empty
551 | otherwise = ppr fix <+> text wanted_str
553 show_inst (inst_ty, loc)
554 = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty)
556 showWithLoc :: SrcLoc -> SDoc -> SDoc
558 = hang doc 2 (char '\t' <> comment <+> pprDefnLoc loc)
559 -- The tab tries to make them line up a bit
561 comment = ptext SLIT("--")
564 -- Now there is rather a lot of goop just to print declarations in a
565 -- civilised way with "..." for the parts we are less interested in.
567 showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc
568 showDecl exts want_name (IfaceForeign {ifName = tc})
569 = ppr tc <+> ptext SLIT("is a foreign type")
571 showDecl exts want_name (IfaceId {ifName = var, ifType = ty})
572 = ppr var <+> dcolon <+> showIfaceType exts ty
574 showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
575 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
576 2 (equals <+> ppr mono_ty)
578 showDecl exts want_name (IfaceData {ifName = tycon,
579 ifTyVars = tyvars, ifCons = condecls, ifCtxt = context})
580 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
581 2 (add_bars (ppr_trim show_con cs))
583 show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
584 ifConStricts = strs, ifConFields = flds})
585 | want_name tycon || want_name con_name || any want_name flds
586 = Just (show_guts con_name is_infix tys_w_strs flds)
587 | otherwise = Nothing
589 tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
590 show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
591 ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
592 | want_name tycon || want_name con_name
593 = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
594 | otherwise = Nothing
596 tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
597 pp_tau = foldr add pp_res_ty tys_w_strs
598 pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
599 add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
601 show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
602 show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
603 show_guts con _ tys flds
604 = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
606 show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
607 = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
608 | otherwise = Nothing
610 (pp_nd, cs) = case condecls of
611 IfAbstractTyCon -> (ptext SLIT("data"), [])
612 IfDataTyCon cs -> (ptext SLIT("data"), cs)
613 IfNewTyCon c -> (ptext SLIT("newtype"),[c])
616 add_bars [c] = equals <+> c
617 add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
619 ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
620 ppr_str MarkedStrict = char '!'
621 ppr_str MarkedUnboxed = ptext SLIT("!!")
622 ppr_str NotMarkedStrict = empty
624 showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
625 ifFDs = fds, ifSigs = sigs})
626 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
627 <+> pprFundeps fds <+> opt_where)
628 2 (vcat (ppr_trim show_op sigs))
630 opt_where | null sigs = empty
631 | otherwise = ptext SLIT("where")
632 show_op (IfaceClassOp op dm ty)
633 | want_name clas || want_name op
634 = Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty)
638 showIfaceType :: Bool -> IfaceType -> SDoc
639 showIfaceType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
640 showIfaceType False ty = ppr ty -- otherwise, print without the foralls
642 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
644 = snd (foldr go (False, []) xs)
646 go x (eliding, so_far)
647 | Just doc <- show x = (False, doc : so_far)
648 | otherwise = if eliding then (True, so_far)
649 else (True, ptext SLIT("...") : so_far)
651 ppr_bndr :: OccName -> SDoc
652 -- Wrap operators in ()
653 ppr_bndr occ = parenSymOcc occ (ppr occ)
656 -----------------------------------------------------------------------------
659 addModule :: [FilePath] -> GHCi ()
661 io (revertCAFs) -- always revert CAFs on load/add.
662 files <- mapM expandPath files
663 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
664 session <- getSession
665 io (mapM_ (GHC.addTarget session) targets)
666 ok <- io (GHC.load session LoadAllTargets)
669 changeDirectory :: String -> GHCi ()
670 changeDirectory dir = do
671 session <- getSession
672 graph <- io (GHC.getModuleGraph session)
673 when (not (null graph)) $
674 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
675 io (GHC.setTargets session [])
676 io (GHC.load session LoadAllTargets)
677 setContextAfterLoad []
678 io (GHC.workingDirectoryChanged session)
679 dir <- expandPath dir
680 io (setCurrentDirectory dir)
682 defineMacro :: String -> GHCi ()
684 let (macro_name, definition) = break isSpace s
685 cmds <- io (readIORef commands)
687 then throwDyn (CmdLineError "invalid macro name")
689 if (macro_name `elem` map fst cmds)
690 then throwDyn (CmdLineError
691 ("command '" ++ macro_name ++ "' is already defined"))
694 -- give the expression a type signature, so we can be sure we're getting
695 -- something of the right type.
696 let new_expr = '(' : definition ++ ") :: String -> IO String"
698 -- compile the expression
700 maybe_hv <- io (GHC.compileExpr cms new_expr)
703 Just hv -> io (writeIORef commands --
704 ((macro_name, keepGoing (runMacro hv)) : cmds))
706 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
708 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
709 stringLoop (lines str)
711 undefineMacro :: String -> GHCi ()
712 undefineMacro macro_name = do
713 cmds <- io (readIORef commands)
714 if (macro_name `elem` map fst builtin_commands)
715 then throwDyn (CmdLineError
716 ("command '" ++ macro_name ++ "' cannot be undefined"))
718 if (macro_name `notElem` map fst cmds)
719 then throwDyn (CmdLineError
720 ("command '" ++ macro_name ++ "' not defined"))
722 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
725 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
726 loadModule fs = timeIt (loadModule' fs)
728 loadModule_ :: [FilePath] -> GHCi ()
729 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
731 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
732 loadModule' files = do
733 session <- getSession
736 io (GHC.setTargets session [])
737 io (GHC.load session LoadAllTargets)
740 let (filenames, phases) = unzip files
741 exp_filenames <- mapM expandPath filenames
742 let files' = zip exp_filenames phases
743 targets <- io (mapM (uncurry GHC.guessTarget) files')
745 -- NOTE: we used to do the dependency anal first, so that if it
746 -- fails we didn't throw away the current set of modules. This would
747 -- require some re-working of the GHC interface, so we'll leave it
748 -- as a ToDo for now.
750 io (GHC.setTargets session targets)
751 ok <- io (GHC.load session LoadAllTargets)
755 checkModule :: String -> GHCi ()
757 let modl = mkModule m
758 session <- getSession
759 result <- io (GHC.checkModule session modl printErrorsAndWarnings)
761 Nothing -> io $ putStrLn "Nothing"
762 Just r -> io $ putStrLn (showSDoc (
763 case checkedModuleInfo r of
764 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
766 (local,global) = partition ((== modl) . GHC.nameModule) scope
768 (text "global names: " <+> ppr global) $$
769 (text "local names: " <+> ppr local)
771 afterLoad (successIf (isJust result)) session
773 reloadModule :: String -> GHCi ()
775 io (revertCAFs) -- always revert CAFs on reload.
776 session <- getSession
777 ok <- io (GHC.load session LoadAllTargets)
780 io (revertCAFs) -- always revert CAFs on reload.
781 session <- getSession
782 ok <- io (GHC.load session (LoadUpTo (mkModule m)))
785 afterLoad ok session = do
786 io (revertCAFs) -- always revert CAFs on load.
787 graph <- io (GHC.getModuleGraph session)
788 let mods = map GHC.ms_mod graph
789 mods' <- filterM (io . GHC.isLoaded session) mods
790 setContextAfterLoad mods'
791 modulesLoadedMsg ok mods'
793 setContextAfterLoad [] = do
794 session <- getSession
795 io (GHC.setContext session [] [prelude_mod])
796 setContextAfterLoad (m:_) = do
797 session <- getSession
798 b <- io (GHC.moduleIsInterpreted session m)
799 if b then io (GHC.setContext session [m] [])
800 else io (GHC.setContext session [] [m])
802 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
803 modulesLoadedMsg ok mods = do
804 dflags <- getDynFlags
805 when (verbosity dflags > 0) $ do
807 | null mods = text "none."
809 punctuate comma (map pprModule mods)) <> text "."
812 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
814 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
817 typeOfExpr :: String -> GHCi ()
819 = do cms <- getSession
820 maybe_ty <- io (GHC.exprType cms str)
823 Just ty -> do ty' <- cleanType ty
824 tystr <- showForUser (ppr ty')
825 io (putStrLn (str ++ " :: " ++ tystr))
827 kindOfType :: String -> GHCi ()
829 = do cms <- getSession
830 maybe_ty <- io (GHC.typeKind cms str)
833 Just ty -> do tystr <- showForUser (ppr ty)
834 io (putStrLn (str ++ " :: " ++ tystr))
836 quit :: String -> GHCi Bool
839 shellEscape :: String -> GHCi Bool
840 shellEscape str = io (system str >> return False)
842 -----------------------------------------------------------------------------
843 -- Browsing a module's contents
845 browseCmd :: String -> GHCi ()
848 ['*':m] | looksLikeModuleName m -> browseModule m False
849 [m] | looksLikeModuleName m -> browseModule m True
850 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
852 browseModule m exports_only = do
855 let modl = mkModule m
856 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
857 when (not is_interpreted && not exports_only) $
858 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
860 -- Temporarily set the context to the module we're interested in,
861 -- just so we can get an appropriate PrintUnqualified
862 (as,bs) <- io (GHC.getContext s)
863 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
864 else GHC.setContext s [modl] [])
865 io (GHC.setContext s as bs)
867 things <- io (GHC.browseModule s modl exports_only)
868 unqual <- io (GHC.getPrintUnqual s)
870 dflags <- getDynFlags
871 let exts = dopt Opt_GlasgowExts dflags
872 io (putStrLn (showSDocForUser unqual (
873 vcat (map (showDecl exts (const True)) things)
876 -----------------------------------------------------------------------------
877 -- Setting the module context
880 | all sensible mods = fn mods
881 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
883 (fn, mods) = case str of
884 '+':stuff -> (addToContext, words stuff)
885 '-':stuff -> (removeFromContext, words stuff)
886 stuff -> (newContext, words stuff)
888 sensible ('*':m) = looksLikeModuleName m
889 sensible m = looksLikeModuleName m
892 session <- getSession
893 (as,bs) <- separate session mods [] []
894 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
895 io (GHC.setContext session as bs')
897 separate :: Session -> [String] -> [Module] -> [Module]
898 -> GHCi ([Module],[Module])
899 separate session [] as bs = return (as,bs)
900 separate session (('*':m):ms) as bs = do
901 let modl = mkModule m
902 b <- io (GHC.moduleIsInterpreted session modl)
903 if b then separate session ms (modl:as) bs
904 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
905 separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
907 prelude_mod = mkModule "Prelude"
910 addToContext mods = do
912 (as,bs) <- io (GHC.getContext cms)
914 (as',bs') <- separate cms mods [] []
916 let as_to_add = as' \\ (as ++ bs)
917 bs_to_add = bs' \\ (as ++ bs)
919 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
922 removeFromContext mods = do
924 (as,bs) <- io (GHC.getContext cms)
926 (as_to_remove,bs_to_remove) <- separate cms mods [] []
928 let as' = as \\ (as_to_remove ++ bs_to_remove)
929 bs' = bs \\ (as_to_remove ++ bs_to_remove)
931 io (GHC.setContext cms as' bs')
933 ----------------------------------------------------------------------------
936 -- set options in the interpreter. Syntax is exactly the same as the
937 -- ghc command line, except that certain options aren't available (-C,
940 -- This is pretty fragile: most options won't work as expected. ToDo:
941 -- figure out which ones & disallow them.
943 setCmd :: String -> GHCi ()
945 = do st <- getGHCiState
946 let opts = options st
947 io $ putStrLn (showSDoc (
948 text "options currently set: " <>
951 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
955 ("args":args) -> setArgs args
956 ("prog":prog) -> setProg prog
957 wds -> setOptions wds
961 setGHCiState st{ args = args }
965 setGHCiState st{ progname = prog }
967 io (hPutStrLn stderr "syntax: :set prog <progname>")
970 do -- first, deal with the GHCi opts (+s, +t, etc.)
971 let (plus_opts, minus_opts) = partition isPlus wds
972 mapM_ setOpt plus_opts
974 -- then, dynamic flags
975 dflags <- getDynFlags
976 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
979 -- update things if the users wants more packages
981 let new_packages = pkgs_after \\ pkgs_before
982 when (not (null new_packages)) $
983 newPackages new_packages
986 if (not (null leftovers))
987 then throwDyn (CmdLineError ("unrecognised flags: " ++
992 unsetOptions :: String -> GHCi ()
994 = do -- first, deal with the GHCi opts (+s, +t, etc.)
996 (minus_opts, rest1) = partition isMinus opts
997 (plus_opts, rest2) = partition isPlus rest1
999 if (not (null rest2))
1000 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1003 mapM_ unsetOpt plus_opts
1005 -- can't do GHC flags for now
1006 if (not (null minus_opts))
1007 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1010 isMinus ('-':s) = True
1013 isPlus ('+':s) = True
1017 = case strToGHCiOpt str of
1018 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1019 Just o -> setOption o
1022 = case strToGHCiOpt str of
1023 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1024 Just o -> unsetOption o
1026 strToGHCiOpt :: String -> (Maybe GHCiOption)
1027 strToGHCiOpt "s" = Just ShowTiming
1028 strToGHCiOpt "t" = Just ShowType
1029 strToGHCiOpt "r" = Just RevertCAFs
1030 strToGHCiOpt _ = Nothing
1032 optToStr :: GHCiOption -> String
1033 optToStr ShowTiming = "s"
1034 optToStr ShowType = "t"
1035 optToStr RevertCAFs = "r"
1038 newPackages new_pkgs = do -- The new packages are already in v_Packages
1039 session <- getSession
1040 io (GHC.setTargets session [])
1041 io (GHC.load session Nothing)
1042 dflags <- getDynFlags
1043 io (linkPackages dflags new_pkgs)
1044 setContextAfterLoad []
1047 -- ---------------------------------------------------------------------------
1052 ["modules" ] -> showModules
1053 ["bindings"] -> showBindings
1054 ["linker"] -> io showLinkerState
1055 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1058 session <- getSession
1059 let show_one ms = do m <- io (GHC.showModule session ms)
1061 graph <- io (GHC.getModuleGraph session)
1062 mapM_ show_one graph
1066 unqual <- io (GHC.getPrintUnqual s)
1067 bindings <- io (GHC.getBindings s)
1068 mapM_ showTyThing bindings
1071 showTyThing (AnId id) = do
1072 ty' <- cleanType (GHC.idType id)
1073 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1075 showTyThing _ = return ()
1077 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1078 cleanType :: Type -> GHCi Type
1080 dflags <- getDynFlags
1081 if dopt Opt_GlasgowExts dflags
1083 else return $! GHC.dropForAlls ty
1085 -----------------------------------------------------------------------------
1088 data GHCiState = GHCiState
1092 session :: GHC.Session,
1093 options :: [GHCiOption]
1097 = ShowTiming -- show time/allocs after evaluation
1098 | ShowType -- show the type of expressions
1099 | RevertCAFs -- revert CAFs after every evaluation
1102 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1104 startGHCi :: GHCi a -> GHCiState -> IO a
1105 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1107 instance Monad GHCi where
1108 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1109 return a = GHCi $ \s -> return a
1111 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1112 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1113 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1115 getGHCiState = GHCi $ \r -> readIORef r
1116 setGHCiState s = GHCi $ \r -> writeIORef r s
1118 -- for convenience...
1119 getSession = getGHCiState >>= return . session
1123 io (GHC.getSessionDynFlags s)
1124 setDynFlags dflags = do
1126 io (GHC.setSessionDynFlags s dflags)
1128 isOptionSet :: GHCiOption -> GHCi Bool
1130 = do st <- getGHCiState
1131 return (opt `elem` options st)
1133 setOption :: GHCiOption -> GHCi ()
1135 = do st <- getGHCiState
1136 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1138 unsetOption :: GHCiOption -> GHCi ()
1140 = do st <- getGHCiState
1141 setGHCiState (st{ options = filter (/= opt) (options st) })
1143 io :: IO a -> GHCi a
1144 io m = GHCi { unGHCi = \s -> m >>= return }
1146 -----------------------------------------------------------------------------
1147 -- recursive exception handlers
1149 -- Don't forget to unblock async exceptions in the handler, or if we're
1150 -- in an exception loop (eg. let a = error a in a) the ^C exception
1151 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1153 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1154 ghciHandle h (GHCi m) = GHCi $ \s ->
1155 Exception.catch (m s)
1156 (\e -> unGHCi (ghciUnblock (h e)) s)
1158 ghciUnblock :: GHCi a -> GHCi a
1159 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1161 -----------------------------------------------------------------------------
1162 -- timing & statistics
1164 timeIt :: GHCi a -> GHCi a
1166 = do b <- isOptionSet ShowTiming
1169 else do allocs1 <- io $ getAllocations
1170 time1 <- io $ getCPUTime
1172 allocs2 <- io $ getAllocations
1173 time2 <- io $ getCPUTime
1174 io $ printTimes (fromIntegral (allocs2 - allocs1))
1178 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1179 -- defined in ghc/rts/Stats.c
1181 printTimes :: Integer -> Integer -> IO ()
1182 printTimes allocs psecs
1183 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1184 secs_str = showFFloat (Just 2) secs
1185 putStrLn (showSDoc (
1186 parens (text (secs_str "") <+> text "secs" <> comma <+>
1187 text (show allocs) <+> text "bytes")))
1189 -----------------------------------------------------------------------------
1196 -- Have to turn off buffering again, because we just
1197 -- reverted stdout, stderr & stdin to their defaults.
1199 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1200 -- Make it "safe", just in case
1202 -- -----------------------------------------------------------------------------
1205 expandPath :: String -> GHCi String
1207 case dropWhile isSpace path of
1209 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1210 return (tilde ++ '/':d)