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(..),
23 -- following all needed for :info... ToDo: remove
24 import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
25 IfaceConDecl(..), IfaceType,
26 pprIfaceDeclHead, pprParendIfaceType,
27 pprIfaceForAllPart, pprIfaceType )
28 import FunDeps ( pprFundeps )
29 import SrcLoc ( SrcLoc, isGoodSrcLoc )
30 import OccName ( OccName, parenSymOcc, occNameUserString )
31 import BasicTypes ( StrictnessMark(..), defaultFixity )
33 -- Other random utilities
34 import Panic hiding ( showException )
36 import StaticFlags ( opt_IgnoreDotGhci )
37 import Linker ( showLinkerState )
38 import Util ( removeSpaces, handle, global, toArgs,
39 looksLikeModuleName, prefixMatch )
41 #ifndef mingw32_HOST_OS
42 import Util ( handle )
44 #if __GLASGOW_HASKELL__ > 504
50 import Control.Concurrent ( yield ) -- Used in readline loop
51 import System.Console.Readline as Readline
56 import Control.Exception as Exception
58 -- import Control.Concurrent
62 import Data.Int ( Int64 )
65 import System.Environment
66 import System.Exit ( exitWith, ExitCode(..) )
67 import System.Directory
69 import System.IO.Error as IO
71 import Control.Monad as Monad
72 import Foreign.StablePtr ( newStablePtr )
74 import GHC.Exts ( unsafeCoerce# )
75 import GHC.IOBase ( IOErrorType(InvalidArgument) )
77 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
79 import System.Posix.Internals ( setNonBlockingFD )
81 -----------------------------------------------------------------------------
85 " / _ \\ /\\ /\\/ __(_)\n"++
86 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
87 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
88 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
90 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
92 builtin_commands :: [(String, String -> GHCi Bool)]
94 ("add", keepGoingPaths addModule),
95 ("browse", keepGoing browseCmd),
96 ("cd", keepGoing changeDirectory),
97 ("def", keepGoing defineMacro),
98 ("help", keepGoing help),
99 ("?", keepGoing help),
100 ("info", keepGoing info),
101 ("load", keepGoingPaths loadModule),
102 ("module", keepGoing setContext),
103 ("reload", keepGoing reloadModule),
104 ("set", keepGoing setCmd),
105 ("show", keepGoing showCmd),
106 ("type", keepGoing typeOfExpr),
107 ("kind", keepGoing kindOfType),
108 ("unset", keepGoing unsetOptions),
109 ("undef", keepGoing undefineMacro),
113 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
114 keepGoing a str = a str >> return False
116 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
117 keepGoingPaths a str = a (toArgs str) >> return False
119 shortHelpText = "use :? for help.\n"
121 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
123 " Commands available from the prompt:\n" ++
125 " <stmt> evaluate/run <stmt>\n" ++
126 " :add <filename> ... add module(s) to the current target set\n" ++
127 " :browse [*]<module> display the names defined by <module>\n" ++
128 " :cd <dir> change directory to <dir>\n" ++
129 " :def <cmd> <expr> define a command :<cmd>\n" ++
130 " :help, :? display this list of commands\n" ++
131 " :info [<name> ...] display information about the given names\n" ++
132 " :load <filename> ... load module(s) and their dependents\n" ++
133 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
134 " :reload reload the current module set\n" ++
136 " :set <option> ... set options\n" ++
137 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
138 " :set prog <progname> set the value returned by System.getProgName\n" ++
140 " :show modules show the currently loaded modules\n" ++
141 " :show bindings show the current bindings made at the prompt\n" ++
143 " :type <expr> show the type of <expr>\n" ++
144 " :kind <type> show the kind of <type>\n" ++
145 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
146 " :unset <option> ... unset options\n" ++
147 " :quit exit GHCi\n" ++
148 " :!<command> run the shell command <command>\n" ++
150 " Options for ':set' and ':unset':\n" ++
152 " +r revert top-level expressions after each evaluation\n" ++
153 " +s print timing/memory stats after each evaluation\n" ++
154 " +t print type after evaluation\n" ++
155 " -<flags> most GHC command line flags can also be set here\n" ++
156 " (eg. -v2, -fglasgow-exts, etc.)\n"
159 interactiveUI :: Session -> [FilePath] -> Maybe String -> IO ()
160 interactiveUI session srcs maybe_expr = do
162 -- HACK! If we happen to get into an infinite loop (eg the user
163 -- types 'let x=x in x' at the prompt), then the thread will block
164 -- on a blackhole, and become unreachable during GC. The GC will
165 -- detect that it is unreachable and send it the NonTermination
166 -- exception. However, since the thread is unreachable, everything
167 -- it refers to might be finalized, including the standard Handles.
168 -- This sounds like a bug, but we don't have a good solution right
175 hSetBuffering stdout NoBuffering
177 -- Initialise buffering for the *interpreted* I/O system
178 initInterpBuffering session
180 -- We don't want the cmd line to buffer any input that might be
181 -- intended for the program, so unbuffer stdin.
182 hSetBuffering stdin NoBuffering
184 -- initial context is just the Prelude
185 GHC.setContext session [] [prelude_mod]
191 startGHCi (runGHCi srcs maybe_expr)
192 GHCiState{ progname = "<interactive>",
198 Readline.resetTerminal Nothing
203 runGHCi :: [FilePath] -> Maybe String -> GHCi ()
204 runGHCi paths maybe_expr = do
205 let read_dot_files = not opt_IgnoreDotGhci
207 when (read_dot_files) $ do
210 exists <- io (doesFileExist file)
212 dir_ok <- io (checkPerms ".")
213 file_ok <- io (checkPerms file)
214 when (dir_ok && file_ok) $ do
215 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
218 Right hdl -> fileLoop hdl False
220 when (read_dot_files) $ do
221 -- Read in $HOME/.ghci
222 either_dir <- io (IO.try (getEnv "HOME"))
226 cwd <- io (getCurrentDirectory)
227 when (dir /= cwd) $ do
228 let file = dir ++ "/.ghci"
229 ok <- io (checkPerms file)
231 either_hdl <- io (IO.try (openFile file ReadMode))
234 Right hdl -> fileLoop hdl False
236 -- Perform a :load for files given on the GHCi command line
237 when (not (null paths)) $
238 ghciHandle showException $
241 -- if verbosity is greater than 0, or we are connected to a
242 -- terminal, display the prompt in the interactive loop.
243 is_tty <- io (hIsTerminalDevice stdin)
244 dflags <- getDynFlags
245 let show_prompt = verbosity dflags > 0 || is_tty
249 -- enter the interactive loop
250 interactiveLoop is_tty show_prompt
252 -- just evaluate the expression we were given
257 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
260 interactiveLoop is_tty show_prompt = do
261 -- Ignore ^C exceptions caught here
262 ghciHandleDyn (\e -> case e of
263 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
264 _other -> return ()) $ do
266 -- read commands from stdin
270 else fileLoop stdin show_prompt
272 fileLoop stdin show_prompt
276 -- NOTE: We only read .ghci files if they are owned by the current user,
277 -- and aren't world writable. Otherwise, we could be accidentally
278 -- running code planted by a malicious third party.
280 -- Furthermore, We only read ./.ghci if . is owned by the current user
281 -- and isn't writable by anyone else. I think this is sufficient: we
282 -- don't need to check .. and ../.. etc. because "." always refers to
283 -- the same directory while a process is running.
285 checkPerms :: String -> IO Bool
287 #ifdef mingw32_HOST_OS
290 Util.handle (\_ -> return False) $ do
291 st <- getFileStatus name
293 if fileOwner st /= me then do
294 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
297 let mode = fileMode st
298 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
299 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
301 putStrLn $ "*** WARNING: " ++ name ++
302 " is writable by someone else, IGNORING!"
307 fileLoop :: Handle -> Bool -> GHCi ()
308 fileLoop hdl prompt = do
309 session <- getSession
310 (mod,imports) <- io (GHC.getContext session)
311 when prompt (io (putStr (mkPrompt mod imports)))
312 l <- io (IO.try (hGetLine hdl))
314 Left e | isEOFError e -> return ()
315 | InvalidArgument <- etype -> return ()
316 | otherwise -> io (ioError e)
317 where etype = ioeGetErrorType e
318 -- treat InvalidArgument in the same way as EOF:
319 -- this can happen if the user closed stdin, or
320 -- perhaps did getContents which closes stdin at
323 case removeSpaces l of
324 "" -> fileLoop hdl prompt
325 l -> do quit <- runCommand l
326 if quit then return () else fileLoop hdl prompt
328 stringLoop :: [String] -> GHCi ()
329 stringLoop [] = return ()
330 stringLoop (s:ss) = do
331 case removeSpaces s of
333 l -> do quit <- runCommand l
334 if quit then return () else stringLoop ss
336 mkPrompt toplevs exports
337 = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
338 <+> hsep (map pprModule exports)
342 readlineLoop :: GHCi ()
344 session <- getSession
345 (mod,imports) <- io (GHC.getContext session)
347 l <- io (readline (mkPrompt mod imports)
348 `finally` setNonBlockingFD 0)
349 -- readline sometimes puts stdin into blocking mode,
350 -- so we need to put it back for the IO library
354 case removeSpaces l of
359 if quit then return () else readlineLoop
362 runCommand :: String -> GHCi Bool
363 runCommand c = ghciHandle handler (doCommand c)
365 -- This version is for the GHC command-line option -e. The only difference
366 -- from runCommand is that it catches the ExitException exception and
367 -- exits, rather than printing out the exception.
368 runCommandEval c = ghciHandle handleEval (doCommand c)
370 handleEval (ExitException code) = io (exitWith code)
371 handleEval e = do showException e
372 io (exitWith (ExitFailure 1))
374 -- This is the exception handler for exceptions generated by the
375 -- user's code; it normally just prints out the exception. The
376 -- handler must be recursive, in case showing the exception causes
377 -- more exceptions to be raised.
379 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
380 -- raising another exception. We therefore don't put the recursive
381 -- handler arond the flushing operation, so if stderr is closed
382 -- GHCi will just die gracefully rather than going into an infinite loop.
383 handler :: Exception -> GHCi Bool
384 handler exception = do
386 io installSignalHandlers
387 ghciHandle handler (showException exception >> return False)
389 showException (DynException dyn) =
390 case fromDynamic dyn of
391 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
392 Just Interrupted -> io (putStrLn "Interrupted.")
393 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
394 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
395 Just other_ghc_ex -> io (print other_ghc_ex)
397 showException other_exception
398 = io (putStrLn ("*** Exception: " ++ show other_exception))
400 doCommand (':' : command) = specialCommand command
402 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
405 runStmt :: String -> GHCi [Name]
407 | null (filter (not.isSpace) stmt) = return []
409 = do st <- getGHCiState
410 session <- getSession
411 result <- io $ withProgName (progname st) $ withArgs (args st) $
412 GHC.runStmt session stmt
414 GHC.RunFailed -> return []
415 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
416 GHC.RunOk names -> return names
418 -- possibly print the type and revert CAFs after evaluating an expression
420 = do b <- isOptionSet ShowType
421 session <- getSession
422 when b (mapM_ (showTypeOfName session) names)
425 io installSignalHandlers
426 b <- isOptionSet RevertCAFs
427 io (when b revertCAFs)
430 showTypeOfName :: Session -> Name -> GHCi ()
431 showTypeOfName session n
432 = do maybe_tything <- io (GHC.lookupName session n)
433 case maybe_tything of
435 Just thing -> showTyThing thing
437 showForUser :: SDoc -> GHCi String
439 session <- getSession
440 unqual <- io (GHC.getPrintUnqual session)
441 return $! showSDocForUser unqual doc
443 specialCommand :: String -> GHCi Bool
444 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
445 specialCommand str = do
446 let (cmd,rest) = break isSpace str
447 cmds <- io (readIORef commands)
448 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
449 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
450 ++ shortHelpText) >> return False)
451 [(_,f)] -> f (dropWhile isSpace rest)
452 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
453 " matches multiple commands (" ++
454 foldr1 (\a b -> a ++ ',':b) (map fst cs)
455 ++ ")") >> return False)
457 noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
460 -----------------------------------------------------------------------------
461 -- To flush buffers for the *interpreted* computation we need
462 -- to refer to *its* stdout/stderr handles
464 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
465 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
467 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
468 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
469 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
471 initInterpBuffering :: Session -> IO ()
472 initInterpBuffering session
473 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
476 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
477 other -> panic "interactiveUI:setBuffering"
479 maybe_hval <- GHC.compileExpr session flush_cmd
481 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
482 _ -> panic "interactiveUI:flush"
484 turnOffBuffering -- Turn it off right now
489 flushInterpBuffers :: GHCi ()
491 = io $ do Monad.join (readIORef flush_interp)
494 turnOffBuffering :: IO ()
496 = do Monad.join (readIORef turn_off_buffering)
499 -----------------------------------------------------------------------------
502 help :: String -> GHCi ()
503 help _ = io (putStr helpText)
505 info :: String -> GHCi ()
506 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
507 info s = do { let names = words s
508 ; session <- getSession
509 ; dflags <- getDynFlags
510 ; let exts = dopt Opt_GlasgowExts dflags
511 ; mapM_ (infoThing exts session) names }
513 infoThing exts session name
514 = do { stuff <- io (GHC.getInfo session name)
515 ; unqual <- io (GHC.getPrintUnqual session)
516 ; io (putStrLn (showSDocForUser unqual $
517 vcat (intersperse (text "") (map (showThing exts) stuff)))) }
519 showThing :: Bool -> GHC.GetInfoResult -> SDoc
520 showThing exts (wanted_str, thing, fixity, src_loc, insts)
521 = vcat [ showWithLoc src_loc (showDecl exts want_name thing),
523 vcat (map show_inst insts)]
525 want_name occ = wanted_str == occNameUserString occ
528 | fix == defaultFixity = empty
529 | otherwise = ppr fix <+> text wanted_str
531 show_inst (inst_ty, loc)
532 = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty)
534 showWithLoc :: SrcLoc -> SDoc -> SDoc
536 = hang doc 2 (char '\t' <> show_loc loc)
537 -- The tab tries to make them line up a bit
539 show_loc loc -- The ppr function for SrcLocs is a bit wonky
540 | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
541 | otherwise = comment <+> ppr loc
542 comment = ptext SLIT("--")
545 -- Now there is rather a lot of goop just to print declarations in a
546 -- civilised way with "..." for the parts we are less interested in.
548 showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc
549 showDecl exts want_name (IfaceForeign {ifName = tc})
550 = ppr tc <+> ptext SLIT("is a foreign type")
552 showDecl exts want_name (IfaceId {ifName = var, ifType = ty})
553 = ppr var <+> dcolon <+> showIfaceType exts ty
555 showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
556 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
557 2 (equals <+> ppr mono_ty)
559 showDecl exts want_name (IfaceData {ifName = tycon,
560 ifTyVars = tyvars, ifCons = condecls})
561 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
562 2 (add_bars (ppr_trim show_con cs))
564 show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
565 ifConStricts = strs, ifConFields = flds})
566 | want_name tycon || want_name con_name || any want_name flds
567 = Just (show_guts con_name is_infix tys_w_strs flds)
568 | otherwise = Nothing
570 tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
571 show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
572 ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
573 | want_name tycon || want_name con_name
574 = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
575 | otherwise = Nothing
577 tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
578 pp_tau = foldr add pp_res_ty tys_w_strs
579 pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
580 add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
582 show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
583 show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
584 show_guts con _ tys flds
585 = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
587 show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
588 = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
589 | otherwise = Nothing
591 (pp_nd, context, cs) = case condecls of
592 IfAbstractTyCon -> (ptext SLIT("data"), [], [])
593 IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs)
594 IfDataTyCon Nothing cs -> (ptext SLIT("data"), [], cs)
595 IfNewTyCon c -> (ptext SLIT("newtype"), [], [c])
598 add_bars [c] = equals <+> c
599 add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
601 ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
602 ppr_str MarkedStrict = char '!'
603 ppr_str MarkedUnboxed = ptext SLIT("!!")
604 ppr_str NotMarkedStrict = empty
606 showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
607 ifFDs = fds, ifSigs = sigs})
608 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
609 <+> pprFundeps fds <+> opt_where)
610 2 (vcat (ppr_trim show_op sigs))
612 opt_where | null sigs = empty
613 | otherwise = ptext SLIT("where")
614 show_op (IfaceClassOp op dm ty)
615 | want_name clas || want_name op
616 = Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty)
620 showIfaceType :: Bool -> IfaceType -> SDoc
621 showIfaceType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
622 showIfaceType False ty = ppr ty -- otherwise, print without the foralls
624 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
626 = snd (foldr go (False, []) xs)
628 go x (eliding, so_far)
629 | Just doc <- show x = (False, doc : so_far)
630 | otherwise = if eliding then (True, so_far)
631 else (True, ptext SLIT("...") : so_far)
633 ppr_bndr :: OccName -> SDoc
634 -- Wrap operators in ()
635 ppr_bndr occ = parenSymOcc occ (ppr occ)
638 -----------------------------------------------------------------------------
641 addModule :: [FilePath] -> GHCi ()
643 io (revertCAFs) -- always revert CAFs on load/add.
644 files <- mapM expandPath files
645 targets <- mapM (io . GHC.guessTarget) files
646 session <- getSession
647 io (mapM_ (GHC.addTarget session) targets)
648 ok <- io (GHC.load session Nothing)
651 changeDirectory :: String -> GHCi ()
652 changeDirectory dir = do
653 session <- getSession
654 graph <- io (GHC.getModuleGraph session)
655 when (not (null graph)) $
656 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
657 io (GHC.setTargets session [])
658 io (GHC.load session Nothing)
659 setContextAfterLoad []
660 io (GHC.workingDirectoryChanged session)
661 dir <- expandPath dir
662 io (setCurrentDirectory dir)
664 defineMacro :: String -> GHCi ()
666 let (macro_name, definition) = break isSpace s
667 cmds <- io (readIORef commands)
669 then throwDyn (CmdLineError "invalid macro name")
671 if (macro_name `elem` map fst cmds)
672 then throwDyn (CmdLineError
673 ("command '" ++ macro_name ++ "' is already defined"))
676 -- give the expression a type signature, so we can be sure we're getting
677 -- something of the right type.
678 let new_expr = '(' : definition ++ ") :: String -> IO String"
680 -- compile the expression
682 maybe_hv <- io (GHC.compileExpr cms new_expr)
685 Just hv -> io (writeIORef commands --
686 ((macro_name, keepGoing (runMacro hv)) : cmds))
688 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
690 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
691 stringLoop (lines str)
693 undefineMacro :: String -> GHCi ()
694 undefineMacro macro_name = do
695 cmds <- io (readIORef commands)
696 if (macro_name `elem` map fst builtin_commands)
697 then throwDyn (CmdLineError
698 ("command '" ++ macro_name ++ "' cannot be undefined"))
700 if (macro_name `notElem` map fst cmds)
701 then throwDyn (CmdLineError
702 ("command '" ++ macro_name ++ "' not defined"))
704 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
707 loadModule :: [FilePath] -> GHCi ()
708 loadModule fs = timeIt (loadModule' fs)
710 loadModule' :: [FilePath] -> GHCi ()
711 loadModule' files = do
712 session <- getSession
715 io (GHC.setTargets session [])
716 io (GHC.load session Nothing)
719 files <- mapM expandPath files
720 targets <- io (mapM GHC.guessTarget files)
722 -- NOTE: we used to do the dependency anal first, so that if it
723 -- fails we didn't throw away the current set of modules. This would
724 -- require some re-working of the GHC interface, so we'll leave it
725 -- as a ToDo for now.
727 io (GHC.setTargets session targets)
728 ok <- io (GHC.load session Nothing)
732 reloadModule :: String -> GHCi ()
734 io (revertCAFs) -- always revert CAFs on reload.
735 session <- getSession
736 ok <- io (GHC.load session Nothing)
739 io (revertCAFs) -- always revert CAFs on reload.
740 session <- getSession
741 ok <- io (GHC.load session (Just (mkModule m)))
744 afterLoad ok session = do
745 io (revertCAFs) -- always revert CAFs on load.
746 graph <- io (GHC.getModuleGraph session)
747 let mods = map GHC.ms_mod graph
748 mods' <- filterM (io . GHC.isLoaded session) mods
749 setContextAfterLoad mods'
750 modulesLoadedMsg ok mods'
752 setContextAfterLoad [] = do
753 session <- getSession
754 io (GHC.setContext session [] [prelude_mod])
755 setContextAfterLoad (m:_) = do
756 session <- getSession
757 b <- io (GHC.moduleIsInterpreted session m)
758 if b then io (GHC.setContext session [m] [])
759 else io (GHC.setContext session [] [m])
761 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
762 modulesLoadedMsg ok mods = do
763 dflags <- getDynFlags
764 when (verbosity dflags > 0) $ do
766 | null mods = text "none."
768 punctuate comma (map pprModule mods)) <> text "."
771 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
773 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
776 typeOfExpr :: String -> GHCi ()
778 = do cms <- getSession
779 maybe_ty <- io (GHC.exprType cms str)
782 Just ty -> do ty' <- cleanType ty
783 tystr <- showForUser (ppr ty')
784 io (putStrLn (str ++ " :: " ++ tystr))
786 kindOfType :: String -> GHCi ()
788 = do cms <- getSession
789 maybe_ty <- io (GHC.typeKind cms str)
792 Just ty -> do tystr <- showForUser (ppr ty)
793 io (putStrLn (str ++ " :: " ++ tystr))
795 quit :: String -> GHCi Bool
798 shellEscape :: String -> GHCi Bool
799 shellEscape str = io (system str >> return False)
801 -----------------------------------------------------------------------------
802 -- Browsing a module's contents
804 browseCmd :: String -> GHCi ()
807 ['*':m] | looksLikeModuleName m -> browseModule m False
808 [m] | looksLikeModuleName m -> browseModule m True
809 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
811 browseModule m exports_only = do
814 let modl = mkModule m
815 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
816 when (not is_interpreted && not exports_only) $
817 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
819 -- Temporarily set the context to the module we're interested in,
820 -- just so we can get an appropriate PrintUnqualified
821 (as,bs) <- io (GHC.getContext s)
822 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
823 else GHC.setContext s [modl] [])
824 io (GHC.setContext s as bs)
826 things <- io (GHC.browseModule s modl exports_only)
827 unqual <- io (GHC.getPrintUnqual s)
829 dflags <- getDynFlags
830 let exts = dopt Opt_GlasgowExts dflags
831 io (putStrLn (showSDocForUser unqual (
832 vcat (map (showDecl exts (const True)) things)
835 -----------------------------------------------------------------------------
836 -- Setting the module context
839 | all sensible mods = fn mods
840 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
842 (fn, mods) = case str of
843 '+':stuff -> (addToContext, words stuff)
844 '-':stuff -> (removeFromContext, words stuff)
845 stuff -> (newContext, words stuff)
847 sensible ('*':m) = looksLikeModuleName m
848 sensible m = looksLikeModuleName m
851 session <- getSession
852 (as,bs) <- separate session mods [] []
853 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
854 io (GHC.setContext session as bs')
856 separate :: Session -> [String] -> [Module] -> [Module]
857 -> GHCi ([Module],[Module])
858 separate session [] as bs = return (as,bs)
859 separate session (('*':m):ms) as bs = do
860 let modl = mkModule m
861 b <- io (GHC.moduleIsInterpreted session modl)
862 if b then separate session ms (modl:as) bs
863 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
864 separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
866 prelude_mod = mkModule "Prelude"
869 addToContext mods = do
871 (as,bs) <- io (GHC.getContext cms)
873 (as',bs') <- separate cms mods [] []
875 let as_to_add = as' \\ (as ++ bs)
876 bs_to_add = bs' \\ (as ++ bs)
878 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
881 removeFromContext mods = do
883 (as,bs) <- io (GHC.getContext cms)
885 (as_to_remove,bs_to_remove) <- separate cms mods [] []
887 let as' = as \\ (as_to_remove ++ bs_to_remove)
888 bs' = bs \\ (as_to_remove ++ bs_to_remove)
890 io (GHC.setContext cms as' bs')
892 ----------------------------------------------------------------------------
895 -- set options in the interpreter. Syntax is exactly the same as the
896 -- ghc command line, except that certain options aren't available (-C,
899 -- This is pretty fragile: most options won't work as expected. ToDo:
900 -- figure out which ones & disallow them.
902 setCmd :: String -> GHCi ()
904 = do st <- getGHCiState
905 let opts = options st
906 io $ putStrLn (showSDoc (
907 text "options currently set: " <>
910 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
914 ("args":args) -> setArgs args
915 ("prog":prog) -> setProg prog
916 wds -> setOptions wds
920 setGHCiState st{ args = args }
924 setGHCiState st{ progname = prog }
926 io (hPutStrLn stderr "syntax: :set prog <progname>")
929 do -- first, deal with the GHCi opts (+s, +t, etc.)
930 let (plus_opts, minus_opts) = partition isPlus wds
931 mapM_ setOpt plus_opts
933 -- then, dynamic flags
934 dflags <- getDynFlags
935 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
938 -- update things if the users wants more packages
940 let new_packages = pkgs_after \\ pkgs_before
941 when (not (null new_packages)) $
942 newPackages new_packages
945 if (not (null leftovers))
946 then throwDyn (CmdLineError ("unrecognised flags: " ++
951 unsetOptions :: String -> GHCi ()
953 = do -- first, deal with the GHCi opts (+s, +t, etc.)
955 (minus_opts, rest1) = partition isMinus opts
956 (plus_opts, rest2) = partition isPlus rest1
958 if (not (null rest2))
959 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
962 mapM_ unsetOpt plus_opts
964 -- can't do GHC flags for now
965 if (not (null minus_opts))
966 then throwDyn (CmdLineError "can't unset GHC command-line flags")
969 isMinus ('-':s) = True
972 isPlus ('+':s) = True
976 = case strToGHCiOpt str of
977 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
978 Just o -> setOption o
981 = case strToGHCiOpt str of
982 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
983 Just o -> unsetOption o
985 strToGHCiOpt :: String -> (Maybe GHCiOption)
986 strToGHCiOpt "s" = Just ShowTiming
987 strToGHCiOpt "t" = Just ShowType
988 strToGHCiOpt "r" = Just RevertCAFs
989 strToGHCiOpt _ = Nothing
991 optToStr :: GHCiOption -> String
992 optToStr ShowTiming = "s"
993 optToStr ShowType = "t"
994 optToStr RevertCAFs = "r"
997 newPackages new_pkgs = do -- The new packages are already in v_Packages
998 session <- getSession
999 io (GHC.setTargets session [])
1000 io (GHC.load session Nothing)
1001 dflags <- getDynFlags
1002 io (linkPackages dflags new_pkgs)
1003 setContextAfterLoad []
1006 -- ---------------------------------------------------------------------------
1011 ["modules" ] -> showModules
1012 ["bindings"] -> showBindings
1013 ["linker"] -> io showLinkerState
1014 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1017 session <- getSession
1018 let show_one ms = do m <- io (GHC.showModule session ms)
1020 graph <- io (GHC.getModuleGraph session)
1021 mapM_ show_one graph
1025 unqual <- io (GHC.getPrintUnqual s)
1026 bindings <- io (GHC.getBindings s)
1027 mapM_ showTyThing bindings
1030 showTyThing (AnId id) = do
1031 ty' <- cleanType (GHC.idType id)
1032 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1034 showTyThing _ = return ()
1036 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1037 cleanType :: Type -> GHCi Type
1039 dflags <- getDynFlags
1040 if dopt Opt_GlasgowExts dflags
1042 else return $! GHC.dropForAlls ty
1044 -----------------------------------------------------------------------------
1047 data GHCiState = GHCiState
1051 session :: GHC.Session,
1052 options :: [GHCiOption]
1056 = ShowTiming -- show time/allocs after evaluation
1057 | ShowType -- show the type of expressions
1058 | RevertCAFs -- revert CAFs after every evaluation
1061 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1063 startGHCi :: GHCi a -> GHCiState -> IO a
1064 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1066 instance Monad GHCi where
1067 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1068 return a = GHCi $ \s -> return a
1070 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1071 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1072 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1074 getGHCiState = GHCi $ \r -> readIORef r
1075 setGHCiState s = GHCi $ \r -> writeIORef r s
1077 -- for convenience...
1078 getSession = getGHCiState >>= return . session
1082 io (GHC.getSessionDynFlags s)
1083 setDynFlags dflags = do
1085 io (GHC.setSessionDynFlags s dflags)
1087 isOptionSet :: GHCiOption -> GHCi Bool
1089 = do st <- getGHCiState
1090 return (opt `elem` options st)
1092 setOption :: GHCiOption -> GHCi ()
1094 = do st <- getGHCiState
1095 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1097 unsetOption :: GHCiOption -> GHCi ()
1099 = do st <- getGHCiState
1100 setGHCiState (st{ options = filter (/= opt) (options st) })
1102 io :: IO a -> GHCi a
1103 io m = GHCi { unGHCi = \s -> m >>= return }
1105 -----------------------------------------------------------------------------
1106 -- recursive exception handlers
1108 -- Don't forget to unblock async exceptions in the handler, or if we're
1109 -- in an exception loop (eg. let a = error a in a) the ^C exception
1110 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1112 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1113 ghciHandle h (GHCi m) = GHCi $ \s ->
1114 Exception.catch (m s)
1115 (\e -> unGHCi (ghciUnblock (h e)) s)
1117 ghciUnblock :: GHCi a -> GHCi a
1118 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1120 -----------------------------------------------------------------------------
1121 -- timing & statistics
1123 timeIt :: GHCi a -> GHCi a
1125 = do b <- isOptionSet ShowTiming
1128 else do allocs1 <- io $ getAllocations
1129 time1 <- io $ getCPUTime
1131 allocs2 <- io $ getAllocations
1132 time2 <- io $ getCPUTime
1133 io $ printTimes (fromIntegral (allocs2 - allocs1))
1137 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1138 -- defined in ghc/rts/Stats.c
1140 printTimes :: Integer -> Integer -> IO ()
1141 printTimes allocs psecs
1142 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1143 secs_str = showFFloat (Just 2) secs
1144 putStrLn (showSDoc (
1145 parens (text (secs_str "") <+> text "secs" <> comma <+>
1146 text (show allocs) <+> text "bytes")))
1148 -----------------------------------------------------------------------------
1155 -- Have to turn off buffering again, because we just
1156 -- reverted stdout, stderr & stdin to their defaults.
1158 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1159 -- Make it "safe", just in case
1161 -- -----------------------------------------------------------------------------
1164 expandPath :: String -> GHCi String
1166 case dropWhile isSpace path of
1168 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1169 return (tilde ++ '/':d)