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})
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, context, cs) = case condecls of
597 IfAbstractTyCon -> (ptext SLIT("data"), [], [])
598 IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs)
599 IfDataTyCon Nothing cs -> (ptext SLIT("data"), [], cs)
600 IfNewTyCon c -> (ptext SLIT("newtype"), [], [c])
603 add_bars [c] = equals <+> c
604 add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
606 ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
607 ppr_str MarkedStrict = char '!'
608 ppr_str MarkedUnboxed = ptext SLIT("!!")
609 ppr_str NotMarkedStrict = empty
611 showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
612 ifFDs = fds, ifSigs = sigs})
613 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
614 <+> pprFundeps fds <+> opt_where)
615 2 (vcat (ppr_trim show_op sigs))
617 opt_where | null sigs = empty
618 | otherwise = ptext SLIT("where")
619 show_op (IfaceClassOp op dm ty)
620 | want_name clas || want_name op
621 = Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty)
625 showIfaceType :: Bool -> IfaceType -> SDoc
626 showIfaceType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
627 showIfaceType False ty = ppr ty -- otherwise, print without the foralls
629 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
631 = snd (foldr go (False, []) xs)
633 go x (eliding, so_far)
634 | Just doc <- show x = (False, doc : so_far)
635 | otherwise = if eliding then (True, so_far)
636 else (True, ptext SLIT("...") : so_far)
638 ppr_bndr :: OccName -> SDoc
639 -- Wrap operators in ()
640 ppr_bndr occ = parenSymOcc occ (ppr occ)
643 -----------------------------------------------------------------------------
646 addModule :: [FilePath] -> GHCi ()
648 io (revertCAFs) -- always revert CAFs on load/add.
649 files <- mapM expandPath files
650 targets <- mapM (io . GHC.guessTarget) files
651 session <- getSession
652 io (mapM_ (GHC.addTarget session) targets)
653 ok <- io (GHC.load session LoadAllTargets)
656 changeDirectory :: String -> GHCi ()
657 changeDirectory dir = do
658 session <- getSession
659 graph <- io (GHC.getModuleGraph session)
660 when (not (null graph)) $
661 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
662 io (GHC.setTargets session [])
663 io (GHC.load session LoadAllTargets)
664 setContextAfterLoad []
665 io (GHC.workingDirectoryChanged session)
666 dir <- expandPath dir
667 io (setCurrentDirectory dir)
669 defineMacro :: String -> GHCi ()
671 let (macro_name, definition) = break isSpace s
672 cmds <- io (readIORef commands)
674 then throwDyn (CmdLineError "invalid macro name")
676 if (macro_name `elem` map fst cmds)
677 then throwDyn (CmdLineError
678 ("command '" ++ macro_name ++ "' is already defined"))
681 -- give the expression a type signature, so we can be sure we're getting
682 -- something of the right type.
683 let new_expr = '(' : definition ++ ") :: String -> IO String"
685 -- compile the expression
687 maybe_hv <- io (GHC.compileExpr cms new_expr)
690 Just hv -> io (writeIORef commands --
691 ((macro_name, keepGoing (runMacro hv)) : cmds))
693 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
695 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
696 stringLoop (lines str)
698 undefineMacro :: String -> GHCi ()
699 undefineMacro macro_name = do
700 cmds <- io (readIORef commands)
701 if (macro_name `elem` map fst builtin_commands)
702 then throwDyn (CmdLineError
703 ("command '" ++ macro_name ++ "' cannot be undefined"))
705 if (macro_name `notElem` map fst cmds)
706 then throwDyn (CmdLineError
707 ("command '" ++ macro_name ++ "' not defined"))
709 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
712 loadModule :: [FilePath] -> GHCi ()
713 loadModule fs = timeIt (loadModule' fs)
715 loadModule' :: [FilePath] -> GHCi ()
716 loadModule' files = do
717 session <- getSession
720 io (GHC.setTargets session [])
721 io (GHC.load session LoadAllTargets)
724 files <- mapM expandPath files
725 targets <- io (mapM GHC.guessTarget files)
727 -- NOTE: we used to do the dependency anal first, so that if it
728 -- fails we didn't throw away the current set of modules. This would
729 -- require some re-working of the GHC interface, so we'll leave it
730 -- as a ToDo for now.
732 io (GHC.setTargets session targets)
733 ok <- io (GHC.load session LoadAllTargets)
737 reloadModule :: String -> GHCi ()
739 io (revertCAFs) -- always revert CAFs on reload.
740 session <- getSession
741 ok <- io (GHC.load session LoadAllTargets)
744 io (revertCAFs) -- always revert CAFs on reload.
745 session <- getSession
746 ok <- io (GHC.load session (LoadUpTo (mkModule m)))
749 afterLoad ok session = do
750 io (revertCAFs) -- always revert CAFs on load.
751 graph <- io (GHC.getModuleGraph session)
752 let mods = map GHC.ms_mod graph
753 mods' <- filterM (io . GHC.isLoaded session) mods
754 setContextAfterLoad mods'
755 modulesLoadedMsg ok mods'
757 setContextAfterLoad [] = do
758 session <- getSession
759 io (GHC.setContext session [] [prelude_mod])
760 setContextAfterLoad (m:_) = do
761 session <- getSession
762 b <- io (GHC.moduleIsInterpreted session m)
763 if b then io (GHC.setContext session [m] [])
764 else io (GHC.setContext session [] [m])
766 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
767 modulesLoadedMsg ok mods = do
768 dflags <- getDynFlags
769 when (verbosity dflags > 0) $ do
771 | null mods = text "none."
773 punctuate comma (map pprModule mods)) <> text "."
776 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
778 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
781 typeOfExpr :: String -> GHCi ()
783 = do cms <- getSession
784 maybe_ty <- io (GHC.exprType cms str)
787 Just ty -> do ty' <- cleanType ty
788 tystr <- showForUser (ppr ty')
789 io (putStrLn (str ++ " :: " ++ tystr))
791 kindOfType :: String -> GHCi ()
793 = do cms <- getSession
794 maybe_ty <- io (GHC.typeKind cms str)
797 Just ty -> do tystr <- showForUser (ppr ty)
798 io (putStrLn (str ++ " :: " ++ tystr))
800 quit :: String -> GHCi Bool
803 shellEscape :: String -> GHCi Bool
804 shellEscape str = io (system str >> return False)
806 -----------------------------------------------------------------------------
807 -- Browsing a module's contents
809 browseCmd :: String -> GHCi ()
812 ['*':m] | looksLikeModuleName m -> browseModule m False
813 [m] | looksLikeModuleName m -> browseModule m True
814 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
816 browseModule m exports_only = do
819 let modl = mkModule m
820 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
821 when (not is_interpreted && not exports_only) $
822 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
824 -- Temporarily set the context to the module we're interested in,
825 -- just so we can get an appropriate PrintUnqualified
826 (as,bs) <- io (GHC.getContext s)
827 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
828 else GHC.setContext s [modl] [])
829 io (GHC.setContext s as bs)
831 things <- io (GHC.browseModule s modl exports_only)
832 unqual <- io (GHC.getPrintUnqual s)
834 dflags <- getDynFlags
835 let exts = dopt Opt_GlasgowExts dflags
836 io (putStrLn (showSDocForUser unqual (
837 vcat (map (showDecl exts (const True)) things)
840 -----------------------------------------------------------------------------
841 -- Setting the module context
844 | all sensible mods = fn mods
845 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
847 (fn, mods) = case str of
848 '+':stuff -> (addToContext, words stuff)
849 '-':stuff -> (removeFromContext, words stuff)
850 stuff -> (newContext, words stuff)
852 sensible ('*':m) = looksLikeModuleName m
853 sensible m = looksLikeModuleName m
856 session <- getSession
857 (as,bs) <- separate session mods [] []
858 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
859 io (GHC.setContext session as bs')
861 separate :: Session -> [String] -> [Module] -> [Module]
862 -> GHCi ([Module],[Module])
863 separate session [] as bs = return (as,bs)
864 separate session (('*':m):ms) as bs = do
865 let modl = mkModule m
866 b <- io (GHC.moduleIsInterpreted session modl)
867 if b then separate session ms (modl:as) bs
868 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
869 separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
871 prelude_mod = mkModule "Prelude"
874 addToContext mods = do
876 (as,bs) <- io (GHC.getContext cms)
878 (as',bs') <- separate cms mods [] []
880 let as_to_add = as' \\ (as ++ bs)
881 bs_to_add = bs' \\ (as ++ bs)
883 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
886 removeFromContext mods = do
888 (as,bs) <- io (GHC.getContext cms)
890 (as_to_remove,bs_to_remove) <- separate cms mods [] []
892 let as' = as \\ (as_to_remove ++ bs_to_remove)
893 bs' = bs \\ (as_to_remove ++ bs_to_remove)
895 io (GHC.setContext cms as' bs')
897 ----------------------------------------------------------------------------
900 -- set options in the interpreter. Syntax is exactly the same as the
901 -- ghc command line, except that certain options aren't available (-C,
904 -- This is pretty fragile: most options won't work as expected. ToDo:
905 -- figure out which ones & disallow them.
907 setCmd :: String -> GHCi ()
909 = do st <- getGHCiState
910 let opts = options st
911 io $ putStrLn (showSDoc (
912 text "options currently set: " <>
915 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
919 ("args":args) -> setArgs args
920 ("prog":prog) -> setProg prog
921 wds -> setOptions wds
925 setGHCiState st{ args = args }
929 setGHCiState st{ progname = prog }
931 io (hPutStrLn stderr "syntax: :set prog <progname>")
934 do -- first, deal with the GHCi opts (+s, +t, etc.)
935 let (plus_opts, minus_opts) = partition isPlus wds
936 mapM_ setOpt plus_opts
938 -- then, dynamic flags
939 dflags <- getDynFlags
940 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
943 -- update things if the users wants more packages
945 let new_packages = pkgs_after \\ pkgs_before
946 when (not (null new_packages)) $
947 newPackages new_packages
950 if (not (null leftovers))
951 then throwDyn (CmdLineError ("unrecognised flags: " ++
956 unsetOptions :: String -> GHCi ()
958 = do -- first, deal with the GHCi opts (+s, +t, etc.)
960 (minus_opts, rest1) = partition isMinus opts
961 (plus_opts, rest2) = partition isPlus rest1
963 if (not (null rest2))
964 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
967 mapM_ unsetOpt plus_opts
969 -- can't do GHC flags for now
970 if (not (null minus_opts))
971 then throwDyn (CmdLineError "can't unset GHC command-line flags")
974 isMinus ('-':s) = True
977 isPlus ('+':s) = True
981 = case strToGHCiOpt str of
982 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
983 Just o -> setOption o
986 = case strToGHCiOpt str of
987 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
988 Just o -> unsetOption o
990 strToGHCiOpt :: String -> (Maybe GHCiOption)
991 strToGHCiOpt "s" = Just ShowTiming
992 strToGHCiOpt "t" = Just ShowType
993 strToGHCiOpt "r" = Just RevertCAFs
994 strToGHCiOpt _ = Nothing
996 optToStr :: GHCiOption -> String
997 optToStr ShowTiming = "s"
998 optToStr ShowType = "t"
999 optToStr RevertCAFs = "r"
1002 newPackages new_pkgs = do -- The new packages are already in v_Packages
1003 session <- getSession
1004 io (GHC.setTargets session [])
1005 io (GHC.load session Nothing)
1006 dflags <- getDynFlags
1007 io (linkPackages dflags new_pkgs)
1008 setContextAfterLoad []
1011 -- ---------------------------------------------------------------------------
1016 ["modules" ] -> showModules
1017 ["bindings"] -> showBindings
1018 ["linker"] -> io showLinkerState
1019 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1022 session <- getSession
1023 let show_one ms = do m <- io (GHC.showModule session ms)
1025 graph <- io (GHC.getModuleGraph session)
1026 mapM_ show_one graph
1030 unqual <- io (GHC.getPrintUnqual s)
1031 bindings <- io (GHC.getBindings s)
1032 mapM_ showTyThing bindings
1035 showTyThing (AnId id) = do
1036 ty' <- cleanType (GHC.idType id)
1037 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1039 showTyThing _ = return ()
1041 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1042 cleanType :: Type -> GHCi Type
1044 dflags <- getDynFlags
1045 if dopt Opt_GlasgowExts dflags
1047 else return $! GHC.dropForAlls ty
1049 -----------------------------------------------------------------------------
1052 data GHCiState = GHCiState
1056 session :: GHC.Session,
1057 options :: [GHCiOption]
1061 = ShowTiming -- show time/allocs after evaluation
1062 | ShowType -- show the type of expressions
1063 | RevertCAFs -- revert CAFs after every evaluation
1066 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1068 startGHCi :: GHCi a -> GHCiState -> IO a
1069 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1071 instance Monad GHCi where
1072 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1073 return a = GHCi $ \s -> return a
1075 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1076 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1077 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1079 getGHCiState = GHCi $ \r -> readIORef r
1080 setGHCiState s = GHCi $ \r -> writeIORef r s
1082 -- for convenience...
1083 getSession = getGHCiState >>= return . session
1087 io (GHC.getSessionDynFlags s)
1088 setDynFlags dflags = do
1090 io (GHC.setSessionDynFlags s dflags)
1092 isOptionSet :: GHCiOption -> GHCi Bool
1094 = do st <- getGHCiState
1095 return (opt `elem` options st)
1097 setOption :: GHCiOption -> GHCi ()
1099 = do st <- getGHCiState
1100 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1102 unsetOption :: GHCiOption -> GHCi ()
1104 = do st <- getGHCiState
1105 setGHCiState (st{ options = filter (/= opt) (options st) })
1107 io :: IO a -> GHCi a
1108 io m = GHCi { unGHCi = \s -> m >>= return }
1110 -----------------------------------------------------------------------------
1111 -- recursive exception handlers
1113 -- Don't forget to unblock async exceptions in the handler, or if we're
1114 -- in an exception loop (eg. let a = error a in a) the ^C exception
1115 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1117 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1118 ghciHandle h (GHCi m) = GHCi $ \s ->
1119 Exception.catch (m s)
1120 (\e -> unGHCi (ghciUnblock (h e)) s)
1122 ghciUnblock :: GHCi a -> GHCi a
1123 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1125 -----------------------------------------------------------------------------
1126 -- timing & statistics
1128 timeIt :: GHCi a -> GHCi a
1130 = do b <- isOptionSet ShowTiming
1133 else do allocs1 <- io $ getAllocations
1134 time1 <- io $ getCPUTime
1136 allocs2 <- io $ getAllocations
1137 time2 <- io $ getCPUTime
1138 io $ printTimes (fromIntegral (allocs2 - allocs1))
1142 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1143 -- defined in ghc/rts/Stats.c
1145 printTimes :: Integer -> Integer -> IO ()
1146 printTimes allocs psecs
1147 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1148 secs_str = showFFloat (Just 2) secs
1149 putStrLn (showSDoc (
1150 parens (text (secs_str "") <+> text "secs" <> comma <+>
1151 text (show allocs) <+> text "bytes")))
1153 -----------------------------------------------------------------------------
1160 -- Have to turn off buffering again, because we just
1161 -- reverted stdout, stderr & stdin to their defaults.
1163 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1164 -- Make it "safe", just in case
1166 -- -----------------------------------------------------------------------------
1169 expandPath :: String -> GHCi String
1171 case dropWhile isSpace path of
1173 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1174 return (tilde ++ '/':d)