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(..),
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 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 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 (io . GHC.guessTarget) 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] -> GHCi SuccessFlag
726 loadModule fs = timeIt (loadModule' fs)
728 loadModule_ :: [FilePath] -> GHCi ()
729 loadModule_ fs = do loadModule fs; return ()
731 loadModule' :: [FilePath] -> GHCi SuccessFlag
732 loadModule' files = do
733 session <- getSession
736 io (GHC.setTargets session [])
737 io (GHC.load session LoadAllTargets)
740 files <- mapM expandPath files
741 targets <- io (mapM GHC.guessTarget files)
743 -- NOTE: we used to do the dependency anal first, so that if it
744 -- fails we didn't throw away the current set of modules. This would
745 -- require some re-working of the GHC interface, so we'll leave it
746 -- as a ToDo for now.
748 io (GHC.setTargets session targets)
749 ok <- io (GHC.load session LoadAllTargets)
753 checkModule :: String -> GHCi ()
755 let modl = mkModule m
756 session <- getSession
757 result <- io (GHC.checkModule session modl printErrorsAndWarnings)
759 Nothing -> io $ putStrLn "Nothing"
760 Just r -> io $ putStrLn (showSDoc (
761 case checkedModuleInfo r of
762 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
764 (local,global) = partition ((== modl) . GHC.nameModule) scope
766 (text "global names: " <+> ppr global) $$
767 (text "local names: " <+> ppr local)
769 afterLoad (successIf (isJust result)) session
771 reloadModule :: String -> GHCi ()
773 io (revertCAFs) -- always revert CAFs on reload.
774 session <- getSession
775 ok <- io (GHC.load session LoadAllTargets)
778 io (revertCAFs) -- always revert CAFs on reload.
779 session <- getSession
780 ok <- io (GHC.load session (LoadUpTo (mkModule m)))
783 afterLoad ok session = do
784 io (revertCAFs) -- always revert CAFs on load.
785 graph <- io (GHC.getModuleGraph session)
786 let mods = map GHC.ms_mod graph
787 mods' <- filterM (io . GHC.isLoaded session) mods
788 setContextAfterLoad mods'
789 modulesLoadedMsg ok mods'
791 setContextAfterLoad [] = do
792 session <- getSession
793 io (GHC.setContext session [] [prelude_mod])
794 setContextAfterLoad (m:_) = do
795 session <- getSession
796 b <- io (GHC.moduleIsInterpreted session m)
797 if b then io (GHC.setContext session [m] [])
798 else io (GHC.setContext session [] [m])
800 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
801 modulesLoadedMsg ok mods = do
802 dflags <- getDynFlags
803 when (verbosity dflags > 0) $ do
805 | null mods = text "none."
807 punctuate comma (map pprModule mods)) <> text "."
810 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
812 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
815 typeOfExpr :: String -> GHCi ()
817 = do cms <- getSession
818 maybe_ty <- io (GHC.exprType cms str)
821 Just ty -> do ty' <- cleanType ty
822 tystr <- showForUser (ppr ty')
823 io (putStrLn (str ++ " :: " ++ tystr))
825 kindOfType :: String -> GHCi ()
827 = do cms <- getSession
828 maybe_ty <- io (GHC.typeKind cms str)
831 Just ty -> do tystr <- showForUser (ppr ty)
832 io (putStrLn (str ++ " :: " ++ tystr))
834 quit :: String -> GHCi Bool
837 shellEscape :: String -> GHCi Bool
838 shellEscape str = io (system str >> return False)
840 -----------------------------------------------------------------------------
841 -- Browsing a module's contents
843 browseCmd :: String -> GHCi ()
846 ['*':m] | looksLikeModuleName m -> browseModule m False
847 [m] | looksLikeModuleName m -> browseModule m True
848 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
850 browseModule m exports_only = do
853 let modl = mkModule m
854 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
855 when (not is_interpreted && not exports_only) $
856 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
858 -- Temporarily set the context to the module we're interested in,
859 -- just so we can get an appropriate PrintUnqualified
860 (as,bs) <- io (GHC.getContext s)
861 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
862 else GHC.setContext s [modl] [])
863 io (GHC.setContext s as bs)
865 things <- io (GHC.browseModule s modl exports_only)
866 unqual <- io (GHC.getPrintUnqual s)
868 dflags <- getDynFlags
869 let exts = dopt Opt_GlasgowExts dflags
870 io (putStrLn (showSDocForUser unqual (
871 vcat (map (showDecl exts (const True)) things)
874 -----------------------------------------------------------------------------
875 -- Setting the module context
878 | all sensible mods = fn mods
879 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
881 (fn, mods) = case str of
882 '+':stuff -> (addToContext, words stuff)
883 '-':stuff -> (removeFromContext, words stuff)
884 stuff -> (newContext, words stuff)
886 sensible ('*':m) = looksLikeModuleName m
887 sensible m = looksLikeModuleName m
890 session <- getSession
891 (as,bs) <- separate session mods [] []
892 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
893 io (GHC.setContext session as bs')
895 separate :: Session -> [String] -> [Module] -> [Module]
896 -> GHCi ([Module],[Module])
897 separate session [] as bs = return (as,bs)
898 separate session (('*':m):ms) as bs = do
899 let modl = mkModule m
900 b <- io (GHC.moduleIsInterpreted session modl)
901 if b then separate session ms (modl:as) bs
902 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
903 separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
905 prelude_mod = mkModule "Prelude"
908 addToContext mods = do
910 (as,bs) <- io (GHC.getContext cms)
912 (as',bs') <- separate cms mods [] []
914 let as_to_add = as' \\ (as ++ bs)
915 bs_to_add = bs' \\ (as ++ bs)
917 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
920 removeFromContext mods = do
922 (as,bs) <- io (GHC.getContext cms)
924 (as_to_remove,bs_to_remove) <- separate cms mods [] []
926 let as' = as \\ (as_to_remove ++ bs_to_remove)
927 bs' = bs \\ (as_to_remove ++ bs_to_remove)
929 io (GHC.setContext cms as' bs')
931 ----------------------------------------------------------------------------
934 -- set options in the interpreter. Syntax is exactly the same as the
935 -- ghc command line, except that certain options aren't available (-C,
938 -- This is pretty fragile: most options won't work as expected. ToDo:
939 -- figure out which ones & disallow them.
941 setCmd :: String -> GHCi ()
943 = do st <- getGHCiState
944 let opts = options st
945 io $ putStrLn (showSDoc (
946 text "options currently set: " <>
949 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
953 ("args":args) -> setArgs args
954 ("prog":prog) -> setProg prog
955 wds -> setOptions wds
959 setGHCiState st{ args = args }
963 setGHCiState st{ progname = prog }
965 io (hPutStrLn stderr "syntax: :set prog <progname>")
968 do -- first, deal with the GHCi opts (+s, +t, etc.)
969 let (plus_opts, minus_opts) = partition isPlus wds
970 mapM_ setOpt plus_opts
972 -- then, dynamic flags
973 dflags <- getDynFlags
974 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
977 -- update things if the users wants more packages
979 let new_packages = pkgs_after \\ pkgs_before
980 when (not (null new_packages)) $
981 newPackages new_packages
984 if (not (null leftovers))
985 then throwDyn (CmdLineError ("unrecognised flags: " ++
990 unsetOptions :: String -> GHCi ()
992 = do -- first, deal with the GHCi opts (+s, +t, etc.)
994 (minus_opts, rest1) = partition isMinus opts
995 (plus_opts, rest2) = partition isPlus rest1
997 if (not (null rest2))
998 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1001 mapM_ unsetOpt plus_opts
1003 -- can't do GHC flags for now
1004 if (not (null minus_opts))
1005 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1008 isMinus ('-':s) = True
1011 isPlus ('+':s) = True
1015 = case strToGHCiOpt str of
1016 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1017 Just o -> setOption o
1020 = case strToGHCiOpt str of
1021 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1022 Just o -> unsetOption o
1024 strToGHCiOpt :: String -> (Maybe GHCiOption)
1025 strToGHCiOpt "s" = Just ShowTiming
1026 strToGHCiOpt "t" = Just ShowType
1027 strToGHCiOpt "r" = Just RevertCAFs
1028 strToGHCiOpt _ = Nothing
1030 optToStr :: GHCiOption -> String
1031 optToStr ShowTiming = "s"
1032 optToStr ShowType = "t"
1033 optToStr RevertCAFs = "r"
1036 newPackages new_pkgs = do -- The new packages are already in v_Packages
1037 session <- getSession
1038 io (GHC.setTargets session [])
1039 io (GHC.load session Nothing)
1040 dflags <- getDynFlags
1041 io (linkPackages dflags new_pkgs)
1042 setContextAfterLoad []
1045 -- ---------------------------------------------------------------------------
1050 ["modules" ] -> showModules
1051 ["bindings"] -> showBindings
1052 ["linker"] -> io showLinkerState
1053 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1056 session <- getSession
1057 let show_one ms = do m <- io (GHC.showModule session ms)
1059 graph <- io (GHC.getModuleGraph session)
1060 mapM_ show_one graph
1064 unqual <- io (GHC.getPrintUnqual s)
1065 bindings <- io (GHC.getBindings s)
1066 mapM_ showTyThing bindings
1069 showTyThing (AnId id) = do
1070 ty' <- cleanType (GHC.idType id)
1071 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1073 showTyThing _ = return ()
1075 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1076 cleanType :: Type -> GHCi Type
1078 dflags <- getDynFlags
1079 if dopt Opt_GlasgowExts dflags
1081 else return $! GHC.dropForAlls ty
1083 -----------------------------------------------------------------------------
1086 data GHCiState = GHCiState
1090 session :: GHC.Session,
1091 options :: [GHCiOption]
1095 = ShowTiming -- show time/allocs after evaluation
1096 | ShowType -- show the type of expressions
1097 | RevertCAFs -- revert CAFs after every evaluation
1100 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1102 startGHCi :: GHCi a -> GHCiState -> IO a
1103 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1105 instance Monad GHCi where
1106 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1107 return a = GHCi $ \s -> return a
1109 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1110 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1111 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1113 getGHCiState = GHCi $ \r -> readIORef r
1114 setGHCiState s = GHCi $ \r -> writeIORef r s
1116 -- for convenience...
1117 getSession = getGHCiState >>= return . session
1121 io (GHC.getSessionDynFlags s)
1122 setDynFlags dflags = do
1124 io (GHC.setSessionDynFlags s dflags)
1126 isOptionSet :: GHCiOption -> GHCi Bool
1128 = do st <- getGHCiState
1129 return (opt `elem` options st)
1131 setOption :: GHCiOption -> GHCi ()
1133 = do st <- getGHCiState
1134 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1136 unsetOption :: GHCiOption -> GHCi ()
1138 = do st <- getGHCiState
1139 setGHCiState (st{ options = filter (/= opt) (options st) })
1141 io :: IO a -> GHCi a
1142 io m = GHCi { unGHCi = \s -> m >>= return }
1144 -----------------------------------------------------------------------------
1145 -- recursive exception handlers
1147 -- Don't forget to unblock async exceptions in the handler, or if we're
1148 -- in an exception loop (eg. let a = error a in a) the ^C exception
1149 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1151 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1152 ghciHandle h (GHCi m) = GHCi $ \s ->
1153 Exception.catch (m s)
1154 (\e -> unGHCi (ghciUnblock (h e)) s)
1156 ghciUnblock :: GHCi a -> GHCi a
1157 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1159 -----------------------------------------------------------------------------
1160 -- timing & statistics
1162 timeIt :: GHCi a -> GHCi a
1164 = do b <- isOptionSet ShowTiming
1167 else do allocs1 <- io $ getAllocations
1168 time1 <- io $ getCPUTime
1170 allocs2 <- io $ getAllocations
1171 time2 <- io $ getCPUTime
1172 io $ printTimes (fromIntegral (allocs2 - allocs1))
1176 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1177 -- defined in ghc/rts/Stats.c
1179 printTimes :: Integer -> Integer -> IO ()
1180 printTimes allocs psecs
1181 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1182 secs_str = showFFloat (Just 2) secs
1183 putStrLn (showSDoc (
1184 parens (text (secs_str "") <+> text "secs" <> comma <+>
1185 text (show allocs) <+> text "bytes")))
1187 -----------------------------------------------------------------------------
1194 -- Have to turn off buffering again, because we just
1195 -- reverted stdout, stderr & stdin to their defaults.
1197 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1198 -- Make it "safe", just in case
1200 -- -----------------------------------------------------------------------------
1203 expandPath :: String -> GHCi String
1205 case dropWhile isSpace path of
1207 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1208 return (tilde ++ '/':d)