1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.174 2004/08/16 09:53:57 simonpj Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2004
9 -----------------------------------------------------------------------------
10 module InteractiveUI (
11 interactiveUI, -- :: CmState -> [FilePath] -> IO ()
15 #include "../includes/ghcconfig.h"
16 #include "HsVersions.h"
19 import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
20 isObjectLinkable, GhciMode(..) )
21 import IfaceSyn ( IfaceType, IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
22 IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
23 import FunDeps ( pprFundeps )
26 import DriverUtil ( remove_spaces )
27 import Linker ( showLinkerState, linkPackages )
29 import Module ( showModMsg, lookupModuleEnv )
30 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
32 import OccName ( OccName, isSymOcc, occNameUserString )
33 import BasicTypes ( StrictnessMark(..), Fixity, defaultFixity, SuccessFlag(..) )
36 import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
37 restoreDynFlags, dopt_unset )
38 import Panic hiding ( showException )
40 import SrcLoc ( SrcLoc, isGoodSrcLoc )
42 #ifndef mingw32_HOST_OS
43 import DriverUtil( handle )
45 #if __GLASGOW_HASKELL__ > 504
50 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
51 import Control.Concurrent ( yield ) -- Used in readline loop
52 import System.Console.Readline as Readline
57 import Control.Exception as Exception
59 import Control.Concurrent
63 import Data.Int ( Int64 )
66 import System.Environment
67 import System.Directory
68 import System.IO as IO
70 import Control.Monad as Monad
72 import GHC.Exts ( unsafeCoerce# )
74 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
76 import System.Posix.Internals ( setNonBlockingFD )
78 -----------------------------------------------------------------------------
82 " / _ \\ /\\ /\\/ __(_)\n"++
83 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
84 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
85 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
87 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
89 builtin_commands :: [(String, String -> GHCi Bool)]
91 ("add", keepGoingPaths addModule),
92 ("browse", keepGoing browseCmd),
93 ("cd", keepGoing changeDirectory),
94 ("def", keepGoing defineMacro),
95 ("help", keepGoing help),
96 ("?", keepGoing help),
97 ("info", keepGoing info),
98 ("load", keepGoingPaths loadModule),
99 ("module", keepGoing setContext),
100 ("reload", keepGoing reloadModule),
101 ("set", keepGoing setCmd),
102 ("show", keepGoing showCmd),
103 ("type", keepGoing typeOfExpr),
104 ("kind", keepGoing kindOfType),
105 ("unset", keepGoing unsetOptions),
106 ("undef", keepGoing undefineMacro),
110 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
111 keepGoing a str = a str >> return False
113 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
114 keepGoingPaths a str = a (toArgs str) >> return False
116 shortHelpText = "use :? for help.\n"
118 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
120 " Commands available from the prompt:\n" ++
122 " <stmt> evaluate/run <stmt>\n" ++
123 " :add <filename> ... add module(s) to the current target set\n" ++
124 " :browse [*]<module> display the names defined by <module>\n" ++
125 " :cd <dir> change directory to <dir>\n" ++
126 " :def <cmd> <expr> define a command :<cmd>\n" ++
127 " :help, :? display this list of commands\n" ++
128 " :info [<name> ...] display information about the given names\n" ++
129 " :load <filename> ... load module(s) and their dependents\n" ++
130 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
131 " :reload reload the current module set\n" ++
133 " :set <option> ... set options\n" ++
134 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
135 " :set prog <progname> set the value returned by System.getProgName\n" ++
137 " :show modules show the currently loaded modules\n" ++
138 " :show bindings show the current bindings made at the prompt\n" ++
140 " :type <expr> show the type of <expr>\n" ++
141 " :kind <type> show the kind of <type>\n" ++
142 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
143 " :unset <option> ... unset options\n" ++
144 " :quit exit GHCi\n" ++
145 " :!<command> run the shell command <command>\n" ++
147 " Options for ':set' and ':unset':\n" ++
149 " +r revert top-level expressions after each evaluation\n" ++
150 " +s print timing/memory stats after each evaluation\n" ++
151 " +t print type after evaluation\n" ++
152 " -<flags> most GHC command line flags can also be set here\n" ++
153 " (eg. -v2, -fglasgow-exts, etc.)\n"
156 interactiveUI :: [FilePath] -> Maybe String -> IO ()
157 interactiveUI srcs maybe_expr = do
158 dflags <- getDynFlags
160 cmstate <- cmInit Interactive dflags;
163 hSetBuffering stdout NoBuffering
165 -- Initialise buffering for the *interpreted* I/O system
166 initInterpBuffering cmstate
168 -- We don't want the cmd line to buffer any input that might be
169 -- intended for the program, so unbuffer stdin.
170 hSetBuffering stdin NoBuffering
172 -- initial context is just the Prelude
173 cmstate <- cmSetContext cmstate [] ["Prelude"]
175 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
179 startGHCi (runGHCi srcs dflags maybe_expr)
180 GHCiState{ progname = "<interactive>",
186 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
187 Readline.resetTerminal Nothing
192 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
193 runGHCi paths dflags maybe_expr = do
194 read_dot_files <- io (readIORef v_Read_DotGHCi)
196 when (read_dot_files) $ do
199 exists <- io (doesFileExist file)
201 dir_ok <- io (checkPerms ".")
202 file_ok <- io (checkPerms file)
203 when (dir_ok && file_ok) $ do
204 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
207 Right hdl -> fileLoop hdl False
209 when (read_dot_files) $ do
210 -- Read in $HOME/.ghci
211 either_dir <- io (IO.try (getEnv "HOME"))
215 cwd <- io (getCurrentDirectory)
216 when (dir /= cwd) $ do
217 let file = dir ++ "/.ghci"
218 ok <- io (checkPerms file)
220 either_hdl <- io (IO.try (openFile file ReadMode))
223 Right hdl -> fileLoop hdl False
225 -- Perform a :load for files given on the GHCi command line
226 when (not (null paths)) $
227 ghciHandle showException $
230 -- if verbosity is greater than 0, or we are connected to a
231 -- terminal, display the prompt in the interactive loop.
232 is_tty <- io (hIsTerminalDevice stdin)
233 let show_prompt = verbosity dflags > 0 || is_tty
237 -- enter the interactive loop
238 interactiveLoop is_tty show_prompt
240 -- just evaluate the expression we were given
245 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
248 interactiveLoop is_tty show_prompt = do
249 -- Ignore ^C exceptions caught here
250 ghciHandleDyn (\e -> case e of
251 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
252 _other -> return ()) $ do
254 -- read commands from stdin
255 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
258 else fileLoop stdin show_prompt
260 fileLoop stdin show_prompt
264 -- NOTE: We only read .ghci files if they are owned by the current user,
265 -- and aren't world writable. Otherwise, we could be accidentally
266 -- running code planted by a malicious third party.
268 -- Furthermore, We only read ./.ghci if . is owned by the current user
269 -- and isn't writable by anyone else. I think this is sufficient: we
270 -- don't need to check .. and ../.. etc. because "." always refers to
271 -- the same directory while a process is running.
273 checkPerms :: String -> IO Bool
275 #ifdef mingw32_HOST_OS
278 DriverUtil.handle (\_ -> return False) $ do
279 st <- getFileStatus name
281 if fileOwner st /= me then do
282 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
285 let mode = fileMode st
286 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
287 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
289 putStrLn $ "*** WARNING: " ++ name ++
290 " is writable by someone else, IGNORING!"
295 fileLoop :: Handle -> Bool -> GHCi ()
296 fileLoop hdl prompt = do
297 cmstate <- getCmState
298 (mod,imports) <- io (cmGetContext cmstate)
299 when prompt (io (putStr (mkPrompt mod imports)))
300 l <- io (IO.try (hGetLine hdl))
302 Left e | isEOFError e -> return ()
303 | otherwise -> io (ioError e)
305 case remove_spaces l of
306 "" -> fileLoop hdl prompt
307 l -> do quit <- runCommand l
308 if quit then return () else fileLoop hdl prompt
310 stringLoop :: [String] -> GHCi ()
311 stringLoop [] = return ()
312 stringLoop (s:ss) = do
313 case remove_spaces s of
315 l -> do quit <- runCommand l
316 if quit then return () else stringLoop ss
318 mkPrompt toplevs exports
319 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
321 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
322 readlineLoop :: GHCi ()
324 cmstate <- getCmState
325 (mod,imports) <- io (cmGetContext cmstate)
327 l <- io (readline (mkPrompt mod imports)
328 `finally` setNonBlockingFD 0)
329 -- readline sometimes puts stdin into blocking mode,
330 -- so we need to put it back for the IO library
334 case remove_spaces l of
339 if quit then return () else readlineLoop
342 runCommand :: String -> GHCi Bool
343 runCommand c = ghciHandle handler (doCommand c)
345 -- This is the exception handler for exceptions generated by the
346 -- user's code; it normally just prints out the exception. The
347 -- handler must be recursive, in case showing the exception causes
348 -- more exceptions to be raised.
350 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
351 -- raising another exception. We therefore don't put the recursive
352 -- handler arond the flushing operation, so if stderr is closed
353 -- GHCi will just die gracefully rather than going into an infinite loop.
354 handler :: Exception -> GHCi Bool
355 handler exception = do
357 io installSignalHandlers
358 ghciHandle handler (showException exception >> return False)
360 showException (DynException dyn) =
361 case fromDynamic dyn of
362 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
363 Just Interrupted -> io (putStrLn "Interrupted.")
364 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
365 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
366 Just other_ghc_ex -> io (print other_ghc_ex)
368 showException other_exception
369 = io (putStrLn ("*** Exception: " ++ show other_exception))
371 doCommand (':' : command) = specialCommand command
373 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
376 runStmt :: String -> GHCi [Name]
378 | null (filter (not.isSpace) stmt) = return []
380 = do st <- getGHCiState
381 dflags <- io getDynFlags
382 let cm_state' = cmSetDFlags (cmstate st)
383 (dopt_unset dflags Opt_WarnUnusedBinds)
384 (new_cmstate, result) <-
385 io $ withProgName (progname st) $ withArgs (args st) $
386 cmRunStmt cm_state' stmt
387 setGHCiState st{cmstate = new_cmstate}
389 CmRunFailed -> return []
390 CmRunException e -> showException e >> return []
391 CmRunOk names -> return names
393 -- possibly print the type and revert CAFs after evaluating an expression
395 = do b <- isOptionSet ShowType
396 cmstate <- getCmState
397 when b (mapM_ (showTypeOfName cmstate) names)
400 io installSignalHandlers
401 b <- isOptionSet RevertCAFs
402 io (when b revertCAFs)
405 showTypeOfName :: CmState -> Name -> GHCi ()
406 showTypeOfName cmstate n
407 = do maybe_str <- io (cmTypeOfName cmstate n)
410 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
412 specialCommand :: String -> GHCi Bool
413 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
414 specialCommand str = do
415 let (cmd,rest) = break isSpace str
416 cmds <- io (readIORef commands)
417 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
418 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
419 ++ shortHelpText) >> return False)
420 [(_,f)] -> f (dropWhile isSpace rest)
421 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
422 " matches multiple commands (" ++
423 foldr1 (\a b -> a ++ ',':b) (map fst cs)
424 ++ ")") >> return False)
426 noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
429 -----------------------------------------------------------------------------
430 -- To flush buffers for the *interpreted* computation we need
431 -- to refer to *its* stdout/stderr handles
433 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
434 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
436 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
437 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
438 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
440 initInterpBuffering :: CmState -> IO ()
441 initInterpBuffering cmstate
442 = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
445 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
446 other -> panic "interactiveUI:setBuffering"
448 maybe_hval <- cmCompileExpr cmstate flush_cmd
450 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
451 _ -> panic "interactiveUI:flush"
453 turnOffBuffering -- Turn it off right now
458 flushInterpBuffers :: GHCi ()
460 = io $ do Monad.join (readIORef flush_interp)
463 turnOffBuffering :: IO ()
465 = do Monad.join (readIORef turn_off_buffering)
468 -----------------------------------------------------------------------------
471 help :: String -> GHCi ()
472 help _ = io (putStr helpText)
474 info :: String -> GHCi ()
475 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
476 info s = do { let names = words s
477 ; init_cms <- getCmState
478 ; mapM_ (infoThing init_cms) names }
481 = do { stuff <- io (cmGetInfo cms name)
482 ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
483 vcat (intersperse (text "") (map showThing stuff)))) }
485 showThing :: GetInfoResult -> SDoc
486 showThing (wanted_str, (thing, fixity, src_loc, insts))
487 = vcat [ showDecl want_name thing,
490 vcat (map show_inst insts)]
492 want_name occ = wanted_str == occNameUserString occ
495 | fix == defaultFixity = empty
496 | otherwise = ppr fix <+> text wanted_str
498 show_loc loc -- The ppr function for SrcLocs is a bit wonky
499 | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
500 | otherwise = comment <+> ppr loc
501 comment = ptext SLIT("--")
503 show_inst (iface_inst, loc)
504 = hang (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
505 2 (char '\t' <> show_loc loc)
506 -- The tab tries to make them line up a bit
508 -- Now there is rather a lot of goop just to print declarations in a
509 -- civilised way with "..." for the parts we are less interested in.
511 showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc
512 showDecl want_name (IfaceForeign {ifName = tc})
513 = ppr tc <+> ptext SLIT("is a foreign type")
515 showDecl want_name (IfaceId {ifName = var, ifType = ty})
516 = ppr var <+> dcolon <+> ppr ty
518 showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
519 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
520 2 (equals <+> ppr mono_ty)
522 showDecl want_name (IfaceData {ifCtxt = context, ifName = tycon,
523 ifTyVars = tyvars, ifCons = condecls})
524 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
525 2 (add_bars (ppr_trim show_con cs))
527 show_con (IfaceConDecl con_name is_infix ex_tvs ex_cxt tys strs flds)
528 | want_name tycon || want_name con_name || any want_name flds
529 = Just (pprIfaceForAllPart ex_tvs ex_cxt (show_guts con_name is_infix tys_w_strs flds))
530 | otherwise = Nothing
532 tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
534 show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
535 show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
536 show_guts con _ tys flds
537 = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
539 show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
540 = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
541 | otherwise = Nothing
543 (pp_nd, cs) = case condecls of
544 IfAbstractTyCon -> (ptext SLIT("data"), [])
545 IfDataTyCon cs -> (ptext SLIT("data"), cs)
546 IfNewTyCon c -> (ptext SLIT("newtype"), [c])
549 add_bars [c] = equals <+> c
550 add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
552 ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
553 ppr_str MarkedStrict = char '!'
554 ppr_str MarkedUnboxed = ptext SLIT("!!")
555 ppr_str NotMarkedStrict = empty
557 showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
558 ifFDs = fds, ifSigs = sigs})
559 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
560 <+> pprFundeps fds <+> ptext SLIT("where"))
561 2 (vcat (ppr_trim show_op sigs))
563 show_op (IfaceClassOp op dm ty)
564 | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty)
565 | otherwise = Nothing
567 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
569 = snd (foldr go (False, []) xs)
571 go x (eliding, so_far)
572 | Just doc <- show x = (False, doc : so_far)
573 | otherwise = if eliding then (True, so_far)
574 else (True, ptext SLIT("...") : so_far)
576 ppr_bndr :: OccName -> SDoc
577 -- Wrap operators in ()
578 ppr_bndr occ | isSymOcc occ = parens (ppr occ)
579 | otherwise = ppr occ
582 -----------------------------------------------------------------------------
585 addModule :: [FilePath] -> GHCi ()
587 state <- getGHCiState
588 io (revertCAFs) -- always revert CAFs on load/add.
589 files <- mapM expandPath files
590 let new_targets = files ++ targets state
591 graph <- io (cmDepAnal (cmstate state) new_targets)
592 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
593 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
594 setContextAfterLoad mods
595 dflags <- io getDynFlags
596 modulesLoadedMsg ok mods dflags
598 changeDirectory :: String -> GHCi ()
599 changeDirectory dir = do
600 state <- getGHCiState
601 when (targets state /= []) $
602 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
603 cmstate1 <- io (cmUnload (cmstate state))
604 setGHCiState state{ cmstate = cmstate1, targets = [] }
605 setContextAfterLoad []
606 dir <- expandPath dir
607 io (setCurrentDirectory dir)
609 defineMacro :: String -> GHCi ()
611 let (macro_name, definition) = break isSpace s
612 cmds <- io (readIORef commands)
614 then throwDyn (CmdLineError "invalid macro name")
616 if (macro_name `elem` map fst cmds)
617 then throwDyn (CmdLineError
618 ("command '" ++ macro_name ++ "' is already defined"))
621 -- give the expression a type signature, so we can be sure we're getting
622 -- something of the right type.
623 let new_expr = '(' : definition ++ ") :: String -> IO String"
625 -- compile the expression
627 maybe_hv <- io (cmCompileExpr cms new_expr)
630 Just hv -> io (writeIORef commands --
631 ((macro_name, keepGoing (runMacro hv)) : cmds))
633 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
635 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
636 stringLoop (lines str)
638 undefineMacro :: String -> GHCi ()
639 undefineMacro macro_name = do
640 cmds <- io (readIORef commands)
641 if (macro_name `elem` map fst builtin_commands)
642 then throwDyn (CmdLineError
643 ("command '" ++ macro_name ++ "' cannot be undefined"))
645 if (macro_name `notElem` map fst cmds)
646 then throwDyn (CmdLineError
647 ("command '" ++ macro_name ++ "' not defined"))
649 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
652 loadModule :: [FilePath] -> GHCi ()
653 loadModule fs = timeIt (loadModule' fs)
655 loadModule' :: [FilePath] -> GHCi ()
656 loadModule' files = do
657 state <- getGHCiState
660 files <- mapM expandPath files
662 -- do the dependency anal first, so that if it fails we don't throw
663 -- away the current set of modules.
664 graph <- io (cmDepAnal (cmstate state) files)
666 -- Dependency anal ok, now unload everything
667 cmstate1 <- io (cmUnload (cmstate state))
668 setGHCiState state{ cmstate = cmstate1, targets = [] }
670 io (revertCAFs) -- always revert CAFs on load.
671 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
672 setGHCiState state{ cmstate = cmstate2, targets = files }
674 setContextAfterLoad mods
675 dflags <- io (getDynFlags)
676 modulesLoadedMsg ok mods dflags
679 reloadModule :: String -> GHCi ()
681 state <- getGHCiState
682 case targets state of
683 [] -> io (putStr "no current target\n")
685 -- do the dependency anal first, so that if it fails we don't throw
686 -- away the current set of modules.
687 graph <- io (cmDepAnal (cmstate state) paths)
689 io (revertCAFs) -- always revert CAFs on reload.
691 <- io (cmLoadModules (cmstate state) graph)
692 setGHCiState state{ cmstate=cmstate1 }
693 setContextAfterLoad mods
694 dflags <- io getDynFlags
695 modulesLoadedMsg ok mods dflags
697 reloadModule _ = noArgs ":reload"
699 setContextAfterLoad [] = setContext prel
700 setContextAfterLoad (m:_) = do
701 cmstate <- getCmState
702 b <- io (cmModuleIsInterpreted cmstate m)
703 if b then setContext ('*':m) else setContext m
705 modulesLoadedMsg ok mods dflags =
706 when (verbosity dflags > 0) $ do
708 | null mods = text "none."
710 punctuate comma (map text mods)) <> text "."
713 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
715 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
718 typeOfExpr :: String -> GHCi ()
720 = do cms <- getCmState
721 maybe_tystr <- io (cmTypeOfExpr cms str)
724 Just tystr -> io (putStrLn tystr)
726 kindOfType :: String -> GHCi ()
728 = do cms <- getCmState
729 maybe_tystr <- io (cmKindOfType cms str)
732 Just tystr -> io (putStrLn tystr)
734 quit :: String -> GHCi Bool
737 shellEscape :: String -> GHCi Bool
738 shellEscape str = io (system str >> return False)
740 -----------------------------------------------------------------------------
741 -- Browsing a module's contents
743 browseCmd :: String -> GHCi ()
746 ['*':m] | looksLikeModuleName m -> browseModule m False
747 [m] | looksLikeModuleName m -> browseModule m True
748 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
750 browseModule m exports_only = do
753 is_interpreted <- io (cmModuleIsInterpreted cms m)
754 when (not is_interpreted && not exports_only) $
755 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
757 -- Temporarily set the context to the module we're interested in,
758 -- just so we can get an appropriate PrintUnqualified
759 (as,bs) <- io (cmGetContext cms)
760 cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
761 else cmSetContext cms [m] [])
762 cms2 <- io (cmSetContext cms1 as bs)
764 things <- io (cmBrowseModule cms2 m exports_only)
766 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
768 io (putStrLn (showSDocForUser unqual (
769 vcat (map (showDecl (const True)) things)
772 -----------------------------------------------------------------------------
773 -- Setting the module context
776 | all sensible mods = fn mods
777 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
779 (fn, mods) = case str of
780 '+':stuff -> (addToContext, words stuff)
781 '-':stuff -> (removeFromContext, words stuff)
782 stuff -> (newContext, words stuff)
784 sensible ('*':m) = looksLikeModuleName m
785 sensible m = looksLikeModuleName m
789 (as,bs) <- separate cms mods [] []
790 let bs' = if null as && prel `notElem` bs then prel:bs else bs
791 cms' <- io (cmSetContext cms as bs')
794 separate cmstate [] as bs = return (as,bs)
795 separate cmstate (('*':m):ms) as bs = do
796 b <- io (cmModuleIsInterpreted cmstate m)
797 if b then separate cmstate ms (m:as) bs
798 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
799 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
804 addToContext mods = do
806 (as,bs) <- io (cmGetContext cms)
808 (as',bs') <- separate cms mods [] []
810 let as_to_add = as' \\ (as ++ bs)
811 bs_to_add = bs' \\ (as ++ bs)
813 cms' <- io (cmSetContext cms
814 (as ++ as_to_add) (bs ++ bs_to_add))
818 removeFromContext mods = do
820 (as,bs) <- io (cmGetContext cms)
822 (as_to_remove,bs_to_remove) <- separate cms mods [] []
824 let as' = as \\ (as_to_remove ++ bs_to_remove)
825 bs' = bs \\ (as_to_remove ++ bs_to_remove)
827 cms' <- io (cmSetContext cms as' bs')
830 ----------------------------------------------------------------------------
833 -- set options in the interpreter. Syntax is exactly the same as the
834 -- ghc command line, except that certain options aren't available (-C,
837 -- This is pretty fragile: most options won't work as expected. ToDo:
838 -- figure out which ones & disallow them.
840 setCmd :: String -> GHCi ()
842 = do st <- getGHCiState
843 let opts = options st
844 io $ putStrLn (showSDoc (
845 text "options currently set: " <>
848 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
852 ("args":args) -> setArgs args
853 ("prog":prog) -> setProg prog
854 wds -> setOptions wds
858 setGHCiState st{ args = args }
862 setGHCiState st{ progname = prog }
864 io (hPutStrLn stderr "syntax: :set prog <progname>")
867 do -- first, deal with the GHCi opts (+s, +t, etc.)
868 let (plus_opts, minus_opts) = partition isPlus wds
869 mapM_ setOpt plus_opts
871 -- now, the GHC flags
872 pkgs_before <- io (readIORef v_ExplicitPackages)
873 leftovers <- io (processArgs static_flags minus_opts [])
874 pkgs_after <- io (readIORef v_ExplicitPackages)
876 -- update things if the users wants more packages
877 let new_packages = pkgs_after \\ pkgs_before
878 when (not (null new_packages)) $
879 newPackages new_packages
881 -- don't forget about the extra command-line flags from the
882 -- extra_ghc_opts fields in the new packages
883 new_package_details <- io (getPackageDetails new_packages)
884 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
885 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
887 -- then, dynamic flags
890 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
893 if (not (null leftovers))
894 then throwDyn (CmdLineError ("unrecognised flags: " ++
899 unsetOptions :: String -> GHCi ()
901 = do -- first, deal with the GHCi opts (+s, +t, etc.)
903 (minus_opts, rest1) = partition isMinus opts
904 (plus_opts, rest2) = partition isPlus rest1
906 if (not (null rest2))
907 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
910 mapM_ unsetOpt plus_opts
912 -- can't do GHC flags for now
913 if (not (null minus_opts))
914 then throwDyn (CmdLineError "can't unset GHC command-line flags")
917 isMinus ('-':s) = True
920 isPlus ('+':s) = True
924 = case strToGHCiOpt str of
925 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
926 Just o -> setOption o
929 = case strToGHCiOpt str of
930 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
931 Just o -> unsetOption o
933 strToGHCiOpt :: String -> (Maybe GHCiOption)
934 strToGHCiOpt "s" = Just ShowTiming
935 strToGHCiOpt "t" = Just ShowType
936 strToGHCiOpt "r" = Just RevertCAFs
937 strToGHCiOpt _ = Nothing
939 optToStr :: GHCiOption -> String
940 optToStr ShowTiming = "s"
941 optToStr ShowType = "t"
942 optToStr RevertCAFs = "r"
944 newPackages new_pkgs = do -- The new packages are already in v_Packages
945 state <- getGHCiState
946 cmstate1 <- io (cmUnload (cmstate state))
947 setGHCiState state{ cmstate = cmstate1, targets = [] }
948 dflags <- io getDynFlags
949 io (linkPackages dflags new_pkgs)
950 setContextAfterLoad []
952 -- ---------------------------------------------------------------------------
957 ["modules" ] -> showModules
958 ["bindings"] -> showBindings
959 ["linker"] -> io showLinkerState
960 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
964 let (mg, hpt) = cmGetModInfo cms
965 mapM_ (showModule hpt) mg
968 showModule :: HomePackageTable -> ModSummary -> GHCi ()
969 showModule hpt mod_summary
970 = case lookupModuleEnv hpt mod of
971 Nothing -> panic "missing linkable"
972 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
974 obj_linkable = isObjectLinkable (hm_linkable mod_info)
976 mod = ms_mod mod_summary
977 locn = ms_location mod_summary
982 unqual = cmGetPrintUnqual cms
983 -- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
984 showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
986 io (mapM_ showBinding (cmGetBindings cms))
990 -----------------------------------------------------------------------------
993 data GHCiState = GHCiState
997 targets :: [FilePath],
999 options :: [GHCiOption]
1003 = ShowTiming -- show time/allocs after evaluation
1004 | ShowType -- show the type of expressions
1005 | RevertCAFs -- revert CAFs after every evaluation
1008 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1010 startGHCi :: GHCi a -> GHCiState -> IO a
1011 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1013 instance Monad GHCi where
1014 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1015 return a = GHCi $ \s -> return a
1017 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1018 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1019 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1021 getGHCiState = GHCi $ \r -> readIORef r
1022 setGHCiState s = GHCi $ \r -> writeIORef r s
1024 -- for convenience...
1025 getCmState = getGHCiState >>= return . cmstate
1026 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1028 isOptionSet :: GHCiOption -> GHCi Bool
1030 = do st <- getGHCiState
1031 return (opt `elem` options st)
1033 setOption :: GHCiOption -> GHCi ()
1035 = do st <- getGHCiState
1036 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1038 unsetOption :: GHCiOption -> GHCi ()
1040 = do st <- getGHCiState
1041 setGHCiState (st{ options = filter (/= opt) (options st) })
1043 io :: IO a -> GHCi a
1044 io m = GHCi { unGHCi = \s -> m >>= return }
1046 -----------------------------------------------------------------------------
1047 -- recursive exception handlers
1049 -- Don't forget to unblock async exceptions in the handler, or if we're
1050 -- in an exception loop (eg. let a = error a in a) the ^C exception
1051 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1053 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1054 ghciHandle h (GHCi m) = GHCi $ \s ->
1055 Exception.catch (m s)
1056 (\e -> unGHCi (ghciUnblock (h e)) s)
1058 ghciUnblock :: GHCi a -> GHCi a
1059 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1061 -----------------------------------------------------------------------------
1062 -- timing & statistics
1064 timeIt :: GHCi a -> GHCi a
1066 = do b <- isOptionSet ShowTiming
1069 else do allocs1 <- io $ getAllocations
1070 time1 <- io $ getCPUTime
1072 allocs2 <- io $ getAllocations
1073 time2 <- io $ getCPUTime
1074 io $ printTimes (fromIntegral (allocs2 - allocs1))
1078 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1079 -- defined in ghc/rts/Stats.c
1081 printTimes :: Integer -> Integer -> IO ()
1082 printTimes allocs psecs
1083 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1084 secs_str = showFFloat (Just 2) secs
1085 putStrLn (showSDoc (
1086 parens (text (secs_str "") <+> text "secs" <> comma <+>
1087 text (show allocs) <+> text "bytes")))
1089 -----------------------------------------------------------------------------
1096 -- Have to turn off buffering again, because we just
1097 -- reverted stdout, stderr & stdin to their defaults.
1099 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1100 -- Make it "safe", just in case
1102 -- -----------------------------------------------------------------------------
1105 expandPath :: String -> GHCi String
1107 case dropWhile isSpace path of
1109 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1110 return (tilde ++ '/':d)