1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.188 2005/02/15 12:15:25 simonmar Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2004
9 -----------------------------------------------------------------------------
10 module InteractiveUI (
11 interactiveUI, -- :: CmState -> [FilePath] -> IO ()
15 #include "HsVersions.h"
18 import HscTypes ( GhciMode(..) )
19 import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
20 IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
21 import FunDeps ( pprFundeps )
24 import DriverUtil ( remove_spaces )
25 import Linker ( showLinkerState, linkPackages )
27 import Name ( Name, NamedThing(..) )
28 import OccName ( OccName, isSymOcc, occNameUserString )
29 import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
31 import CmdLineOpts ( DynFlags(..) )
32 import Panic hiding ( showException )
34 import SrcLoc ( SrcLoc, isGoodSrcLoc )
36 #ifndef mingw32_HOST_OS
37 import DriverUtil( handle )
39 #if __GLASGOW_HASKELL__ > 504
45 import Control.Concurrent ( yield ) -- Used in readline loop
46 import System.Console.Readline as Readline
51 import Control.Exception as Exception
53 -- import Control.Concurrent
57 import Data.Int ( Int64 )
60 import System.Environment
61 import System.Exit ( exitWith, ExitCode(..) )
62 import System.Directory
64 import System.IO.Error as IO
66 import Control.Monad as Monad
67 import Foreign.StablePtr ( newStablePtr )
69 import GHC.Exts ( unsafeCoerce# )
70 import GHC.IOBase ( IOErrorType(InvalidArgument) )
72 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
74 import System.Posix.Internals ( setNonBlockingFD )
76 -----------------------------------------------------------------------------
80 " / _ \\ /\\ /\\/ __(_)\n"++
81 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
82 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
83 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
85 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
87 builtin_commands :: [(String, String -> GHCi Bool)]
89 ("add", keepGoingPaths addModule),
90 ("browse", keepGoing browseCmd),
91 ("cd", keepGoing changeDirectory),
92 ("def", keepGoing defineMacro),
93 ("help", keepGoing help),
94 ("?", keepGoing help),
95 ("info", keepGoing info),
96 ("load", keepGoingPaths loadModule),
97 ("module", keepGoing setContext),
98 ("reload", keepGoing reloadModule),
99 ("set", keepGoing setCmd),
100 ("show", keepGoing showCmd),
101 ("type", keepGoing typeOfExpr),
102 ("kind", keepGoing kindOfType),
103 ("unset", keepGoing unsetOptions),
104 ("undef", keepGoing undefineMacro),
108 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
109 keepGoing a str = a str >> return False
111 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
112 keepGoingPaths a str = a (toArgs str) >> return False
114 shortHelpText = "use :? for help.\n"
116 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
118 " Commands available from the prompt:\n" ++
120 " <stmt> evaluate/run <stmt>\n" ++
121 " :add <filename> ... add module(s) to the current target set\n" ++
122 " :browse [*]<module> display the names defined by <module>\n" ++
123 " :cd <dir> change directory to <dir>\n" ++
124 " :def <cmd> <expr> define a command :<cmd>\n" ++
125 " :help, :? display this list of commands\n" ++
126 " :info [<name> ...] display information about the given names\n" ++
127 " :load <filename> ... load module(s) and their dependents\n" ++
128 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
129 " :reload reload the current module set\n" ++
131 " :set <option> ... set options\n" ++
132 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
133 " :set prog <progname> set the value returned by System.getProgName\n" ++
135 " :show modules show the currently loaded modules\n" ++
136 " :show bindings show the current bindings made at the prompt\n" ++
138 " :type <expr> show the type of <expr>\n" ++
139 " :kind <type> show the kind of <type>\n" ++
140 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
141 " :unset <option> ... unset options\n" ++
142 " :quit exit GHCi\n" ++
143 " :!<command> run the shell command <command>\n" ++
145 " Options for ':set' and ':unset':\n" ++
147 " +r revert top-level expressions after each evaluation\n" ++
148 " +s print timing/memory stats after each evaluation\n" ++
149 " +t print type after evaluation\n" ++
150 " -<flags> most GHC command line flags can also be set here\n" ++
151 " (eg. -v2, -fglasgow-exts, etc.)\n"
154 interactiveUI :: DynFlags -> [FilePath] -> Maybe String -> IO ()
155 interactiveUI dflags srcs maybe_expr = do
157 cmstate <- cmInit Interactive dflags;
159 -- HACK! If we happen to get into an infinite loop (eg the user
160 -- types 'let x=x in x' at the prompt), then the thread will block
161 -- on a blackhole, and become unreachable during GC. The GC will
162 -- detect that it is unreachable and send it the NonTermination
163 -- exception. However, since the thread is unreachable, everything
164 -- it refers to might be finalized, including the standard Handles.
165 -- This sounds like a bug, but we don't have a good solution right
172 hSetBuffering stdout NoBuffering
174 -- Initialise buffering for the *interpreted* I/O system
175 initInterpBuffering cmstate
177 -- We don't want the cmd line to buffer any input that might be
178 -- intended for the program, so unbuffer stdin.
179 hSetBuffering stdin NoBuffering
181 -- initial context is just the Prelude
182 cmstate <- cmSetContext cmstate [] ["Prelude"]
188 startGHCi (runGHCi srcs dflags maybe_expr)
189 GHCiState{ progname = "<interactive>",
196 Readline.resetTerminal Nothing
201 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
202 runGHCi paths dflags maybe_expr = do
203 read_dot_files <- io (readIORef v_Read_DotGHCi)
205 when (read_dot_files) $ do
208 exists <- io (doesFileExist file)
210 dir_ok <- io (checkPerms ".")
211 file_ok <- io (checkPerms file)
212 when (dir_ok && file_ok) $ do
213 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
216 Right hdl -> fileLoop hdl False
218 when (read_dot_files) $ do
219 -- Read in $HOME/.ghci
220 either_dir <- io (IO.try (getEnv "HOME"))
224 cwd <- io (getCurrentDirectory)
225 when (dir /= cwd) $ do
226 let file = dir ++ "/.ghci"
227 ok <- io (checkPerms file)
229 either_hdl <- io (IO.try (openFile file ReadMode))
232 Right hdl -> fileLoop hdl False
234 -- Perform a :load for files given on the GHCi command line
235 when (not (null paths)) $
236 ghciHandle showException $
239 -- if verbosity is greater than 0, or we are connected to a
240 -- terminal, display the prompt in the interactive loop.
241 is_tty <- io (hIsTerminalDevice stdin)
242 let show_prompt = verbosity dflags > 0 || is_tty
246 -- enter the interactive loop
247 interactiveLoop is_tty show_prompt
249 -- just evaluate the expression we were given
254 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
257 interactiveLoop is_tty show_prompt = do
258 -- Ignore ^C exceptions caught here
259 ghciHandleDyn (\e -> case e of
260 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
261 _other -> return ()) $ do
263 -- read commands from stdin
267 else fileLoop stdin show_prompt
269 fileLoop stdin show_prompt
273 -- NOTE: We only read .ghci files if they are owned by the current user,
274 -- and aren't world writable. Otherwise, we could be accidentally
275 -- running code planted by a malicious third party.
277 -- Furthermore, We only read ./.ghci if . is owned by the current user
278 -- and isn't writable by anyone else. I think this is sufficient: we
279 -- don't need to check .. and ../.. etc. because "." always refers to
280 -- the same directory while a process is running.
282 checkPerms :: String -> IO Bool
284 #ifdef mingw32_HOST_OS
287 DriverUtil.handle (\_ -> return False) $ do
288 st <- getFileStatus name
290 if fileOwner st /= me then do
291 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
294 let mode = fileMode st
295 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
296 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
298 putStrLn $ "*** WARNING: " ++ name ++
299 " is writable by someone else, IGNORING!"
304 fileLoop :: Handle -> Bool -> GHCi ()
305 fileLoop hdl prompt = do
306 cmstate <- getCmState
307 (mod,imports) <- io (cmGetContext cmstate)
308 when prompt (io (putStr (mkPrompt mod imports)))
309 l <- io (IO.try (hGetLine hdl))
311 Left e | isEOFError e -> return ()
312 | InvalidArgument <- etype -> return ()
313 | otherwise -> io (ioError e)
314 where etype = ioeGetErrorType e
315 -- treat InvalidArgument in the same way as EOF:
316 -- this can happen if the user closed stdin, or
317 -- perhaps did getContents which closes stdin at
320 case remove_spaces l of
321 "" -> fileLoop hdl prompt
322 l -> do quit <- runCommand l
323 if quit then return () else fileLoop hdl prompt
325 stringLoop :: [String] -> GHCi ()
326 stringLoop [] = return ()
327 stringLoop (s:ss) = do
328 case remove_spaces s of
330 l -> do quit <- runCommand l
331 if quit then return () else stringLoop ss
333 mkPrompt toplevs exports
334 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
337 readlineLoop :: GHCi ()
339 cmstate <- getCmState
340 (mod,imports) <- io (cmGetContext cmstate)
342 l <- io (readline (mkPrompt mod imports)
343 `finally` setNonBlockingFD 0)
344 -- readline sometimes puts stdin into blocking mode,
345 -- so we need to put it back for the IO library
349 case remove_spaces l of
354 if quit then return () else readlineLoop
357 runCommand :: String -> GHCi Bool
358 runCommand c = ghciHandle handler (doCommand c)
360 -- This version is for the GHC command-line option -e. The only difference
361 -- from runCommand is that it catches the ExitException exception and
362 -- exits, rather than printing out the exception.
363 runCommandEval c = ghciHandle handleEval (doCommand c)
365 handleEval (ExitException code) = io (exitWith code)
366 handleEval e = do showException e
367 io (exitWith (ExitFailure 1))
369 -- This is the exception handler for exceptions generated by the
370 -- user's code; it normally just prints out the exception. The
371 -- handler must be recursive, in case showing the exception causes
372 -- more exceptions to be raised.
374 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
375 -- raising another exception. We therefore don't put the recursive
376 -- handler arond the flushing operation, so if stderr is closed
377 -- GHCi will just die gracefully rather than going into an infinite loop.
378 handler :: Exception -> GHCi Bool
379 handler exception = do
381 io installSignalHandlers
382 ghciHandle handler (showException exception >> return False)
384 showException (DynException dyn) =
385 case fromDynamic dyn of
386 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
387 Just Interrupted -> io (putStrLn "Interrupted.")
388 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
389 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
390 Just other_ghc_ex -> io (print other_ghc_ex)
392 showException other_exception
393 = io (putStrLn ("*** Exception: " ++ show other_exception))
395 doCommand (':' : command) = specialCommand command
397 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
400 runStmt :: String -> GHCi [Name]
402 | null (filter (not.isSpace) stmt) = return []
404 = do st <- getGHCiState
405 cmstate <- getCmState
406 (new_cmstate, result) <-
407 io $ withProgName (progname st) $ withArgs (args st) $
408 cmRunStmt cmstate stmt
409 setGHCiState st{cmstate = new_cmstate}
411 CmRunFailed -> return []
412 CmRunException e -> throw e -- this is caught by runCommand(Eval)
413 CmRunOk names -> return names
415 -- possibly print the type and revert CAFs after evaluating an expression
417 = do b <- isOptionSet ShowType
418 cmstate <- getCmState
419 when b (mapM_ (showTypeOfName cmstate) names)
422 io installSignalHandlers
423 b <- isOptionSet RevertCAFs
424 io (when b revertCAFs)
427 showTypeOfName :: CmState -> Name -> GHCi ()
428 showTypeOfName cmstate n
429 = do maybe_str <- io (cmTypeOfName cmstate n)
432 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
434 specialCommand :: String -> GHCi Bool
435 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
436 specialCommand str = do
437 let (cmd,rest) = break isSpace str
438 cmds <- io (readIORef commands)
439 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
440 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
441 ++ shortHelpText) >> return False)
442 [(_,f)] -> f (dropWhile isSpace rest)
443 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
444 " matches multiple commands (" ++
445 foldr1 (\a b -> a ++ ',':b) (map fst cs)
446 ++ ")") >> return False)
448 noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
451 -----------------------------------------------------------------------------
452 -- To flush buffers for the *interpreted* computation we need
453 -- to refer to *its* stdout/stderr handles
455 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
456 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
458 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
459 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
460 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
462 initInterpBuffering :: CmState -> IO ()
463 initInterpBuffering cmstate
464 = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
467 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
468 other -> panic "interactiveUI:setBuffering"
470 maybe_hval <- cmCompileExpr cmstate flush_cmd
472 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
473 _ -> panic "interactiveUI:flush"
475 turnOffBuffering -- Turn it off right now
480 flushInterpBuffers :: GHCi ()
482 = io $ do Monad.join (readIORef flush_interp)
485 turnOffBuffering :: IO ()
487 = do Monad.join (readIORef turn_off_buffering)
490 -----------------------------------------------------------------------------
493 help :: String -> GHCi ()
494 help _ = io (putStr helpText)
496 info :: String -> GHCi ()
497 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
498 info s = do { let names = words s
499 ; init_cms <- getCmState
500 ; mapM_ (infoThing init_cms) names }
503 = do { stuff <- io (cmGetInfo cms name)
504 ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
505 vcat (intersperse (text "") (map showThing stuff)))) }
507 showThing :: GetInfoResult -> SDoc
508 showThing (wanted_str, (thing, fixity, src_loc, insts))
509 = vcat [ showWithLoc src_loc (showDecl want_name thing),
511 vcat (map show_inst insts)]
513 want_name occ = wanted_str == occNameUserString occ
516 | fix == defaultFixity = empty
517 | otherwise = ppr fix <+> text wanted_str
519 show_inst (iface_inst, loc)
520 = showWithLoc loc (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
522 showWithLoc :: SrcLoc -> SDoc -> SDoc
524 = hang doc 2 (char '\t' <> show_loc loc)
525 -- The tab tries to make them line up a bit
527 show_loc loc -- The ppr function for SrcLocs is a bit wonky
528 | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
529 | otherwise = comment <+> ppr loc
530 comment = ptext SLIT("--")
533 -- Now there is rather a lot of goop just to print declarations in a
534 -- civilised way with "..." for the parts we are less interested in.
536 showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc
537 showDecl want_name (IfaceForeign {ifName = tc})
538 = ppr tc <+> ptext SLIT("is a foreign type")
540 showDecl want_name (IfaceId {ifName = var, ifType = ty})
541 = ppr var <+> dcolon <+> ppr ty
543 showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
544 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
545 2 (equals <+> ppr mono_ty)
547 showDecl want_name (IfaceData {ifName = tycon,
548 ifTyVars = tyvars, ifCons = condecls})
549 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
550 2 (add_bars (ppr_trim show_con cs))
552 show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
553 ifConStricts = strs, ifConFields = flds})
554 | want_name tycon || want_name con_name || any want_name flds
555 = Just (show_guts con_name is_infix tys_w_strs flds)
556 | otherwise = Nothing
558 tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
559 show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
560 ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
561 | want_name tycon || want_name con_name
562 = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
563 | otherwise = Nothing
565 tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
566 pp_tau = foldr add pp_res_ty tys_w_strs
567 pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
568 add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
570 show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
571 show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
572 show_guts con _ tys flds
573 = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
575 show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
576 = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
577 | otherwise = Nothing
579 (pp_nd, context, cs) = case condecls of
580 IfAbstractTyCon -> (ptext SLIT("data"), [], [])
581 IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs)
582 IfDataTyCon Nothing cs -> (ptext SLIT("data"), [], cs)
583 IfNewTyCon c -> (ptext SLIT("newtype"), [], [c])
586 add_bars [c] = equals <+> c
587 add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
589 ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
590 ppr_str MarkedStrict = char '!'
591 ppr_str MarkedUnboxed = ptext SLIT("!!")
592 ppr_str NotMarkedStrict = empty
594 showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
595 ifFDs = fds, ifSigs = sigs})
596 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
597 <+> pprFundeps fds <+> ptext SLIT("where"))
598 2 (vcat (ppr_trim show_op sigs))
600 show_op (IfaceClassOp op dm ty)
601 | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty)
602 | otherwise = Nothing
604 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
606 = snd (foldr go (False, []) xs)
608 go x (eliding, so_far)
609 | Just doc <- show x = (False, doc : so_far)
610 | otherwise = if eliding then (True, so_far)
611 else (True, ptext SLIT("...") : so_far)
613 ppr_bndr :: OccName -> SDoc
614 -- Wrap operators in ()
615 ppr_bndr occ | isSymOcc occ = parens (ppr occ)
616 | otherwise = ppr occ
619 -----------------------------------------------------------------------------
622 addModule :: [FilePath] -> GHCi ()
624 state <- getGHCiState
625 io (revertCAFs) -- always revert CAFs on load/add.
626 files <- mapM expandPath files
627 let new_targets = files ++ targets state
628 graph <- io (cmDepAnal (cmstate state) new_targets)
629 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
630 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
631 setContextAfterLoad mods
632 dflags <- getDynFlags
633 modulesLoadedMsg ok mods dflags
635 changeDirectory :: String -> GHCi ()
636 changeDirectory dir = do
637 state <- getGHCiState
638 when (targets state /= []) $
639 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
640 cmstate1 <- io (cmUnload (cmstate state))
641 setGHCiState state{ cmstate = cmstate1, targets = [] }
642 setContextAfterLoad []
643 dir <- expandPath dir
644 io (setCurrentDirectory dir)
646 defineMacro :: String -> GHCi ()
648 let (macro_name, definition) = break isSpace s
649 cmds <- io (readIORef commands)
651 then throwDyn (CmdLineError "invalid macro name")
653 if (macro_name `elem` map fst cmds)
654 then throwDyn (CmdLineError
655 ("command '" ++ macro_name ++ "' is already defined"))
658 -- give the expression a type signature, so we can be sure we're getting
659 -- something of the right type.
660 let new_expr = '(' : definition ++ ") :: String -> IO String"
662 -- compile the expression
664 maybe_hv <- io (cmCompileExpr cms new_expr)
667 Just hv -> io (writeIORef commands --
668 ((macro_name, keepGoing (runMacro hv)) : cmds))
670 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
672 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
673 stringLoop (lines str)
675 undefineMacro :: String -> GHCi ()
676 undefineMacro macro_name = do
677 cmds <- io (readIORef commands)
678 if (macro_name `elem` map fst builtin_commands)
679 then throwDyn (CmdLineError
680 ("command '" ++ macro_name ++ "' cannot be undefined"))
682 if (macro_name `notElem` map fst cmds)
683 then throwDyn (CmdLineError
684 ("command '" ++ macro_name ++ "' not defined"))
686 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
689 loadModule :: [FilePath] -> GHCi ()
690 loadModule fs = timeIt (loadModule' fs)
692 loadModule' :: [FilePath] -> GHCi ()
693 loadModule' files = do
694 state <- getGHCiState
697 files <- mapM expandPath files
699 -- do the dependency anal first, so that if it fails we don't throw
700 -- away the current set of modules.
701 graph <- io (cmDepAnal (cmstate state) files)
703 -- Dependency anal ok, now unload everything
704 cmstate1 <- io (cmUnload (cmstate state))
705 setGHCiState state{ cmstate = cmstate1, targets = [] }
707 io (revertCAFs) -- always revert CAFs on load.
708 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
709 setGHCiState state{ cmstate = cmstate2, targets = files }
711 setContextAfterLoad mods
712 dflags <- getDynFlags
713 modulesLoadedMsg ok mods dflags
716 reloadModule :: String -> GHCi ()
718 state <- getGHCiState
719 case targets state of
720 [] -> io (putStr "no current target\n")
722 -- do the dependency anal first, so that if it fails we don't throw
723 -- away the current set of modules.
724 graph <- io (cmDepAnal (cmstate state) paths)
726 io (revertCAFs) -- always revert CAFs on reload.
728 <- io (cmLoadModules (cmstate state) graph)
729 setGHCiState state{ cmstate=cmstate1 }
730 setContextAfterLoad mods
731 dflags <- getDynFlags
732 modulesLoadedMsg ok mods dflags
734 reloadModule _ = noArgs ":reload"
736 setContextAfterLoad [] = setContext prel
737 setContextAfterLoad (m:_) = do
738 cmstate <- getCmState
739 b <- io (cmModuleIsInterpreted cmstate m)
740 if b then setContext ('*':m) else setContext m
742 modulesLoadedMsg ok mods dflags =
743 when (verbosity dflags > 0) $ do
745 | null mods = text "none."
747 punctuate comma (map text mods)) <> text "."
750 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
752 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
755 typeOfExpr :: String -> GHCi ()
757 = do cms <- getCmState
758 maybe_tystr <- io (cmTypeOfExpr cms str)
761 Just tystr -> io (putStrLn tystr)
763 kindOfType :: String -> GHCi ()
765 = do cms <- getCmState
766 maybe_tystr <- io (cmKindOfType cms str)
769 Just tystr -> io (putStrLn tystr)
771 quit :: String -> GHCi Bool
774 shellEscape :: String -> GHCi Bool
775 shellEscape str = io (system str >> return False)
777 -----------------------------------------------------------------------------
778 -- Browsing a module's contents
780 browseCmd :: String -> GHCi ()
783 ['*':m] | looksLikeModuleName m -> browseModule m False
784 [m] | looksLikeModuleName m -> browseModule m True
785 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
787 browseModule m exports_only = do
790 is_interpreted <- io (cmModuleIsInterpreted cms m)
791 when (not is_interpreted && not exports_only) $
792 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
794 -- Temporarily set the context to the module we're interested in,
795 -- just so we can get an appropriate PrintUnqualified
796 (as,bs) <- io (cmGetContext cms)
797 cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
798 else cmSetContext cms [m] [])
799 cms2 <- io (cmSetContext cms1 as bs)
801 things <- io (cmBrowseModule cms2 m exports_only)
803 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
805 io (putStrLn (showSDocForUser unqual (
806 vcat (map (showDecl (const True)) things)
809 -----------------------------------------------------------------------------
810 -- Setting the module context
813 | all sensible mods = fn mods
814 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
816 (fn, mods) = case str of
817 '+':stuff -> (addToContext, words stuff)
818 '-':stuff -> (removeFromContext, words stuff)
819 stuff -> (newContext, words stuff)
821 sensible ('*':m) = looksLikeModuleName m
822 sensible m = looksLikeModuleName m
826 (as,bs) <- separate cms mods [] []
827 let bs' = if null as && prel `notElem` bs then prel:bs else bs
828 cms' <- io (cmSetContext cms as bs')
831 separate cmstate [] as bs = return (as,bs)
832 separate cmstate (('*':m):ms) as bs = do
833 b <- io (cmModuleIsInterpreted cmstate m)
834 if b then separate cmstate ms (m:as) bs
835 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
836 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
841 addToContext mods = do
843 (as,bs) <- io (cmGetContext cms)
845 (as',bs') <- separate cms mods [] []
847 let as_to_add = as' \\ (as ++ bs)
848 bs_to_add = bs' \\ (as ++ bs)
850 cms' <- io (cmSetContext cms
851 (as ++ as_to_add) (bs ++ bs_to_add))
855 removeFromContext mods = do
857 (as,bs) <- io (cmGetContext cms)
859 (as_to_remove,bs_to_remove) <- separate cms mods [] []
861 let as' = as \\ (as_to_remove ++ bs_to_remove)
862 bs' = bs \\ (as_to_remove ++ bs_to_remove)
864 cms' <- io (cmSetContext cms as' bs')
867 ----------------------------------------------------------------------------
870 -- set options in the interpreter. Syntax is exactly the same as the
871 -- ghc command line, except that certain options aren't available (-C,
874 -- This is pretty fragile: most options won't work as expected. ToDo:
875 -- figure out which ones & disallow them.
877 setCmd :: String -> GHCi ()
879 = do st <- getGHCiState
880 let opts = options st
881 io $ putStrLn (showSDoc (
882 text "options currently set: " <>
885 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
889 ("args":args) -> setArgs args
890 ("prog":prog) -> setProg prog
891 wds -> setOptions wds
895 setGHCiState st{ args = args }
899 setGHCiState st{ progname = prog }
901 io (hPutStrLn stderr "syntax: :set prog <progname>")
904 do -- first, deal with the GHCi opts (+s, +t, etc.)
905 let (plus_opts, minus_opts) = partition isPlus wds
906 mapM_ setOpt plus_opts
908 -- now, the GHC flags
909 leftovers <- io $ processStaticFlags minus_opts
911 -- then, dynamic flags
912 dflags <- getDynFlags
913 (dflags',leftovers) <- io $ processDynamicFlags leftovers dflags
916 -- update things if the users wants more packages
918 let new_packages = pkgs_after \\ pkgs_before
919 when (not (null new_packages)) $
920 newPackages new_packages
923 if (not (null leftovers))
924 then throwDyn (CmdLineError ("unrecognised flags: " ++
929 unsetOptions :: String -> GHCi ()
931 = do -- first, deal with the GHCi opts (+s, +t, etc.)
933 (minus_opts, rest1) = partition isMinus opts
934 (plus_opts, rest2) = partition isPlus rest1
936 if (not (null rest2))
937 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
940 mapM_ unsetOpt plus_opts
942 -- can't do GHC flags for now
943 if (not (null minus_opts))
944 then throwDyn (CmdLineError "can't unset GHC command-line flags")
947 isMinus ('-':s) = True
950 isPlus ('+':s) = True
954 = case strToGHCiOpt str of
955 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
956 Just o -> setOption o
959 = case strToGHCiOpt str of
960 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
961 Just o -> unsetOption o
963 strToGHCiOpt :: String -> (Maybe GHCiOption)
964 strToGHCiOpt "s" = Just ShowTiming
965 strToGHCiOpt "t" = Just ShowType
966 strToGHCiOpt "r" = Just RevertCAFs
967 strToGHCiOpt _ = Nothing
969 optToStr :: GHCiOption -> String
970 optToStr ShowTiming = "s"
971 optToStr ShowType = "t"
972 optToStr RevertCAFs = "r"
974 newPackages new_pkgs = do -- The new packages are already in v_Packages
975 state <- getGHCiState
976 cmstate1 <- io (cmUnload (cmstate state))
977 setGHCiState state{ cmstate = cmstate1, targets = [] }
978 dflags <- getDynFlags
979 io (linkPackages dflags new_pkgs)
980 setContextAfterLoad []
982 -- ---------------------------------------------------------------------------
987 ["modules" ] -> showModules
988 ["bindings"] -> showBindings
989 ["linker"] -> io showLinkerState
990 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
993 = do { cms <- getCmState
994 ; let show_one ms = io (putStrLn (cmShowModule cms ms))
995 ; mapM_ show_one (cmGetModuleGraph cms) }
1000 unqual = cmGetPrintUnqual cms
1001 -- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
1002 showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
1004 io (mapM_ showBinding (cmGetBindings cms))
1008 -----------------------------------------------------------------------------
1011 data GHCiState = GHCiState
1015 targets :: [FilePath],
1017 options :: [GHCiOption]
1021 = ShowTiming -- show time/allocs after evaluation
1022 | ShowType -- show the type of expressions
1023 | RevertCAFs -- revert CAFs after every evaluation
1026 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1028 startGHCi :: GHCi a -> GHCiState -> IO a
1029 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1031 instance Monad GHCi where
1032 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1033 return a = GHCi $ \s -> return a
1035 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1036 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1037 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1039 getGHCiState = GHCi $ \r -> readIORef r
1040 setGHCiState s = GHCi $ \r -> writeIORef r s
1042 -- for convenience...
1043 getCmState = getGHCiState >>= return . cmstate
1044 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1046 getDynFlags = getCmState >>= return . cmGetDFlags
1048 setDynFlags dflags = do s <- getCmState; setCmState (cmSetDFlags s dflags)
1050 isOptionSet :: GHCiOption -> GHCi Bool
1052 = do st <- getGHCiState
1053 return (opt `elem` options st)
1055 setOption :: GHCiOption -> GHCi ()
1057 = do st <- getGHCiState
1058 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1060 unsetOption :: GHCiOption -> GHCi ()
1062 = do st <- getGHCiState
1063 setGHCiState (st{ options = filter (/= opt) (options st) })
1065 io :: IO a -> GHCi a
1066 io m = GHCi { unGHCi = \s -> m >>= return }
1068 -----------------------------------------------------------------------------
1069 -- recursive exception handlers
1071 -- Don't forget to unblock async exceptions in the handler, or if we're
1072 -- in an exception loop (eg. let a = error a in a) the ^C exception
1073 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1075 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1076 ghciHandle h (GHCi m) = GHCi $ \s ->
1077 Exception.catch (m s)
1078 (\e -> unGHCi (ghciUnblock (h e)) s)
1080 ghciUnblock :: GHCi a -> GHCi a
1081 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1083 -----------------------------------------------------------------------------
1084 -- timing & statistics
1086 timeIt :: GHCi a -> GHCi a
1088 = do b <- isOptionSet ShowTiming
1091 else do allocs1 <- io $ getAllocations
1092 time1 <- io $ getCPUTime
1094 allocs2 <- io $ getAllocations
1095 time2 <- io $ getCPUTime
1096 io $ printTimes (fromIntegral (allocs2 - allocs1))
1100 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1101 -- defined in ghc/rts/Stats.c
1103 printTimes :: Integer -> Integer -> IO ()
1104 printTimes allocs psecs
1105 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1106 secs_str = showFFloat (Just 2) secs
1107 putStrLn (showSDoc (
1108 parens (text (secs_str "") <+> text "secs" <> comma <+>
1109 text (show allocs) <+> text "bytes")))
1111 -----------------------------------------------------------------------------
1118 -- Have to turn off buffering again, because we just
1119 -- reverted stdout, stderr & stdin to their defaults.
1121 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1122 -- Make it "safe", just in case
1124 -- -----------------------------------------------------------------------------
1127 expandPath :: String -> GHCi String
1129 case dropWhile isSpace path of
1131 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1132 return (tilde ++ '/':d)