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 )
24 -- following all needed for :info... ToDo: remove
25 import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
26 IfaceConDecl(..), IfaceType,
27 pprIfaceDeclHead, pprParendIfaceType,
28 pprIfaceForAllPart, pprIfaceType )
29 import FunDeps ( pprFundeps )
30 import SrcLoc ( SrcLoc, isGoodSrcLoc )
31 import OccName ( OccName, parenSymOcc, occNameUserString )
32 import BasicTypes ( StrictnessMark(..), defaultFixity )
34 -- Other random utilities
35 import Panic ( panic, installSignalHandlers )
37 import StaticFlags ( opt_IgnoreDotGhci )
38 import Linker ( showLinkerState )
39 import Util ( removeSpaces, handle, global, toArgs,
40 looksLikeModuleName, prefixMatch )
42 #ifndef mingw32_HOST_OS
43 import Util ( handle )
45 #if __GLASGOW_HASKELL__ > 504
51 import Control.Concurrent ( yield ) -- Used in readline loop
52 import System.Console.Readline as Readline
57 import Control.Exception as Exception
59 -- import Control.Concurrent
63 import Data.Int ( Int64 )
66 import System.Environment
67 import System.Exit ( exitWith, ExitCode(..) )
68 import System.Directory
70 import System.IO.Error as IO
72 import Control.Monad as Monad
73 import Foreign.StablePtr ( newStablePtr )
75 import GHC.Exts ( unsafeCoerce# )
76 import GHC.IOBase ( IOErrorType(InvalidArgument) )
78 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
80 import System.Posix.Internals ( setNonBlockingFD )
82 -----------------------------------------------------------------------------
86 " / _ \\ /\\ /\\/ __(_)\n"++
87 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
88 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
89 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
91 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
93 builtin_commands :: [(String, String -> GHCi Bool)]
95 ("add", keepGoingPaths addModule),
96 ("browse", keepGoing browseCmd),
97 ("cd", keepGoing changeDirectory),
98 ("def", keepGoing defineMacro),
99 ("help", keepGoing help),
100 ("?", keepGoing help),
101 ("info", keepGoing info),
102 ("load", keepGoingPaths loadModule),
103 ("module", keepGoing setContext),
104 ("reload", keepGoing reloadModule),
105 ("set", keepGoing setCmd),
106 ("show", keepGoing showCmd),
107 ("type", keepGoing typeOfExpr),
108 ("kind", keepGoing kindOfType),
109 ("unset", keepGoing unsetOptions),
110 ("undef", keepGoing undefineMacro),
114 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
115 keepGoing a str = a str >> return False
117 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
118 keepGoingPaths a str = a (toArgs str) >> return False
120 shortHelpText = "use :? for help.\n"
122 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
124 " Commands available from the prompt:\n" ++
126 " <stmt> evaluate/run <stmt>\n" ++
127 " :add <filename> ... add module(s) to the current target set\n" ++
128 " :browse [*]<module> display the names defined by <module>\n" ++
129 " :cd <dir> change directory to <dir>\n" ++
130 " :def <cmd> <expr> define a command :<cmd>\n" ++
131 " :help, :? display this list of commands\n" ++
132 " :info [<name> ...] display information about the given names\n" ++
133 " :load <filename> ... load module(s) and their dependents\n" ++
134 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
135 " :reload reload the current module set\n" ++
137 " :set <option> ... set options\n" ++
138 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
139 " :set prog <progname> set the value returned by System.getProgName\n" ++
141 " :show modules show the currently loaded modules\n" ++
142 " :show bindings show the current bindings made at the prompt\n" ++
144 " :type <expr> show the type of <expr>\n" ++
145 " :kind <type> show the kind of <type>\n" ++
146 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
147 " :unset <option> ... unset options\n" ++
148 " :quit exit GHCi\n" ++
149 " :!<command> run the shell command <command>\n" ++
151 " Options for ':set' and ':unset':\n" ++
153 " +r revert top-level expressions after each evaluation\n" ++
154 " +s print timing/memory stats after each evaluation\n" ++
155 " +t print type after evaluation\n" ++
156 " -<flags> most GHC command line flags can also be set here\n" ++
157 " (eg. -v2, -fglasgow-exts, etc.)\n"
160 interactiveUI :: Session -> [FilePath] -> Maybe String -> IO ()
161 interactiveUI session srcs maybe_expr = do
163 -- HACK! If we happen to get into an infinite loop (eg the user
164 -- types 'let x=x in x' at the prompt), then the thread will block
165 -- on a blackhole, and become unreachable during GC. The GC will
166 -- detect that it is unreachable and send it the NonTermination
167 -- exception. However, since the thread is unreachable, everything
168 -- it refers to might be finalized, including the standard Handles.
169 -- This sounds like a bug, but we don't have a good solution right
176 hSetBuffering stdout NoBuffering
178 -- Initialise buffering for the *interpreted* I/O system
179 initInterpBuffering session
181 -- We don't want the cmd line to buffer any input that might be
182 -- intended for the program, so unbuffer stdin.
183 hSetBuffering stdin NoBuffering
185 -- initial context is just the Prelude
186 GHC.setContext session [] [prelude_mod]
192 startGHCi (runGHCi srcs maybe_expr)
193 GHCiState{ progname = "<interactive>",
199 Readline.resetTerminal Nothing
204 runGHCi :: [FilePath] -> Maybe String -> GHCi ()
205 runGHCi paths maybe_expr = do
206 let read_dot_files = not opt_IgnoreDotGhci
208 when (read_dot_files) $ do
211 exists <- io (doesFileExist file)
213 dir_ok <- io (checkPerms ".")
214 file_ok <- io (checkPerms file)
215 when (dir_ok && file_ok) $ do
216 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
219 Right hdl -> fileLoop hdl False
221 when (read_dot_files) $ do
222 -- Read in $HOME/.ghci
223 either_dir <- io (IO.try (getEnv "HOME"))
227 cwd <- io (getCurrentDirectory)
228 when (dir /= cwd) $ do
229 let file = dir ++ "/.ghci"
230 ok <- io (checkPerms file)
232 either_hdl <- io (IO.try (openFile file ReadMode))
235 Right hdl -> fileLoop hdl False
237 -- Perform a :load for files given on the GHCi command line
238 when (not (null paths)) $
239 ghciHandle showException $
242 -- if verbosity is greater than 0, or we are connected to a
243 -- terminal, display the prompt in the interactive loop.
244 is_tty <- io (hIsTerminalDevice stdin)
245 dflags <- getDynFlags
246 let show_prompt = verbosity dflags > 0 || is_tty
250 -- enter the interactive loop
251 interactiveLoop is_tty show_prompt
253 -- just evaluate the expression we were given
258 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
261 interactiveLoop is_tty show_prompt = do
262 -- Ignore ^C exceptions caught here
263 ghciHandleDyn (\e -> case e of
264 Interrupted -> ghciUnblock (
265 #if defined(mingw32_HOST_OS)
268 interactiveLoop is_tty show_prompt)
269 _other -> return ()) $ do
271 -- read commands from stdin
275 else fileLoop stdin show_prompt
277 fileLoop stdin show_prompt
281 -- NOTE: We only read .ghci files if they are owned by the current user,
282 -- and aren't world writable. Otherwise, we could be accidentally
283 -- running code planted by a malicious third party.
285 -- Furthermore, We only read ./.ghci if . is owned by the current user
286 -- and isn't writable by anyone else. I think this is sufficient: we
287 -- don't need to check .. and ../.. etc. because "." always refers to
288 -- the same directory while a process is running.
290 checkPerms :: String -> IO Bool
292 #ifdef mingw32_HOST_OS
295 Util.handle (\_ -> return False) $ do
296 st <- getFileStatus name
298 if fileOwner st /= me then do
299 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
302 let mode = fileMode st
303 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
304 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
306 putStrLn $ "*** WARNING: " ++ name ++
307 " is writable by someone else, IGNORING!"
312 fileLoop :: Handle -> Bool -> GHCi ()
313 fileLoop hdl prompt = do
314 session <- getSession
315 (mod,imports) <- io (GHC.getContext session)
316 when prompt (io (putStr (mkPrompt mod imports)))
317 l <- io (IO.try (hGetLine hdl))
319 Left e | isEOFError e -> return ()
320 | InvalidArgument <- etype -> return ()
321 | otherwise -> io (ioError e)
322 where etype = ioeGetErrorType e
323 -- treat InvalidArgument in the same way as EOF:
324 -- this can happen if the user closed stdin, or
325 -- perhaps did getContents which closes stdin at
328 case removeSpaces l of
329 "" -> fileLoop hdl prompt
330 l -> do quit <- runCommand l
331 if quit then return () else fileLoop hdl prompt
333 stringLoop :: [String] -> GHCi ()
334 stringLoop [] = return ()
335 stringLoop (s:ss) = do
336 case removeSpaces s of
338 l -> do quit <- runCommand l
339 if quit then return () else stringLoop ss
341 mkPrompt toplevs exports
342 = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
343 <+> hsep (map pprModule exports)
347 readlineLoop :: GHCi ()
349 session <- getSession
350 (mod,imports) <- io (GHC.getContext session)
352 l <- io (readline (mkPrompt mod imports)
353 `finally` setNonBlockingFD 0)
354 -- readline sometimes puts stdin into blocking mode,
355 -- so we need to put it back for the IO library
359 case removeSpaces l of
364 if quit then return () else readlineLoop
367 runCommand :: String -> GHCi Bool
368 runCommand c = ghciHandle handler (doCommand c)
370 -- This version is for the GHC command-line option -e. The only difference
371 -- from runCommand is that it catches the ExitException exception and
372 -- exits, rather than printing out the exception.
373 runCommandEval c = ghciHandle handleEval (doCommand c)
375 handleEval (ExitException code) = io (exitWith code)
376 handleEval e = do showException e
377 io (exitWith (ExitFailure 1))
379 -- This is the exception handler for exceptions generated by the
380 -- user's code; it normally just prints out the exception. The
381 -- handler must be recursive, in case showing the exception causes
382 -- more exceptions to be raised.
384 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
385 -- raising another exception. We therefore don't put the recursive
386 -- handler arond the flushing operation, so if stderr is closed
387 -- GHCi will just die gracefully rather than going into an infinite loop.
388 handler :: Exception -> GHCi Bool
389 handler exception = do
391 io installSignalHandlers
392 ghciHandle handler (showException exception >> return False)
394 showException (DynException dyn) =
395 case fromDynamic dyn of
396 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
397 Just Interrupted -> io (putStrLn "Interrupted.")
398 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
399 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
400 Just other_ghc_ex -> io (print other_ghc_ex)
402 showException other_exception
403 = io (putStrLn ("*** Exception: " ++ show other_exception))
405 doCommand (':' : command) = specialCommand command
407 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
410 runStmt :: String -> GHCi [Name]
412 | null (filter (not.isSpace) stmt) = return []
414 = do st <- getGHCiState
415 session <- getSession
416 result <- io $ withProgName (progname st) $ withArgs (args st) $
417 GHC.runStmt session stmt
419 GHC.RunFailed -> return []
420 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
421 GHC.RunOk names -> return names
423 -- possibly print the type and revert CAFs after evaluating an expression
425 = do b <- isOptionSet ShowType
426 session <- getSession
427 when b (mapM_ (showTypeOfName session) names)
430 io installSignalHandlers
431 b <- isOptionSet RevertCAFs
432 io (when b revertCAFs)
435 showTypeOfName :: Session -> Name -> GHCi ()
436 showTypeOfName session n
437 = do maybe_tything <- io (GHC.lookupName session n)
438 case maybe_tything of
440 Just thing -> showTyThing thing
442 showForUser :: SDoc -> GHCi String
444 session <- getSession
445 unqual <- io (GHC.getPrintUnqual session)
446 return $! showSDocForUser unqual doc
448 specialCommand :: String -> GHCi Bool
449 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
450 specialCommand str = do
451 let (cmd,rest) = break isSpace str
452 cmds <- io (readIORef commands)
453 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
454 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
455 ++ shortHelpText) >> return False)
456 [(_,f)] -> f (dropWhile isSpace rest)
457 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
458 " matches multiple commands (" ++
459 foldr1 (\a b -> a ++ ',':b) (map fst cs)
460 ++ ")") >> return False)
462 noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
465 -----------------------------------------------------------------------------
466 -- To flush buffers for the *interpreted* computation we need
467 -- to refer to *its* stdout/stderr handles
469 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
470 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
472 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
473 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
474 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
476 initInterpBuffering :: Session -> IO ()
477 initInterpBuffering session
478 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
481 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
482 other -> panic "interactiveUI:setBuffering"
484 maybe_hval <- GHC.compileExpr session flush_cmd
486 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
487 _ -> panic "interactiveUI:flush"
489 turnOffBuffering -- Turn it off right now
494 flushInterpBuffers :: GHCi ()
496 = io $ do Monad.join (readIORef flush_interp)
499 turnOffBuffering :: IO ()
501 = do Monad.join (readIORef turn_off_buffering)
504 -----------------------------------------------------------------------------
507 help :: String -> GHCi ()
508 help _ = io (putStr helpText)
510 info :: String -> GHCi ()
511 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
512 info s = do { let names = words s
513 ; session <- getSession
514 ; dflags <- getDynFlags
515 ; let exts = dopt Opt_GlasgowExts dflags
516 ; mapM_ (infoThing exts session) names }
518 infoThing exts session name
519 = do { stuff <- io (GHC.getInfo session name)
520 ; unqual <- io (GHC.getPrintUnqual session)
521 ; io (putStrLn (showSDocForUser unqual $
522 vcat (intersperse (text "") (map (showThing exts) stuff)))) }
524 showThing :: Bool -> GHC.GetInfoResult -> SDoc
525 showThing exts (wanted_str, thing, fixity, src_loc, insts)
526 = vcat [ showWithLoc src_loc (showDecl exts want_name thing),
528 vcat (map show_inst insts)]
530 want_name occ = wanted_str == occNameUserString occ
533 | fix == defaultFixity = empty
534 | otherwise = ppr fix <+> text wanted_str
536 show_inst (inst_ty, loc)
537 = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty)
539 showWithLoc :: SrcLoc -> SDoc -> SDoc
541 = hang doc 2 (char '\t' <> show_loc loc)
542 -- The tab tries to make them line up a bit
544 show_loc loc -- The ppr function for SrcLocs is a bit wonky
545 | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
546 | otherwise = comment <+> ppr loc
547 comment = ptext SLIT("--")
550 -- Now there is rather a lot of goop just to print declarations in a
551 -- civilised way with "..." for the parts we are less interested in.
553 showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc
554 showDecl exts want_name (IfaceForeign {ifName = tc})
555 = ppr tc <+> ptext SLIT("is a foreign type")
557 showDecl exts want_name (IfaceId {ifName = var, ifType = ty})
558 = ppr var <+> dcolon <+> showIfaceType exts ty
560 showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
561 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
562 2 (equals <+> ppr mono_ty)
564 showDecl exts want_name (IfaceData {ifName = tycon,
565 ifTyVars = tyvars, ifCons = condecls, ifCtxt = context})
566 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
567 2 (add_bars (ppr_trim show_con cs))
569 show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
570 ifConStricts = strs, ifConFields = flds})
571 | want_name tycon || want_name con_name || any want_name flds
572 = Just (show_guts con_name is_infix tys_w_strs flds)
573 | otherwise = Nothing
575 tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
576 show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
577 ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
578 | want_name tycon || want_name con_name
579 = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
580 | otherwise = Nothing
582 tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
583 pp_tau = foldr add pp_res_ty tys_w_strs
584 pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
585 add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
587 show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
588 show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
589 show_guts con _ tys flds
590 = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
592 show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
593 = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
594 | otherwise = Nothing
596 (pp_nd, cs) = case condecls of
597 IfAbstractTyCon -> (ptext SLIT("data"), [])
598 IfDataTyCon cs -> (ptext SLIT("data"), cs)
599 IfNewTyCon c -> (ptext SLIT("newtype"),[c])
602 add_bars [c] = equals <+> c
603 add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
605 ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
606 ppr_str MarkedStrict = char '!'
607 ppr_str MarkedUnboxed = ptext SLIT("!!")
608 ppr_str NotMarkedStrict = empty
610 showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
611 ifFDs = fds, ifSigs = sigs})
612 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
613 <+> pprFundeps fds <+> opt_where)
614 2 (vcat (ppr_trim show_op sigs))
616 opt_where | null sigs = empty
617 | otherwise = ptext SLIT("where")
618 show_op (IfaceClassOp op dm ty)
619 | want_name clas || want_name op
620 = Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty)
624 showIfaceType :: Bool -> IfaceType -> SDoc
625 showIfaceType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
626 showIfaceType False ty = ppr ty -- otherwise, print without the foralls
628 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
630 = snd (foldr go (False, []) xs)
632 go x (eliding, so_far)
633 | Just doc <- show x = (False, doc : so_far)
634 | otherwise = if eliding then (True, so_far)
635 else (True, ptext SLIT("...") : so_far)
637 ppr_bndr :: OccName -> SDoc
638 -- Wrap operators in ()
639 ppr_bndr occ = parenSymOcc occ (ppr occ)
642 -----------------------------------------------------------------------------
645 addModule :: [FilePath] -> GHCi ()
647 io (revertCAFs) -- always revert CAFs on load/add.
648 files <- mapM expandPath files
649 targets <- mapM (io . GHC.guessTarget) files
650 session <- getSession
651 io (mapM_ (GHC.addTarget session) targets)
652 ok <- io (GHC.load session LoadAllTargets)
655 changeDirectory :: String -> GHCi ()
656 changeDirectory dir = do
657 session <- getSession
658 graph <- io (GHC.getModuleGraph session)
659 when (not (null graph)) $
660 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
661 io (GHC.setTargets session [])
662 io (GHC.load session LoadAllTargets)
663 setContextAfterLoad []
664 io (GHC.workingDirectoryChanged session)
665 dir <- expandPath dir
666 io (setCurrentDirectory dir)
668 defineMacro :: String -> GHCi ()
670 let (macro_name, definition) = break isSpace s
671 cmds <- io (readIORef commands)
673 then throwDyn (CmdLineError "invalid macro name")
675 if (macro_name `elem` map fst cmds)
676 then throwDyn (CmdLineError
677 ("command '" ++ macro_name ++ "' is already defined"))
680 -- give the expression a type signature, so we can be sure we're getting
681 -- something of the right type.
682 let new_expr = '(' : definition ++ ") :: String -> IO String"
684 -- compile the expression
686 maybe_hv <- io (GHC.compileExpr cms new_expr)
689 Just hv -> io (writeIORef commands --
690 ((macro_name, keepGoing (runMacro hv)) : cmds))
692 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
694 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
695 stringLoop (lines str)
697 undefineMacro :: String -> GHCi ()
698 undefineMacro macro_name = do
699 cmds <- io (readIORef commands)
700 if (macro_name `elem` map fst builtin_commands)
701 then throwDyn (CmdLineError
702 ("command '" ++ macro_name ++ "' cannot be undefined"))
704 if (macro_name `notElem` map fst cmds)
705 then throwDyn (CmdLineError
706 ("command '" ++ macro_name ++ "' not defined"))
708 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
711 loadModule :: [FilePath] -> GHCi ()
712 loadModule fs = timeIt (loadModule' fs)
714 loadModule' :: [FilePath] -> GHCi ()
715 loadModule' files = do
716 session <- getSession
719 io (GHC.setTargets session [])
720 io (GHC.load session LoadAllTargets)
723 files <- mapM expandPath files
724 targets <- io (mapM GHC.guessTarget files)
726 -- NOTE: we used to do the dependency anal first, so that if it
727 -- fails we didn't throw away the current set of modules. This would
728 -- require some re-working of the GHC interface, so we'll leave it
729 -- as a ToDo for now.
731 io (GHC.setTargets session targets)
732 ok <- io (GHC.load session LoadAllTargets)
736 reloadModule :: String -> GHCi ()
738 io (revertCAFs) -- always revert CAFs on reload.
739 session <- getSession
740 ok <- io (GHC.load session LoadAllTargets)
743 io (revertCAFs) -- always revert CAFs on reload.
744 session <- getSession
745 ok <- io (GHC.load session (LoadUpTo (mkModule m)))
748 afterLoad ok session = do
749 io (revertCAFs) -- always revert CAFs on load.
750 graph <- io (GHC.getModuleGraph session)
751 let mods = map GHC.ms_mod graph
752 mods' <- filterM (io . GHC.isLoaded session) mods
753 setContextAfterLoad mods'
754 modulesLoadedMsg ok mods'
756 setContextAfterLoad [] = do
757 session <- getSession
758 io (GHC.setContext session [] [prelude_mod])
759 setContextAfterLoad (m:_) = do
760 session <- getSession
761 b <- io (GHC.moduleIsInterpreted session m)
762 if b then io (GHC.setContext session [m] [])
763 else io (GHC.setContext session [] [m])
765 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
766 modulesLoadedMsg ok mods = do
767 dflags <- getDynFlags
768 when (verbosity dflags > 0) $ do
770 | null mods = text "none."
772 punctuate comma (map pprModule mods)) <> text "."
775 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
777 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
780 typeOfExpr :: String -> GHCi ()
782 = do cms <- getSession
783 maybe_ty <- io (GHC.exprType cms str)
786 Just ty -> do ty' <- cleanType ty
787 tystr <- showForUser (ppr ty')
788 io (putStrLn (str ++ " :: " ++ tystr))
790 kindOfType :: String -> GHCi ()
792 = do cms <- getSession
793 maybe_ty <- io (GHC.typeKind cms str)
796 Just ty -> do tystr <- showForUser (ppr ty)
797 io (putStrLn (str ++ " :: " ++ tystr))
799 quit :: String -> GHCi Bool
802 shellEscape :: String -> GHCi Bool
803 shellEscape str = io (system str >> return False)
805 -----------------------------------------------------------------------------
806 -- Browsing a module's contents
808 browseCmd :: String -> GHCi ()
811 ['*':m] | looksLikeModuleName m -> browseModule m False
812 [m] | looksLikeModuleName m -> browseModule m True
813 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
815 browseModule m exports_only = do
818 let modl = mkModule m
819 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
820 when (not is_interpreted && not exports_only) $
821 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
823 -- Temporarily set the context to the module we're interested in,
824 -- just so we can get an appropriate PrintUnqualified
825 (as,bs) <- io (GHC.getContext s)
826 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
827 else GHC.setContext s [modl] [])
828 io (GHC.setContext s as bs)
830 things <- io (GHC.browseModule s modl exports_only)
831 unqual <- io (GHC.getPrintUnqual s)
833 dflags <- getDynFlags
834 let exts = dopt Opt_GlasgowExts dflags
835 io (putStrLn (showSDocForUser unqual (
836 vcat (map (showDecl exts (const True)) things)
839 -----------------------------------------------------------------------------
840 -- Setting the module context
843 | all sensible mods = fn mods
844 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
846 (fn, mods) = case str of
847 '+':stuff -> (addToContext, words stuff)
848 '-':stuff -> (removeFromContext, words stuff)
849 stuff -> (newContext, words stuff)
851 sensible ('*':m) = looksLikeModuleName m
852 sensible m = looksLikeModuleName m
855 session <- getSession
856 (as,bs) <- separate session mods [] []
857 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
858 io (GHC.setContext session as bs')
860 separate :: Session -> [String] -> [Module] -> [Module]
861 -> GHCi ([Module],[Module])
862 separate session [] as bs = return (as,bs)
863 separate session (('*':m):ms) as bs = do
864 let modl = mkModule m
865 b <- io (GHC.moduleIsInterpreted session modl)
866 if b then separate session ms (modl:as) bs
867 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
868 separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
870 prelude_mod = mkModule "Prelude"
873 addToContext mods = do
875 (as,bs) <- io (GHC.getContext cms)
877 (as',bs') <- separate cms mods [] []
879 let as_to_add = as' \\ (as ++ bs)
880 bs_to_add = bs' \\ (as ++ bs)
882 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
885 removeFromContext mods = do
887 (as,bs) <- io (GHC.getContext cms)
889 (as_to_remove,bs_to_remove) <- separate cms mods [] []
891 let as' = as \\ (as_to_remove ++ bs_to_remove)
892 bs' = bs \\ (as_to_remove ++ bs_to_remove)
894 io (GHC.setContext cms as' bs')
896 ----------------------------------------------------------------------------
899 -- set options in the interpreter. Syntax is exactly the same as the
900 -- ghc command line, except that certain options aren't available (-C,
903 -- This is pretty fragile: most options won't work as expected. ToDo:
904 -- figure out which ones & disallow them.
906 setCmd :: String -> GHCi ()
908 = do st <- getGHCiState
909 let opts = options st
910 io $ putStrLn (showSDoc (
911 text "options currently set: " <>
914 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
918 ("args":args) -> setArgs args
919 ("prog":prog) -> setProg prog
920 wds -> setOptions wds
924 setGHCiState st{ args = args }
928 setGHCiState st{ progname = prog }
930 io (hPutStrLn stderr "syntax: :set prog <progname>")
933 do -- first, deal with the GHCi opts (+s, +t, etc.)
934 let (plus_opts, minus_opts) = partition isPlus wds
935 mapM_ setOpt plus_opts
937 -- then, dynamic flags
938 dflags <- getDynFlags
939 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
942 -- update things if the users wants more packages
944 let new_packages = pkgs_after \\ pkgs_before
945 when (not (null new_packages)) $
946 newPackages new_packages
949 if (not (null leftovers))
950 then throwDyn (CmdLineError ("unrecognised flags: " ++
955 unsetOptions :: String -> GHCi ()
957 = do -- first, deal with the GHCi opts (+s, +t, etc.)
959 (minus_opts, rest1) = partition isMinus opts
960 (plus_opts, rest2) = partition isPlus rest1
962 if (not (null rest2))
963 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
966 mapM_ unsetOpt plus_opts
968 -- can't do GHC flags for now
969 if (not (null minus_opts))
970 then throwDyn (CmdLineError "can't unset GHC command-line flags")
973 isMinus ('-':s) = True
976 isPlus ('+':s) = True
980 = case strToGHCiOpt str of
981 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
982 Just o -> setOption o
985 = case strToGHCiOpt str of
986 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
987 Just o -> unsetOption o
989 strToGHCiOpt :: String -> (Maybe GHCiOption)
990 strToGHCiOpt "s" = Just ShowTiming
991 strToGHCiOpt "t" = Just ShowType
992 strToGHCiOpt "r" = Just RevertCAFs
993 strToGHCiOpt _ = Nothing
995 optToStr :: GHCiOption -> String
996 optToStr ShowTiming = "s"
997 optToStr ShowType = "t"
998 optToStr RevertCAFs = "r"
1001 newPackages new_pkgs = do -- The new packages are already in v_Packages
1002 session <- getSession
1003 io (GHC.setTargets session [])
1004 io (GHC.load session Nothing)
1005 dflags <- getDynFlags
1006 io (linkPackages dflags new_pkgs)
1007 setContextAfterLoad []
1010 -- ---------------------------------------------------------------------------
1015 ["modules" ] -> showModules
1016 ["bindings"] -> showBindings
1017 ["linker"] -> io showLinkerState
1018 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1021 session <- getSession
1022 let show_one ms = do m <- io (GHC.showModule session ms)
1024 graph <- io (GHC.getModuleGraph session)
1025 mapM_ show_one graph
1029 unqual <- io (GHC.getPrintUnqual s)
1030 bindings <- io (GHC.getBindings s)
1031 mapM_ showTyThing bindings
1034 showTyThing (AnId id) = do
1035 ty' <- cleanType (GHC.idType id)
1036 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1038 showTyThing _ = return ()
1040 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1041 cleanType :: Type -> GHCi Type
1043 dflags <- getDynFlags
1044 if dopt Opt_GlasgowExts dflags
1046 else return $! GHC.dropForAlls ty
1048 -----------------------------------------------------------------------------
1051 data GHCiState = GHCiState
1055 session :: GHC.Session,
1056 options :: [GHCiOption]
1060 = ShowTiming -- show time/allocs after evaluation
1061 | ShowType -- show the type of expressions
1062 | RevertCAFs -- revert CAFs after every evaluation
1065 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1067 startGHCi :: GHCi a -> GHCiState -> IO a
1068 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1070 instance Monad GHCi where
1071 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1072 return a = GHCi $ \s -> return a
1074 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1075 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1076 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1078 getGHCiState = GHCi $ \r -> readIORef r
1079 setGHCiState s = GHCi $ \r -> writeIORef r s
1081 -- for convenience...
1082 getSession = getGHCiState >>= return . session
1086 io (GHC.getSessionDynFlags s)
1087 setDynFlags dflags = do
1089 io (GHC.setSessionDynFlags s dflags)
1091 isOptionSet :: GHCiOption -> GHCi Bool
1093 = do st <- getGHCiState
1094 return (opt `elem` options st)
1096 setOption :: GHCiOption -> GHCi ()
1098 = do st <- getGHCiState
1099 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1101 unsetOption :: GHCiOption -> GHCi ()
1103 = do st <- getGHCiState
1104 setGHCiState (st{ options = filter (/= opt) (options st) })
1106 io :: IO a -> GHCi a
1107 io m = GHCi { unGHCi = \s -> m >>= return }
1109 -----------------------------------------------------------------------------
1110 -- recursive exception handlers
1112 -- Don't forget to unblock async exceptions in the handler, or if we're
1113 -- in an exception loop (eg. let a = error a in a) the ^C exception
1114 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1116 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1117 ghciHandle h (GHCi m) = GHCi $ \s ->
1118 Exception.catch (m s)
1119 (\e -> unGHCi (ghciUnblock (h e)) s)
1121 ghciUnblock :: GHCi a -> GHCi a
1122 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1124 -----------------------------------------------------------------------------
1125 -- timing & statistics
1127 timeIt :: GHCi a -> GHCi a
1129 = do b <- isOptionSet ShowTiming
1132 else do allocs1 <- io $ getAllocations
1133 time1 <- io $ getCPUTime
1135 allocs2 <- io $ getAllocations
1136 time2 <- io $ getCPUTime
1137 io $ printTimes (fromIntegral (allocs2 - allocs1))
1141 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1142 -- defined in ghc/rts/Stats.c
1144 printTimes :: Integer -> Integer -> IO ()
1145 printTimes allocs psecs
1146 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1147 secs_str = showFFloat (Just 2) secs
1148 putStrLn (showSDoc (
1149 parens (text (secs_str "") <+> text "secs" <> comma <+>
1150 text (show allocs) <+> text "bytes")))
1152 -----------------------------------------------------------------------------
1159 -- Have to turn off buffering again, because we just
1160 -- reverted stdout, stderr & stdin to their defaults.
1162 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1163 -- Make it "safe", just in case
1165 -- -----------------------------------------------------------------------------
1168 expandPath :: String -> GHCi String
1170 case dropWhile isSpace path of
1172 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1173 return (tilde ++ '/':d)