1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.175 2004/08/20 15:02:40 simonmar 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
71 import Foreign.StablePtr ( newStablePtr )
73 import GHC.Exts ( unsafeCoerce# )
75 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
77 import System.Posix.Internals ( setNonBlockingFD )
79 -----------------------------------------------------------------------------
83 " / _ \\ /\\ /\\/ __(_)\n"++
84 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
85 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
86 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
88 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
90 builtin_commands :: [(String, String -> GHCi Bool)]
92 ("add", keepGoingPaths addModule),
93 ("browse", keepGoing browseCmd),
94 ("cd", keepGoing changeDirectory),
95 ("def", keepGoing defineMacro),
96 ("help", keepGoing help),
97 ("?", keepGoing help),
98 ("info", keepGoing info),
99 ("load", keepGoingPaths loadModule),
100 ("module", keepGoing setContext),
101 ("reload", keepGoing reloadModule),
102 ("set", keepGoing setCmd),
103 ("show", keepGoing showCmd),
104 ("type", keepGoing typeOfExpr),
105 ("kind", keepGoing kindOfType),
106 ("unset", keepGoing unsetOptions),
107 ("undef", keepGoing undefineMacro),
111 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
112 keepGoing a str = a str >> return False
114 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
115 keepGoingPaths a str = a (toArgs str) >> return False
117 shortHelpText = "use :? for help.\n"
119 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
121 " Commands available from the prompt:\n" ++
123 " <stmt> evaluate/run <stmt>\n" ++
124 " :add <filename> ... add module(s) to the current target set\n" ++
125 " :browse [*]<module> display the names defined by <module>\n" ++
126 " :cd <dir> change directory to <dir>\n" ++
127 " :def <cmd> <expr> define a command :<cmd>\n" ++
128 " :help, :? display this list of commands\n" ++
129 " :info [<name> ...] display information about the given names\n" ++
130 " :load <filename> ... load module(s) and their dependents\n" ++
131 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
132 " :reload reload the current module set\n" ++
134 " :set <option> ... set options\n" ++
135 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
136 " :set prog <progname> set the value returned by System.getProgName\n" ++
138 " :show modules show the currently loaded modules\n" ++
139 " :show bindings show the current bindings made at the prompt\n" ++
141 " :type <expr> show the type of <expr>\n" ++
142 " :kind <type> show the kind of <type>\n" ++
143 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
144 " :unset <option> ... unset options\n" ++
145 " :quit exit GHCi\n" ++
146 " :!<command> run the shell command <command>\n" ++
148 " Options for ':set' and ':unset':\n" ++
150 " +r revert top-level expressions after each evaluation\n" ++
151 " +s print timing/memory stats after each evaluation\n" ++
152 " +t print type after evaluation\n" ++
153 " -<flags> most GHC command line flags can also be set here\n" ++
154 " (eg. -v2, -fglasgow-exts, etc.)\n"
157 interactiveUI :: [FilePath] -> Maybe String -> IO ()
158 interactiveUI srcs maybe_expr = do
159 dflags <- getDynFlags
161 cmstate <- cmInit Interactive dflags;
163 -- HACK! If we happen to get into an infinite loop (eg the user
164 -- types 'let x=x in x' at the prompt), then the thread will block
165 -- on a blackhole, and become unreachable during GC. The GC will
166 -- detect that it is unreachable and send it the NonTermination
167 -- exception. However, since the thread is unreachable, everything
168 -- it refers to might be finalized, including the standard Handles.
169 -- This sounds like a bug, but we don't have a good solution right
176 hSetBuffering stdout NoBuffering
178 -- Initialise buffering for the *interpreted* I/O system
179 initInterpBuffering cmstate
181 -- We don't want the cmd line to buffer any input that might be
182 -- intended for the program, so unbuffer stdin.
183 hSetBuffering stdin NoBuffering
185 -- initial context is just the Prelude
186 cmstate <- cmSetContext cmstate [] ["Prelude"]
188 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
192 startGHCi (runGHCi srcs dflags maybe_expr)
193 GHCiState{ progname = "<interactive>",
199 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
200 Readline.resetTerminal Nothing
205 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
206 runGHCi paths dflags maybe_expr = do
207 read_dot_files <- io (readIORef v_Read_DotGHCi)
209 when (read_dot_files) $ do
212 exists <- io (doesFileExist file)
214 dir_ok <- io (checkPerms ".")
215 file_ok <- io (checkPerms file)
216 when (dir_ok && file_ok) $ do
217 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
220 Right hdl -> fileLoop hdl False
222 when (read_dot_files) $ do
223 -- Read in $HOME/.ghci
224 either_dir <- io (IO.try (getEnv "HOME"))
228 cwd <- io (getCurrentDirectory)
229 when (dir /= cwd) $ do
230 let file = dir ++ "/.ghci"
231 ok <- io (checkPerms file)
233 either_hdl <- io (IO.try (openFile file ReadMode))
236 Right hdl -> fileLoop hdl False
238 -- Perform a :load for files given on the GHCi command line
239 when (not (null paths)) $
240 ghciHandle showException $
243 -- if verbosity is greater than 0, or we are connected to a
244 -- terminal, display the prompt in the interactive loop.
245 is_tty <- io (hIsTerminalDevice stdin)
246 let show_prompt = verbosity dflags > 0 || is_tty
250 -- enter the interactive loop
251 interactiveLoop is_tty show_prompt
253 -- just evaluate the expression we were given
258 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
261 interactiveLoop is_tty show_prompt = do
262 -- Ignore ^C exceptions caught here
263 ghciHandleDyn (\e -> case e of
264 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
265 _other -> return ()) $ do
267 -- read commands from stdin
268 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
271 else fileLoop stdin show_prompt
273 fileLoop stdin show_prompt
277 -- NOTE: We only read .ghci files if they are owned by the current user,
278 -- and aren't world writable. Otherwise, we could be accidentally
279 -- running code planted by a malicious third party.
281 -- Furthermore, We only read ./.ghci if . is owned by the current user
282 -- and isn't writable by anyone else. I think this is sufficient: we
283 -- don't need to check .. and ../.. etc. because "." always refers to
284 -- the same directory while a process is running.
286 checkPerms :: String -> IO Bool
288 #ifdef mingw32_HOST_OS
291 DriverUtil.handle (\_ -> return False) $ do
292 st <- getFileStatus name
294 if fileOwner st /= me then do
295 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
298 let mode = fileMode st
299 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
300 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
302 putStrLn $ "*** WARNING: " ++ name ++
303 " is writable by someone else, IGNORING!"
308 fileLoop :: Handle -> Bool -> GHCi ()
309 fileLoop hdl prompt = do
310 cmstate <- getCmState
311 (mod,imports) <- io (cmGetContext cmstate)
312 when prompt (io (putStr (mkPrompt mod imports)))
313 l <- io (IO.try (hGetLine hdl))
315 Left e | isEOFError e -> return ()
316 | otherwise -> io (ioError e)
318 case remove_spaces l of
319 "" -> fileLoop hdl prompt
320 l -> do quit <- runCommand l
321 if quit then return () else fileLoop hdl prompt
323 stringLoop :: [String] -> GHCi ()
324 stringLoop [] = return ()
325 stringLoop (s:ss) = do
326 case remove_spaces s of
328 l -> do quit <- runCommand l
329 if quit then return () else stringLoop ss
331 mkPrompt toplevs exports
332 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
334 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
335 readlineLoop :: GHCi ()
337 cmstate <- getCmState
338 (mod,imports) <- io (cmGetContext cmstate)
340 l <- io (readline (mkPrompt mod imports)
341 `finally` setNonBlockingFD 0)
342 -- readline sometimes puts stdin into blocking mode,
343 -- so we need to put it back for the IO library
347 case remove_spaces l of
352 if quit then return () else readlineLoop
355 runCommand :: String -> GHCi Bool
356 runCommand c = ghciHandle handler (doCommand c)
358 -- This is the exception handler for exceptions generated by the
359 -- user's code; it normally just prints out the exception. The
360 -- handler must be recursive, in case showing the exception causes
361 -- more exceptions to be raised.
363 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
364 -- raising another exception. We therefore don't put the recursive
365 -- handler arond the flushing operation, so if stderr is closed
366 -- GHCi will just die gracefully rather than going into an infinite loop.
367 handler :: Exception -> GHCi Bool
368 handler exception = do
370 io installSignalHandlers
371 ghciHandle handler (showException exception >> return False)
373 showException (DynException dyn) =
374 case fromDynamic dyn of
375 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
376 Just Interrupted -> io (putStrLn "Interrupted.")
377 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
378 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
379 Just other_ghc_ex -> io (print other_ghc_ex)
381 showException other_exception
382 = io (putStrLn ("*** Exception: " ++ show other_exception))
384 doCommand (':' : command) = specialCommand command
386 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
389 runStmt :: String -> GHCi [Name]
391 | null (filter (not.isSpace) stmt) = return []
393 = do st <- getGHCiState
394 dflags <- io getDynFlags
395 let cm_state' = cmSetDFlags (cmstate st)
396 (dopt_unset dflags Opt_WarnUnusedBinds)
397 (new_cmstate, result) <-
398 io $ withProgName (progname st) $ withArgs (args st) $
399 cmRunStmt cm_state' stmt
400 setGHCiState st{cmstate = new_cmstate}
402 CmRunFailed -> return []
403 CmRunException e -> showException e >> return []
404 CmRunOk names -> return names
406 -- possibly print the type and revert CAFs after evaluating an expression
408 = do b <- isOptionSet ShowType
409 cmstate <- getCmState
410 when b (mapM_ (showTypeOfName cmstate) names)
413 io installSignalHandlers
414 b <- isOptionSet RevertCAFs
415 io (when b revertCAFs)
418 showTypeOfName :: CmState -> Name -> GHCi ()
419 showTypeOfName cmstate n
420 = do maybe_str <- io (cmTypeOfName cmstate n)
423 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
425 specialCommand :: String -> GHCi Bool
426 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
427 specialCommand str = do
428 let (cmd,rest) = break isSpace str
429 cmds <- io (readIORef commands)
430 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
431 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
432 ++ shortHelpText) >> return False)
433 [(_,f)] -> f (dropWhile isSpace rest)
434 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
435 " matches multiple commands (" ++
436 foldr1 (\a b -> a ++ ',':b) (map fst cs)
437 ++ ")") >> return False)
439 noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
442 -----------------------------------------------------------------------------
443 -- To flush buffers for the *interpreted* computation we need
444 -- to refer to *its* stdout/stderr handles
446 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
447 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
449 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
450 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
451 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
453 initInterpBuffering :: CmState -> IO ()
454 initInterpBuffering cmstate
455 = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
458 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
459 other -> panic "interactiveUI:setBuffering"
461 maybe_hval <- cmCompileExpr cmstate flush_cmd
463 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
464 _ -> panic "interactiveUI:flush"
466 turnOffBuffering -- Turn it off right now
471 flushInterpBuffers :: GHCi ()
473 = io $ do Monad.join (readIORef flush_interp)
476 turnOffBuffering :: IO ()
478 = do Monad.join (readIORef turn_off_buffering)
481 -----------------------------------------------------------------------------
484 help :: String -> GHCi ()
485 help _ = io (putStr helpText)
487 info :: String -> GHCi ()
488 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
489 info s = do { let names = words s
490 ; init_cms <- getCmState
491 ; mapM_ (infoThing init_cms) names }
494 = do { stuff <- io (cmGetInfo cms name)
495 ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
496 vcat (intersperse (text "") (map showThing stuff)))) }
498 showThing :: GetInfoResult -> SDoc
499 showThing (wanted_str, (thing, fixity, src_loc, insts))
500 = vcat [ showDecl want_name thing,
503 vcat (map show_inst insts)]
505 want_name occ = wanted_str == occNameUserString occ
508 | fix == defaultFixity = empty
509 | otherwise = ppr fix <+> text wanted_str
511 show_loc loc -- The ppr function for SrcLocs is a bit wonky
512 | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
513 | otherwise = comment <+> ppr loc
514 comment = ptext SLIT("--")
516 show_inst (iface_inst, loc)
517 = hang (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
518 2 (char '\t' <> show_loc loc)
519 -- The tab tries to make them line up a bit
521 -- Now there is rather a lot of goop just to print declarations in a
522 -- civilised way with "..." for the parts we are less interested in.
524 showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc
525 showDecl want_name (IfaceForeign {ifName = tc})
526 = ppr tc <+> ptext SLIT("is a foreign type")
528 showDecl want_name (IfaceId {ifName = var, ifType = ty})
529 = ppr var <+> dcolon <+> ppr ty
531 showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
532 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
533 2 (equals <+> ppr mono_ty)
535 showDecl want_name (IfaceData {ifCtxt = context, ifName = tycon,
536 ifTyVars = tyvars, ifCons = condecls})
537 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
538 2 (add_bars (ppr_trim show_con cs))
540 show_con (IfaceConDecl con_name is_infix ex_tvs ex_cxt tys strs flds)
541 | want_name tycon || want_name con_name || any want_name flds
542 = Just (pprIfaceForAllPart ex_tvs ex_cxt (show_guts con_name is_infix tys_w_strs flds))
543 | otherwise = Nothing
545 tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
547 show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
548 show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
549 show_guts con _ tys flds
550 = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
552 show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
553 = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
554 | otherwise = Nothing
556 (pp_nd, cs) = case condecls of
557 IfAbstractTyCon -> (ptext SLIT("data"), [])
558 IfDataTyCon cs -> (ptext SLIT("data"), cs)
559 IfNewTyCon c -> (ptext SLIT("newtype"), [c])
562 add_bars [c] = equals <+> c
563 add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
565 ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
566 ppr_str MarkedStrict = char '!'
567 ppr_str MarkedUnboxed = ptext SLIT("!!")
568 ppr_str NotMarkedStrict = empty
570 showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
571 ifFDs = fds, ifSigs = sigs})
572 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
573 <+> pprFundeps fds <+> ptext SLIT("where"))
574 2 (vcat (ppr_trim show_op sigs))
576 show_op (IfaceClassOp op dm ty)
577 | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty)
578 | otherwise = Nothing
580 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
582 = snd (foldr go (False, []) xs)
584 go x (eliding, so_far)
585 | Just doc <- show x = (False, doc : so_far)
586 | otherwise = if eliding then (True, so_far)
587 else (True, ptext SLIT("...") : so_far)
589 ppr_bndr :: OccName -> SDoc
590 -- Wrap operators in ()
591 ppr_bndr occ | isSymOcc occ = parens (ppr occ)
592 | otherwise = ppr occ
595 -----------------------------------------------------------------------------
598 addModule :: [FilePath] -> GHCi ()
600 state <- getGHCiState
601 io (revertCAFs) -- always revert CAFs on load/add.
602 files <- mapM expandPath files
603 let new_targets = files ++ targets state
604 graph <- io (cmDepAnal (cmstate state) new_targets)
605 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
606 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
607 setContextAfterLoad mods
608 dflags <- io getDynFlags
609 modulesLoadedMsg ok mods dflags
611 changeDirectory :: String -> GHCi ()
612 changeDirectory dir = do
613 state <- getGHCiState
614 when (targets state /= []) $
615 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
616 cmstate1 <- io (cmUnload (cmstate state))
617 setGHCiState state{ cmstate = cmstate1, targets = [] }
618 setContextAfterLoad []
619 dir <- expandPath dir
620 io (setCurrentDirectory dir)
622 defineMacro :: String -> GHCi ()
624 let (macro_name, definition) = break isSpace s
625 cmds <- io (readIORef commands)
627 then throwDyn (CmdLineError "invalid macro name")
629 if (macro_name `elem` map fst cmds)
630 then throwDyn (CmdLineError
631 ("command '" ++ macro_name ++ "' is already defined"))
634 -- give the expression a type signature, so we can be sure we're getting
635 -- something of the right type.
636 let new_expr = '(' : definition ++ ") :: String -> IO String"
638 -- compile the expression
640 maybe_hv <- io (cmCompileExpr cms new_expr)
643 Just hv -> io (writeIORef commands --
644 ((macro_name, keepGoing (runMacro hv)) : cmds))
646 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
648 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
649 stringLoop (lines str)
651 undefineMacro :: String -> GHCi ()
652 undefineMacro macro_name = do
653 cmds <- io (readIORef commands)
654 if (macro_name `elem` map fst builtin_commands)
655 then throwDyn (CmdLineError
656 ("command '" ++ macro_name ++ "' cannot be undefined"))
658 if (macro_name `notElem` map fst cmds)
659 then throwDyn (CmdLineError
660 ("command '" ++ macro_name ++ "' not defined"))
662 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
665 loadModule :: [FilePath] -> GHCi ()
666 loadModule fs = timeIt (loadModule' fs)
668 loadModule' :: [FilePath] -> GHCi ()
669 loadModule' files = do
670 state <- getGHCiState
673 files <- mapM expandPath files
675 -- do the dependency anal first, so that if it fails we don't throw
676 -- away the current set of modules.
677 graph <- io (cmDepAnal (cmstate state) files)
679 -- Dependency anal ok, now unload everything
680 cmstate1 <- io (cmUnload (cmstate state))
681 setGHCiState state{ cmstate = cmstate1, targets = [] }
683 io (revertCAFs) -- always revert CAFs on load.
684 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
685 setGHCiState state{ cmstate = cmstate2, targets = files }
687 setContextAfterLoad mods
688 dflags <- io (getDynFlags)
689 modulesLoadedMsg ok mods dflags
692 reloadModule :: String -> GHCi ()
694 state <- getGHCiState
695 case targets state of
696 [] -> io (putStr "no current target\n")
698 -- do the dependency anal first, so that if it fails we don't throw
699 -- away the current set of modules.
700 graph <- io (cmDepAnal (cmstate state) paths)
702 io (revertCAFs) -- always revert CAFs on reload.
704 <- io (cmLoadModules (cmstate state) graph)
705 setGHCiState state{ cmstate=cmstate1 }
706 setContextAfterLoad mods
707 dflags <- io getDynFlags
708 modulesLoadedMsg ok mods dflags
710 reloadModule _ = noArgs ":reload"
712 setContextAfterLoad [] = setContext prel
713 setContextAfterLoad (m:_) = do
714 cmstate <- getCmState
715 b <- io (cmModuleIsInterpreted cmstate m)
716 if b then setContext ('*':m) else setContext m
718 modulesLoadedMsg ok mods dflags =
719 when (verbosity dflags > 0) $ do
721 | null mods = text "none."
723 punctuate comma (map text mods)) <> text "."
726 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
728 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
731 typeOfExpr :: String -> GHCi ()
733 = do cms <- getCmState
734 maybe_tystr <- io (cmTypeOfExpr cms str)
737 Just tystr -> io (putStrLn tystr)
739 kindOfType :: String -> GHCi ()
741 = do cms <- getCmState
742 maybe_tystr <- io (cmKindOfType cms str)
745 Just tystr -> io (putStrLn tystr)
747 quit :: String -> GHCi Bool
750 shellEscape :: String -> GHCi Bool
751 shellEscape str = io (system str >> return False)
753 -----------------------------------------------------------------------------
754 -- Browsing a module's contents
756 browseCmd :: String -> GHCi ()
759 ['*':m] | looksLikeModuleName m -> browseModule m False
760 [m] | looksLikeModuleName m -> browseModule m True
761 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
763 browseModule m exports_only = do
766 is_interpreted <- io (cmModuleIsInterpreted cms m)
767 when (not is_interpreted && not exports_only) $
768 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
770 -- Temporarily set the context to the module we're interested in,
771 -- just so we can get an appropriate PrintUnqualified
772 (as,bs) <- io (cmGetContext cms)
773 cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
774 else cmSetContext cms [m] [])
775 cms2 <- io (cmSetContext cms1 as bs)
777 things <- io (cmBrowseModule cms2 m exports_only)
779 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
781 io (putStrLn (showSDocForUser unqual (
782 vcat (map (showDecl (const True)) things)
785 -----------------------------------------------------------------------------
786 -- Setting the module context
789 | all sensible mods = fn mods
790 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
792 (fn, mods) = case str of
793 '+':stuff -> (addToContext, words stuff)
794 '-':stuff -> (removeFromContext, words stuff)
795 stuff -> (newContext, words stuff)
797 sensible ('*':m) = looksLikeModuleName m
798 sensible m = looksLikeModuleName m
802 (as,bs) <- separate cms mods [] []
803 let bs' = if null as && prel `notElem` bs then prel:bs else bs
804 cms' <- io (cmSetContext cms as bs')
807 separate cmstate [] as bs = return (as,bs)
808 separate cmstate (('*':m):ms) as bs = do
809 b <- io (cmModuleIsInterpreted cmstate m)
810 if b then separate cmstate ms (m:as) bs
811 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
812 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
817 addToContext mods = do
819 (as,bs) <- io (cmGetContext cms)
821 (as',bs') <- separate cms mods [] []
823 let as_to_add = as' \\ (as ++ bs)
824 bs_to_add = bs' \\ (as ++ bs)
826 cms' <- io (cmSetContext cms
827 (as ++ as_to_add) (bs ++ bs_to_add))
831 removeFromContext mods = do
833 (as,bs) <- io (cmGetContext cms)
835 (as_to_remove,bs_to_remove) <- separate cms mods [] []
837 let as' = as \\ (as_to_remove ++ bs_to_remove)
838 bs' = bs \\ (as_to_remove ++ bs_to_remove)
840 cms' <- io (cmSetContext cms as' bs')
843 ----------------------------------------------------------------------------
846 -- set options in the interpreter. Syntax is exactly the same as the
847 -- ghc command line, except that certain options aren't available (-C,
850 -- This is pretty fragile: most options won't work as expected. ToDo:
851 -- figure out which ones & disallow them.
853 setCmd :: String -> GHCi ()
855 = do st <- getGHCiState
856 let opts = options st
857 io $ putStrLn (showSDoc (
858 text "options currently set: " <>
861 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
865 ("args":args) -> setArgs args
866 ("prog":prog) -> setProg prog
867 wds -> setOptions wds
871 setGHCiState st{ args = args }
875 setGHCiState st{ progname = prog }
877 io (hPutStrLn stderr "syntax: :set prog <progname>")
880 do -- first, deal with the GHCi opts (+s, +t, etc.)
881 let (plus_opts, minus_opts) = partition isPlus wds
882 mapM_ setOpt plus_opts
884 -- now, the GHC flags
885 pkgs_before <- io (readIORef v_ExplicitPackages)
886 leftovers <- io (processArgs static_flags minus_opts [])
887 pkgs_after <- io (readIORef v_ExplicitPackages)
889 -- update things if the users wants more packages
890 let new_packages = pkgs_after \\ pkgs_before
891 when (not (null new_packages)) $
892 newPackages new_packages
894 -- don't forget about the extra command-line flags from the
895 -- extra_ghc_opts fields in the new packages
896 new_package_details <- io (getPackageDetails new_packages)
897 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
898 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
900 -- then, dynamic flags
903 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
906 if (not (null leftovers))
907 then throwDyn (CmdLineError ("unrecognised flags: " ++
912 unsetOptions :: String -> GHCi ()
914 = do -- first, deal with the GHCi opts (+s, +t, etc.)
916 (minus_opts, rest1) = partition isMinus opts
917 (plus_opts, rest2) = partition isPlus rest1
919 if (not (null rest2))
920 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
923 mapM_ unsetOpt plus_opts
925 -- can't do GHC flags for now
926 if (not (null minus_opts))
927 then throwDyn (CmdLineError "can't unset GHC command-line flags")
930 isMinus ('-':s) = True
933 isPlus ('+':s) = True
937 = case strToGHCiOpt str of
938 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
939 Just o -> setOption o
942 = case strToGHCiOpt str of
943 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
944 Just o -> unsetOption o
946 strToGHCiOpt :: String -> (Maybe GHCiOption)
947 strToGHCiOpt "s" = Just ShowTiming
948 strToGHCiOpt "t" = Just ShowType
949 strToGHCiOpt "r" = Just RevertCAFs
950 strToGHCiOpt _ = Nothing
952 optToStr :: GHCiOption -> String
953 optToStr ShowTiming = "s"
954 optToStr ShowType = "t"
955 optToStr RevertCAFs = "r"
957 newPackages new_pkgs = do -- The new packages are already in v_Packages
958 state <- getGHCiState
959 cmstate1 <- io (cmUnload (cmstate state))
960 setGHCiState state{ cmstate = cmstate1, targets = [] }
961 dflags <- io getDynFlags
962 io (linkPackages dflags new_pkgs)
963 setContextAfterLoad []
965 -- ---------------------------------------------------------------------------
970 ["modules" ] -> showModules
971 ["bindings"] -> showBindings
972 ["linker"] -> io showLinkerState
973 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
977 let (mg, hpt) = cmGetModInfo cms
978 mapM_ (showModule hpt) mg
981 showModule :: HomePackageTable -> ModSummary -> GHCi ()
982 showModule hpt mod_summary
983 = case lookupModuleEnv hpt mod of
984 Nothing -> panic "missing linkable"
985 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
987 obj_linkable = isObjectLinkable (hm_linkable mod_info)
989 mod = ms_mod mod_summary
990 locn = ms_location mod_summary
995 unqual = cmGetPrintUnqual cms
996 -- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
997 showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
999 io (mapM_ showBinding (cmGetBindings cms))
1003 -----------------------------------------------------------------------------
1006 data GHCiState = GHCiState
1010 targets :: [FilePath],
1012 options :: [GHCiOption]
1016 = ShowTiming -- show time/allocs after evaluation
1017 | ShowType -- show the type of expressions
1018 | RevertCAFs -- revert CAFs after every evaluation
1021 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1023 startGHCi :: GHCi a -> GHCiState -> IO a
1024 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1026 instance Monad GHCi where
1027 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1028 return a = GHCi $ \s -> return a
1030 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1031 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1032 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1034 getGHCiState = GHCi $ \r -> readIORef r
1035 setGHCiState s = GHCi $ \r -> writeIORef r s
1037 -- for convenience...
1038 getCmState = getGHCiState >>= return . cmstate
1039 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1041 isOptionSet :: GHCiOption -> GHCi Bool
1043 = do st <- getGHCiState
1044 return (opt `elem` options st)
1046 setOption :: GHCiOption -> GHCi ()
1048 = do st <- getGHCiState
1049 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1051 unsetOption :: GHCiOption -> GHCi ()
1053 = do st <- getGHCiState
1054 setGHCiState (st{ options = filter (/= opt) (options st) })
1056 io :: IO a -> GHCi a
1057 io m = GHCi { unGHCi = \s -> m >>= return }
1059 -----------------------------------------------------------------------------
1060 -- recursive exception handlers
1062 -- Don't forget to unblock async exceptions in the handler, or if we're
1063 -- in an exception loop (eg. let a = error a in a) the ^C exception
1064 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1066 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1067 ghciHandle h (GHCi m) = GHCi $ \s ->
1068 Exception.catch (m s)
1069 (\e -> unGHCi (ghciUnblock (h e)) s)
1071 ghciUnblock :: GHCi a -> GHCi a
1072 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1074 -----------------------------------------------------------------------------
1075 -- timing & statistics
1077 timeIt :: GHCi a -> GHCi a
1079 = do b <- isOptionSet ShowTiming
1082 else do allocs1 <- io $ getAllocations
1083 time1 <- io $ getCPUTime
1085 allocs2 <- io $ getAllocations
1086 time2 <- io $ getCPUTime
1087 io $ printTimes (fromIntegral (allocs2 - allocs1))
1091 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1092 -- defined in ghc/rts/Stats.c
1094 printTimes :: Integer -> Integer -> IO ()
1095 printTimes allocs psecs
1096 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1097 secs_str = showFFloat (Just 2) secs
1098 putStrLn (showSDoc (
1099 parens (text (secs_str "") <+> text "secs" <> comma <+>
1100 text (show allocs) <+> text "bytes")))
1102 -----------------------------------------------------------------------------
1109 -- Have to turn off buffering again, because we just
1110 -- reverted stdout, stderr & stdin to their defaults.
1112 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1113 -- Make it "safe", just in case
1115 -- -----------------------------------------------------------------------------
1118 expandPath :: String -> GHCi String
1120 case dropWhile isSpace path of
1122 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1123 return (tilde ++ '/':d)