1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.186 2005/01/28 17:44:56 simonpj 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.Directory
63 import System.IO.Error as IO
65 import Control.Monad as Monad
66 import Foreign.StablePtr ( newStablePtr )
68 import GHC.Exts ( unsafeCoerce# )
69 import GHC.IOBase ( IOErrorType(InvalidArgument) )
71 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
73 import System.Posix.Internals ( setNonBlockingFD )
75 -----------------------------------------------------------------------------
79 " / _ \\ /\\ /\\/ __(_)\n"++
80 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
81 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
82 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
84 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
86 builtin_commands :: [(String, String -> GHCi Bool)]
88 ("add", keepGoingPaths addModule),
89 ("browse", keepGoing browseCmd),
90 ("cd", keepGoing changeDirectory),
91 ("def", keepGoing defineMacro),
92 ("help", keepGoing help),
93 ("?", keepGoing help),
94 ("info", keepGoing info),
95 ("load", keepGoingPaths loadModule),
96 ("module", keepGoing setContext),
97 ("reload", keepGoing reloadModule),
98 ("set", keepGoing setCmd),
99 ("show", keepGoing showCmd),
100 ("type", keepGoing typeOfExpr),
101 ("kind", keepGoing kindOfType),
102 ("unset", keepGoing unsetOptions),
103 ("undef", keepGoing undefineMacro),
107 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
108 keepGoing a str = a str >> return False
110 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
111 keepGoingPaths a str = a (toArgs str) >> return False
113 shortHelpText = "use :? for help.\n"
115 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
117 " Commands available from the prompt:\n" ++
119 " <stmt> evaluate/run <stmt>\n" ++
120 " :add <filename> ... add module(s) to the current target set\n" ++
121 " :browse [*]<module> display the names defined by <module>\n" ++
122 " :cd <dir> change directory to <dir>\n" ++
123 " :def <cmd> <expr> define a command :<cmd>\n" ++
124 " :help, :? display this list of commands\n" ++
125 " :info [<name> ...] display information about the given names\n" ++
126 " :load <filename> ... load module(s) and their dependents\n" ++
127 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
128 " :reload reload the current module set\n" ++
130 " :set <option> ... set options\n" ++
131 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
132 " :set prog <progname> set the value returned by System.getProgName\n" ++
134 " :show modules show the currently loaded modules\n" ++
135 " :show bindings show the current bindings made at the prompt\n" ++
137 " :type <expr> show the type of <expr>\n" ++
138 " :kind <type> show the kind of <type>\n" ++
139 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
140 " :unset <option> ... unset options\n" ++
141 " :quit exit GHCi\n" ++
142 " :!<command> run the shell command <command>\n" ++
144 " Options for ':set' and ':unset':\n" ++
146 " +r revert top-level expressions after each evaluation\n" ++
147 " +s print timing/memory stats after each evaluation\n" ++
148 " +t print type after evaluation\n" ++
149 " -<flags> most GHC command line flags can also be set here\n" ++
150 " (eg. -v2, -fglasgow-exts, etc.)\n"
153 interactiveUI :: DynFlags -> [FilePath] -> Maybe String -> IO ()
154 interactiveUI dflags srcs maybe_expr = do
156 cmstate <- cmInit Interactive dflags;
158 -- HACK! If we happen to get into an infinite loop (eg the user
159 -- types 'let x=x in x' at the prompt), then the thread will block
160 -- on a blackhole, and become unreachable during GC. The GC will
161 -- detect that it is unreachable and send it the NonTermination
162 -- exception. However, since the thread is unreachable, everything
163 -- it refers to might be finalized, including the standard Handles.
164 -- This sounds like a bug, but we don't have a good solution right
171 hSetBuffering stdout NoBuffering
173 -- Initialise buffering for the *interpreted* I/O system
174 initInterpBuffering cmstate
176 -- We don't want the cmd line to buffer any input that might be
177 -- intended for the program, so unbuffer stdin.
178 hSetBuffering stdin NoBuffering
180 -- initial context is just the Prelude
181 cmstate <- cmSetContext cmstate [] ["Prelude"]
187 startGHCi (runGHCi srcs dflags maybe_expr)
188 GHCiState{ progname = "<interactive>",
195 Readline.resetTerminal Nothing
200 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
201 runGHCi paths dflags maybe_expr = do
202 read_dot_files <- io (readIORef v_Read_DotGHCi)
204 when (read_dot_files) $ do
207 exists <- io (doesFileExist file)
209 dir_ok <- io (checkPerms ".")
210 file_ok <- io (checkPerms file)
211 when (dir_ok && file_ok) $ do
212 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
215 Right hdl -> fileLoop hdl False
217 when (read_dot_files) $ do
218 -- Read in $HOME/.ghci
219 either_dir <- io (IO.try (getEnv "HOME"))
223 cwd <- io (getCurrentDirectory)
224 when (dir /= cwd) $ do
225 let file = dir ++ "/.ghci"
226 ok <- io (checkPerms file)
228 either_hdl <- io (IO.try (openFile file ReadMode))
231 Right hdl -> fileLoop hdl False
233 -- Perform a :load for files given on the GHCi command line
234 when (not (null paths)) $
235 ghciHandle showException $
238 -- if verbosity is greater than 0, or we are connected to a
239 -- terminal, display the prompt in the interactive loop.
240 is_tty <- io (hIsTerminalDevice stdin)
241 let show_prompt = verbosity dflags > 0 || is_tty
245 -- enter the interactive loop
246 interactiveLoop is_tty show_prompt
248 -- just evaluate the expression we were given
253 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
256 interactiveLoop is_tty show_prompt = do
257 -- Ignore ^C exceptions caught here
258 ghciHandleDyn (\e -> case e of
259 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
260 _other -> return ()) $ do
262 -- read commands from stdin
266 else fileLoop stdin show_prompt
268 fileLoop stdin show_prompt
272 -- NOTE: We only read .ghci files if they are owned by the current user,
273 -- and aren't world writable. Otherwise, we could be accidentally
274 -- running code planted by a malicious third party.
276 -- Furthermore, We only read ./.ghci if . is owned by the current user
277 -- and isn't writable by anyone else. I think this is sufficient: we
278 -- don't need to check .. and ../.. etc. because "." always refers to
279 -- the same directory while a process is running.
281 checkPerms :: String -> IO Bool
283 #ifdef mingw32_HOST_OS
286 DriverUtil.handle (\_ -> return False) $ do
287 st <- getFileStatus name
289 if fileOwner st /= me then do
290 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
293 let mode = fileMode st
294 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
295 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
297 putStrLn $ "*** WARNING: " ++ name ++
298 " is writable by someone else, IGNORING!"
303 fileLoop :: Handle -> Bool -> GHCi ()
304 fileLoop hdl prompt = do
305 cmstate <- getCmState
306 (mod,imports) <- io (cmGetContext cmstate)
307 when prompt (io (putStr (mkPrompt mod imports)))
308 l <- io (IO.try (hGetLine hdl))
310 Left e | isEOFError e -> return ()
311 | InvalidArgument <- etype -> return ()
312 | otherwise -> io (ioError e)
313 where etype = ioeGetErrorType e
314 -- treat InvalidArgument in the same way as EOF:
315 -- this can happen if the user closed stdin, or
316 -- perhaps did getContents which closes stdin at
319 case remove_spaces l of
320 "" -> fileLoop hdl prompt
321 l -> do quit <- runCommand l
322 if quit then return () else fileLoop hdl prompt
324 stringLoop :: [String] -> GHCi ()
325 stringLoop [] = return ()
326 stringLoop (s:ss) = do
327 case remove_spaces s of
329 l -> do quit <- runCommand l
330 if quit then return () else stringLoop ss
332 mkPrompt toplevs exports
333 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
336 readlineLoop :: GHCi ()
338 cmstate <- getCmState
339 (mod,imports) <- io (cmGetContext cmstate)
341 l <- io (readline (mkPrompt mod imports)
342 `finally` setNonBlockingFD 0)
343 -- readline sometimes puts stdin into blocking mode,
344 -- so we need to put it back for the IO library
348 case remove_spaces l of
353 if quit then return () else readlineLoop
356 runCommand :: String -> GHCi Bool
357 runCommand c = ghciHandle handler (doCommand c)
359 -- This is the exception handler for exceptions generated by the
360 -- user's code; it normally just prints out the exception. The
361 -- handler must be recursive, in case showing the exception causes
362 -- more exceptions to be raised.
364 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
365 -- raising another exception. We therefore don't put the recursive
366 -- handler arond the flushing operation, so if stderr is closed
367 -- GHCi will just die gracefully rather than going into an infinite loop.
368 handler :: Exception -> GHCi Bool
369 handler exception = do
371 io installSignalHandlers
372 ghciHandle handler (showException exception >> return False)
374 showException (DynException dyn) =
375 case fromDynamic dyn of
376 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
377 Just Interrupted -> io (putStrLn "Interrupted.")
378 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
379 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
380 Just other_ghc_ex -> io (print other_ghc_ex)
382 showException other_exception
383 = io (putStrLn ("*** Exception: " ++ show other_exception))
385 doCommand (':' : command) = specialCommand command
387 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
390 runStmt :: String -> GHCi [Name]
392 | null (filter (not.isSpace) stmt) = return []
394 = do st <- getGHCiState
395 cmstate <- getCmState
396 (new_cmstate, result) <-
397 io $ withProgName (progname st) $ withArgs (args st) $
398 cmRunStmt cmstate stmt
399 setGHCiState st{cmstate = new_cmstate}
401 CmRunFailed -> return []
402 CmRunException e -> showException e >> return []
403 CmRunOk names -> return names
405 -- possibly print the type and revert CAFs after evaluating an expression
407 = do b <- isOptionSet ShowType
408 cmstate <- getCmState
409 when b (mapM_ (showTypeOfName cmstate) names)
412 io installSignalHandlers
413 b <- isOptionSet RevertCAFs
414 io (when b revertCAFs)
417 showTypeOfName :: CmState -> Name -> GHCi ()
418 showTypeOfName cmstate n
419 = do maybe_str <- io (cmTypeOfName cmstate n)
422 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
424 specialCommand :: String -> GHCi Bool
425 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
426 specialCommand str = do
427 let (cmd,rest) = break isSpace str
428 cmds <- io (readIORef commands)
429 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
430 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
431 ++ shortHelpText) >> return False)
432 [(_,f)] -> f (dropWhile isSpace rest)
433 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
434 " matches multiple commands (" ++
435 foldr1 (\a b -> a ++ ',':b) (map fst cs)
436 ++ ")") >> return False)
438 noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
441 -----------------------------------------------------------------------------
442 -- To flush buffers for the *interpreted* computation we need
443 -- to refer to *its* stdout/stderr handles
445 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
446 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
448 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
449 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
450 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
452 initInterpBuffering :: CmState -> IO ()
453 initInterpBuffering cmstate
454 = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
457 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
458 other -> panic "interactiveUI:setBuffering"
460 maybe_hval <- cmCompileExpr cmstate flush_cmd
462 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
463 _ -> panic "interactiveUI:flush"
465 turnOffBuffering -- Turn it off right now
470 flushInterpBuffers :: GHCi ()
472 = io $ do Monad.join (readIORef flush_interp)
475 turnOffBuffering :: IO ()
477 = do Monad.join (readIORef turn_off_buffering)
480 -----------------------------------------------------------------------------
483 help :: String -> GHCi ()
484 help _ = io (putStr helpText)
486 info :: String -> GHCi ()
487 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
488 info s = do { let names = words s
489 ; init_cms <- getCmState
490 ; mapM_ (infoThing init_cms) names }
493 = do { stuff <- io (cmGetInfo cms name)
494 ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
495 vcat (intersperse (text "") (map showThing stuff)))) }
497 showThing :: GetInfoResult -> SDoc
498 showThing (wanted_str, (thing, fixity, src_loc, insts))
499 = vcat [ showWithLoc src_loc (showDecl want_name thing),
501 vcat (map show_inst insts)]
503 want_name occ = wanted_str == occNameUserString occ
506 | fix == defaultFixity = empty
507 | otherwise = ppr fix <+> text wanted_str
509 show_inst (iface_inst, loc)
510 = showWithLoc loc (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
512 showWithLoc :: SrcLoc -> SDoc -> SDoc
514 = hang doc 2 (char '\t' <> show_loc loc)
515 -- The tab tries to make them line up a bit
517 show_loc loc -- The ppr function for SrcLocs is a bit wonky
518 | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
519 | otherwise = comment <+> ppr loc
520 comment = ptext SLIT("--")
523 -- Now there is rather a lot of goop just to print declarations in a
524 -- civilised way with "..." for the parts we are less interested in.
526 showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc
527 showDecl want_name (IfaceForeign {ifName = tc})
528 = ppr tc <+> ptext SLIT("is a foreign type")
530 showDecl want_name (IfaceId {ifName = var, ifType = ty})
531 = ppr var <+> dcolon <+> ppr ty
533 showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
534 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
535 2 (equals <+> ppr mono_ty)
537 showDecl want_name (IfaceData {ifName = tycon,
538 ifTyVars = tyvars, ifCons = condecls})
539 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
540 2 (add_bars (ppr_trim show_con cs))
542 show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
543 ifConStricts = strs, ifConFields = flds})
544 | want_name tycon || want_name con_name || any want_name flds
545 = Just (show_guts con_name is_infix tys_w_strs flds)
546 | otherwise = Nothing
548 tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
549 show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
550 ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
551 | want_name tycon || want_name con_name
552 = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
553 | otherwise = Nothing
555 tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
556 pp_tau = foldr add pp_res_ty tys_w_strs
557 pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
558 add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
560 show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
561 show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
562 show_guts con _ tys flds
563 = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
565 show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
566 = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
567 | otherwise = Nothing
569 (pp_nd, context, cs) = case condecls of
570 IfAbstractTyCon -> (ptext SLIT("data"), [], [])
571 IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs)
572 IfDataTyCon Nothing cs -> (ptext SLIT("data"), [], cs)
573 IfNewTyCon c -> (ptext SLIT("newtype"), [], [c])
576 add_bars [c] = equals <+> c
577 add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
579 ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
580 ppr_str MarkedStrict = char '!'
581 ppr_str MarkedUnboxed = ptext SLIT("!!")
582 ppr_str NotMarkedStrict = empty
584 showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
585 ifFDs = fds, ifSigs = sigs})
586 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
587 <+> pprFundeps fds <+> ptext SLIT("where"))
588 2 (vcat (ppr_trim show_op sigs))
590 show_op (IfaceClassOp op dm ty)
591 | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty)
592 | otherwise = Nothing
594 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
596 = snd (foldr go (False, []) xs)
598 go x (eliding, so_far)
599 | Just doc <- show x = (False, doc : so_far)
600 | otherwise = if eliding then (True, so_far)
601 else (True, ptext SLIT("...") : so_far)
603 ppr_bndr :: OccName -> SDoc
604 -- Wrap operators in ()
605 ppr_bndr occ | isSymOcc occ = parens (ppr occ)
606 | otherwise = ppr occ
609 -----------------------------------------------------------------------------
612 addModule :: [FilePath] -> GHCi ()
614 state <- getGHCiState
615 io (revertCAFs) -- always revert CAFs on load/add.
616 files <- mapM expandPath files
617 let new_targets = files ++ targets state
618 graph <- io (cmDepAnal (cmstate state) new_targets)
619 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
620 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
621 setContextAfterLoad mods
622 dflags <- getDynFlags
623 modulesLoadedMsg ok mods dflags
625 changeDirectory :: String -> GHCi ()
626 changeDirectory dir = do
627 state <- getGHCiState
628 when (targets state /= []) $
629 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
630 cmstate1 <- io (cmUnload (cmstate state))
631 setGHCiState state{ cmstate = cmstate1, targets = [] }
632 setContextAfterLoad []
633 dir <- expandPath dir
634 io (setCurrentDirectory dir)
636 defineMacro :: String -> GHCi ()
638 let (macro_name, definition) = break isSpace s
639 cmds <- io (readIORef commands)
641 then throwDyn (CmdLineError "invalid macro name")
643 if (macro_name `elem` map fst cmds)
644 then throwDyn (CmdLineError
645 ("command '" ++ macro_name ++ "' is already defined"))
648 -- give the expression a type signature, so we can be sure we're getting
649 -- something of the right type.
650 let new_expr = '(' : definition ++ ") :: String -> IO String"
652 -- compile the expression
654 maybe_hv <- io (cmCompileExpr cms new_expr)
657 Just hv -> io (writeIORef commands --
658 ((macro_name, keepGoing (runMacro hv)) : cmds))
660 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
662 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
663 stringLoop (lines str)
665 undefineMacro :: String -> GHCi ()
666 undefineMacro macro_name = do
667 cmds <- io (readIORef commands)
668 if (macro_name `elem` map fst builtin_commands)
669 then throwDyn (CmdLineError
670 ("command '" ++ macro_name ++ "' cannot be undefined"))
672 if (macro_name `notElem` map fst cmds)
673 then throwDyn (CmdLineError
674 ("command '" ++ macro_name ++ "' not defined"))
676 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
679 loadModule :: [FilePath] -> GHCi ()
680 loadModule fs = timeIt (loadModule' fs)
682 loadModule' :: [FilePath] -> GHCi ()
683 loadModule' files = do
684 state <- getGHCiState
687 files <- mapM expandPath files
689 -- do the dependency anal first, so that if it fails we don't throw
690 -- away the current set of modules.
691 graph <- io (cmDepAnal (cmstate state) files)
693 -- Dependency anal ok, now unload everything
694 cmstate1 <- io (cmUnload (cmstate state))
695 setGHCiState state{ cmstate = cmstate1, targets = [] }
697 io (revertCAFs) -- always revert CAFs on load.
698 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
699 setGHCiState state{ cmstate = cmstate2, targets = files }
701 setContextAfterLoad mods
702 dflags <- getDynFlags
703 modulesLoadedMsg ok mods dflags
706 reloadModule :: String -> GHCi ()
708 state <- getGHCiState
709 case targets state of
710 [] -> io (putStr "no current target\n")
712 -- do the dependency anal first, so that if it fails we don't throw
713 -- away the current set of modules.
714 graph <- io (cmDepAnal (cmstate state) paths)
716 io (revertCAFs) -- always revert CAFs on reload.
718 <- io (cmLoadModules (cmstate state) graph)
719 setGHCiState state{ cmstate=cmstate1 }
720 setContextAfterLoad mods
721 dflags <- getDynFlags
722 modulesLoadedMsg ok mods dflags
724 reloadModule _ = noArgs ":reload"
726 setContextAfterLoad [] = setContext prel
727 setContextAfterLoad (m:_) = do
728 cmstate <- getCmState
729 b <- io (cmModuleIsInterpreted cmstate m)
730 if b then setContext ('*':m) else setContext m
732 modulesLoadedMsg ok mods dflags =
733 when (verbosity dflags > 0) $ do
735 | null mods = text "none."
737 punctuate comma (map text mods)) <> text "."
740 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
742 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
745 typeOfExpr :: String -> GHCi ()
747 = do cms <- getCmState
748 maybe_tystr <- io (cmTypeOfExpr cms str)
751 Just tystr -> io (putStrLn tystr)
753 kindOfType :: String -> GHCi ()
755 = do cms <- getCmState
756 maybe_tystr <- io (cmKindOfType cms str)
759 Just tystr -> io (putStrLn tystr)
761 quit :: String -> GHCi Bool
764 shellEscape :: String -> GHCi Bool
765 shellEscape str = io (system str >> return False)
767 -----------------------------------------------------------------------------
768 -- Browsing a module's contents
770 browseCmd :: String -> GHCi ()
773 ['*':m] | looksLikeModuleName m -> browseModule m False
774 [m] | looksLikeModuleName m -> browseModule m True
775 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
777 browseModule m exports_only = do
780 is_interpreted <- io (cmModuleIsInterpreted cms m)
781 when (not is_interpreted && not exports_only) $
782 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
784 -- Temporarily set the context to the module we're interested in,
785 -- just so we can get an appropriate PrintUnqualified
786 (as,bs) <- io (cmGetContext cms)
787 cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
788 else cmSetContext cms [m] [])
789 cms2 <- io (cmSetContext cms1 as bs)
791 things <- io (cmBrowseModule cms2 m exports_only)
793 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
795 io (putStrLn (showSDocForUser unqual (
796 vcat (map (showDecl (const True)) things)
799 -----------------------------------------------------------------------------
800 -- Setting the module context
803 | all sensible mods = fn mods
804 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
806 (fn, mods) = case str of
807 '+':stuff -> (addToContext, words stuff)
808 '-':stuff -> (removeFromContext, words stuff)
809 stuff -> (newContext, words stuff)
811 sensible ('*':m) = looksLikeModuleName m
812 sensible m = looksLikeModuleName m
816 (as,bs) <- separate cms mods [] []
817 let bs' = if null as && prel `notElem` bs then prel:bs else bs
818 cms' <- io (cmSetContext cms as bs')
821 separate cmstate [] as bs = return (as,bs)
822 separate cmstate (('*':m):ms) as bs = do
823 b <- io (cmModuleIsInterpreted cmstate m)
824 if b then separate cmstate ms (m:as) bs
825 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
826 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
831 addToContext mods = do
833 (as,bs) <- io (cmGetContext cms)
835 (as',bs') <- separate cms mods [] []
837 let as_to_add = as' \\ (as ++ bs)
838 bs_to_add = bs' \\ (as ++ bs)
840 cms' <- io (cmSetContext cms
841 (as ++ as_to_add) (bs ++ bs_to_add))
845 removeFromContext mods = do
847 (as,bs) <- io (cmGetContext cms)
849 (as_to_remove,bs_to_remove) <- separate cms mods [] []
851 let as' = as \\ (as_to_remove ++ bs_to_remove)
852 bs' = bs \\ (as_to_remove ++ bs_to_remove)
854 cms' <- io (cmSetContext cms as' bs')
857 ----------------------------------------------------------------------------
860 -- set options in the interpreter. Syntax is exactly the same as the
861 -- ghc command line, except that certain options aren't available (-C,
864 -- This is pretty fragile: most options won't work as expected. ToDo:
865 -- figure out which ones & disallow them.
867 setCmd :: String -> GHCi ()
869 = do st <- getGHCiState
870 let opts = options st
871 io $ putStrLn (showSDoc (
872 text "options currently set: " <>
875 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
879 ("args":args) -> setArgs args
880 ("prog":prog) -> setProg prog
881 wds -> setOptions wds
885 setGHCiState st{ args = args }
889 setGHCiState st{ progname = prog }
891 io (hPutStrLn stderr "syntax: :set prog <progname>")
894 do -- first, deal with the GHCi opts (+s, +t, etc.)
895 let (plus_opts, minus_opts) = partition isPlus wds
896 mapM_ setOpt plus_opts
898 -- now, the GHC flags
899 leftovers <- io $ processStaticFlags minus_opts
901 -- then, dynamic flags
902 dflags <- getDynFlags
903 (dflags',leftovers) <- io $ processDynamicFlags leftovers dflags
906 -- update things if the users wants more packages
908 let new_packages = pkgs_after \\ pkgs_before
909 when (not (null new_packages)) $
910 newPackages new_packages
913 if (not (null leftovers))
914 then throwDyn (CmdLineError ("unrecognised flags: " ++
919 unsetOptions :: String -> GHCi ()
921 = do -- first, deal with the GHCi opts (+s, +t, etc.)
923 (minus_opts, rest1) = partition isMinus opts
924 (plus_opts, rest2) = partition isPlus rest1
926 if (not (null rest2))
927 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
930 mapM_ unsetOpt plus_opts
932 -- can't do GHC flags for now
933 if (not (null minus_opts))
934 then throwDyn (CmdLineError "can't unset GHC command-line flags")
937 isMinus ('-':s) = True
940 isPlus ('+':s) = True
944 = case strToGHCiOpt str of
945 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
946 Just o -> setOption o
949 = case strToGHCiOpt str of
950 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
951 Just o -> unsetOption o
953 strToGHCiOpt :: String -> (Maybe GHCiOption)
954 strToGHCiOpt "s" = Just ShowTiming
955 strToGHCiOpt "t" = Just ShowType
956 strToGHCiOpt "r" = Just RevertCAFs
957 strToGHCiOpt _ = Nothing
959 optToStr :: GHCiOption -> String
960 optToStr ShowTiming = "s"
961 optToStr ShowType = "t"
962 optToStr RevertCAFs = "r"
964 newPackages new_pkgs = do -- The new packages are already in v_Packages
965 state <- getGHCiState
966 cmstate1 <- io (cmUnload (cmstate state))
967 setGHCiState state{ cmstate = cmstate1, targets = [] }
968 dflags <- getDynFlags
969 io (linkPackages dflags new_pkgs)
970 setContextAfterLoad []
972 -- ---------------------------------------------------------------------------
977 ["modules" ] -> showModules
978 ["bindings"] -> showBindings
979 ["linker"] -> io showLinkerState
980 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
983 = do { cms <- getCmState
984 ; let show_one ms = io (putStrLn (cmShowModule cms ms))
985 ; mapM_ show_one (cmGetModuleGraph cms) }
990 unqual = cmGetPrintUnqual cms
991 -- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
992 showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
994 io (mapM_ showBinding (cmGetBindings cms))
998 -----------------------------------------------------------------------------
1001 data GHCiState = GHCiState
1005 targets :: [FilePath],
1007 options :: [GHCiOption]
1011 = ShowTiming -- show time/allocs after evaluation
1012 | ShowType -- show the type of expressions
1013 | RevertCAFs -- revert CAFs after every evaluation
1016 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1018 startGHCi :: GHCi a -> GHCiState -> IO a
1019 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1021 instance Monad GHCi where
1022 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1023 return a = GHCi $ \s -> return a
1025 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1026 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1027 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1029 getGHCiState = GHCi $ \r -> readIORef r
1030 setGHCiState s = GHCi $ \r -> writeIORef r s
1032 -- for convenience...
1033 getCmState = getGHCiState >>= return . cmstate
1034 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1036 getDynFlags = getCmState >>= return . cmGetDFlags
1038 setDynFlags dflags = do s <- getCmState; setCmState (cmSetDFlags s dflags)
1040 isOptionSet :: GHCiOption -> GHCi Bool
1042 = do st <- getGHCiState
1043 return (opt `elem` options st)
1045 setOption :: GHCiOption -> GHCi ()
1047 = do st <- getGHCiState
1048 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1050 unsetOption :: GHCiOption -> GHCi ()
1052 = do st <- getGHCiState
1053 setGHCiState (st{ options = filter (/= opt) (options st) })
1055 io :: IO a -> GHCi a
1056 io m = GHCi { unGHCi = \s -> m >>= return }
1058 -----------------------------------------------------------------------------
1059 -- recursive exception handlers
1061 -- Don't forget to unblock async exceptions in the handler, or if we're
1062 -- in an exception loop (eg. let a = error a in a) the ^C exception
1063 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1065 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1066 ghciHandle h (GHCi m) = GHCi $ \s ->
1067 Exception.catch (m s)
1068 (\e -> unGHCi (ghciUnblock (h e)) s)
1070 ghciUnblock :: GHCi a -> GHCi a
1071 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1073 -----------------------------------------------------------------------------
1074 -- timing & statistics
1076 timeIt :: GHCi a -> GHCi a
1078 = do b <- isOptionSet ShowTiming
1081 else do allocs1 <- io $ getAllocations
1082 time1 <- io $ getCPUTime
1084 allocs2 <- io $ getAllocations
1085 time2 <- io $ getCPUTime
1086 io $ printTimes (fromIntegral (allocs2 - allocs1))
1090 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1091 -- defined in ghc/rts/Stats.c
1093 printTimes :: Integer -> Integer -> IO ()
1094 printTimes allocs psecs
1095 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1096 secs_str = showFFloat (Just 2) secs
1097 putStrLn (showSDoc (
1098 parens (text (secs_str "") <+> text "secs" <> comma <+>
1099 text (show allocs) <+> text "bytes")))
1101 -----------------------------------------------------------------------------
1108 -- Have to turn off buffering again, because we just
1109 -- reverted stdout, stderr & stdin to their defaults.
1111 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1112 -- Make it "safe", just in case
1114 -- -----------------------------------------------------------------------------
1117 expandPath :: String -> GHCi String
1119 case dropWhile isSpace path of
1121 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1122 return (tilde ++ '/':d)