1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.145 2003/02/17 12:24:26 simonmar Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2000
9 -----------------------------------------------------------------------------
10 module InteractiveUI (
11 interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
15 #include "../includes/config.h"
16 #include "HsVersions.h"
19 import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
21 import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
22 import MkIface ( ifaceTyThing )
25 import DriverUtil ( remove_spaces, handle )
26 import Linker ( initLinker, showLinkerState, linkLibraries,
29 import Id ( isRecordSelector, isImplicitId, recordSelectorFieldLabel, idName )
30 import Class ( className )
31 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
32 import DataCon ( dataConName )
33 import FieldLabel ( fieldLabelTyCon )
34 import SrcLoc ( isGoodSrcLoc )
35 import Module ( showModMsg, lookupModuleEnv )
36 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
38 import OccName ( isSymOcc )
39 import BasicTypes ( defaultFixity, SuccessFlag(..) )
42 import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
43 restoreDynFlags, dopt_unset )
44 import Panic hiding ( showException )
47 #ifndef mingw32_TARGET_OS
51 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
52 import Control.Concurrent ( yield ) -- Used in readline loop
53 import System.Console.Readline as Readline
58 import Control.Exception as Exception
60 import Control.Concurrent
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 GHC.Posix ( 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 ("unset", keepGoing unsetOptions),
105 ("undef", keepGoing undefineMacro),
109 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
110 keepGoing a str = a str >> return False
112 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
113 keepGoingPaths a str = a (toArgs str) >> return False
115 shortHelpText = "use :? for help.\n"
117 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
119 \ Commands available from the prompt:\n\
121 \ <stmt> evaluate/run <stmt>\n\
122 \ :add <filename> ... add module(s) to the current target set\n\
123 \ :browse [*]<module> display the names defined by <module>\n\
124 \ :cd <dir> change directory to <dir>\n\
125 \ :def <cmd> <expr> define a command :<cmd>\n\
126 \ :help, :? display this list of commands\n\
127 \ :info [<name> ...] display information about the given names\n\
128 \ :load <filename> ... load module(s) and their dependents\n\
129 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
130 \ :reload reload the current module set\n\
132 \ :set <option> ... set options\n\
133 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
134 \ :set prog <progname> set the value returned by System.getProgName\n\
136 \ :show modules show the currently loaded modules\n\
137 \ :show bindings show the current bindings made at the prompt\n\
139 \ :type <expr> show the type of <expr>\n\
140 \ :undef <cmd> undefine user-defined command :<cmd>\n\
141 \ :unset <option> ... unset options\n\
143 \ :!<command> run the shell command <command>\n\
145 \ Options for `:set' and `:unset':\n\
147 \ +r revert top-level expressions after each evaluation\n\
148 \ +s print timing/memory stats after each evaluation\n\
149 \ +t print type after evaluation\n\
150 \ -<flags> most GHC command line flags can also be set here\n\
151 \ (eg. -v2, -fglasgow-exts, etc.)\n\
154 interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO ()
155 interactiveUI cmstate paths cmdline_objs = do
157 hSetBuffering stdout NoBuffering
159 dflags <- getDynFlags
163 -- link packages requested explicitly on the command-line
164 expl <- readIORef v_ExplicitPackages
165 linkPackages dflags expl
167 -- link libraries from the command-line
168 linkLibraries dflags cmdline_objs
170 -- Initialise buffering for the *interpreted* I/O system
171 cmstate <- initInterpBuffering cmstate dflags
173 -- We don't want the cmd line to buffer any input that might be
174 -- intended for the program, so unbuffer stdin.
175 hSetBuffering stdin NoBuffering
177 -- initial context is just the Prelude
178 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
180 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
184 startGHCi (runGHCi paths dflags)
185 GHCiState{ progname = "<interactive>",
191 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
192 Readline.resetTerminal Nothing
197 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
198 runGHCi paths dflags = do
199 read_dot_files <- io (readIORef v_Read_DotGHCi)
201 when (read_dot_files) $ do
204 exists <- io (doesFileExist file)
206 dir_ok <- io (checkPerms ".")
207 file_ok <- io (checkPerms file)
208 when (dir_ok && file_ok) $ do
209 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
212 Right hdl -> fileLoop hdl False
214 when (read_dot_files) $ do
215 -- Read in $HOME/.ghci
216 either_dir <- io (IO.try (getEnv "HOME"))
220 cwd <- io (getCurrentDirectory)
221 when (dir /= cwd) $ do
222 let file = dir ++ "/.ghci"
223 ok <- io (checkPerms file)
225 either_hdl <- io (IO.try (openFile file ReadMode))
228 Right hdl -> fileLoop hdl False
230 -- perform a :load for files given on the GHCi command line
231 when (not (null paths)) $
232 ghciHandle showException $
235 -- enter the interactive loop
236 #if defined(mingw32_TARGET_OS)
237 -- always show prompt, since hIsTerminalDevice returns True for Consoles
238 -- only, which we may or may not be running under (cf. Emacs sub-shells.)
241 is_tty <- io (hIsTerminalDevice stdin)
242 interactiveLoop is_tty
246 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
249 interactiveLoop is_tty = do
250 -- ignore ^C exceptions caught here
251 ghciHandleDyn (\e -> case e of
252 Interrupted -> ghciUnblock (interactiveLoop is_tty)
253 _other -> return ()) $ do
255 -- read commands from stdin
256 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
259 else fileLoop stdin False -- turn off prompt for non-TTY input
261 fileLoop stdin is_tty
265 -- NOTE: We only read .ghci files if they are owned by the current user,
266 -- and aren't world writable. Otherwise, we could be accidentally
267 -- running code planted by a malicious third party.
269 -- Furthermore, We only read ./.ghci if . is owned by the current user
270 -- and isn't writable by anyone else. I think this is sufficient: we
271 -- don't need to check .. and ../.. etc. because "." always refers to
272 -- the same directory while a process is running.
274 checkPerms :: String -> IO Bool
276 #ifdef mingw32_TARGET_OS
279 DriverUtil.handle (\_ -> return False) $ do
280 st <- getFileStatus name
282 if fileOwner st /= me then do
283 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
286 let mode = fileMode st
287 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
288 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
290 putStrLn $ "*** WARNING: " ++ name ++
291 " is writable by someone else, IGNORING!"
296 fileLoop :: Handle -> Bool -> GHCi ()
297 fileLoop hdl prompt = do
298 cmstate <- getCmState
299 (mod,imports) <- io (cmGetContext cmstate)
300 when prompt (io (putStr (mkPrompt mod imports)))
301 l <- io (IO.try (hGetLine hdl))
303 Left e | isEOFError e -> return ()
304 | otherwise -> io (ioError e)
306 case remove_spaces l of
307 "" -> fileLoop hdl prompt
308 l -> do quit <- runCommand l
309 if quit then return () else fileLoop hdl prompt
311 stringLoop :: [String] -> GHCi ()
312 stringLoop [] = return ()
313 stringLoop (s:ss) = do
314 case remove_spaces s of
316 l -> do quit <- runCommand l
317 if quit then return () else stringLoop ss
319 mkPrompt toplevs exports
320 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
322 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
323 readlineLoop :: GHCi ()
325 cmstate <- getCmState
326 (mod,imports) <- io (cmGetContext cmstate)
328 l <- io (readline (mkPrompt mod imports)
329 `finally` setNonBlockingFD 0)
330 -- readline sometimes puts stdin into blocking mode,
331 -- so we need to put it back for the IO library
335 case remove_spaces l of
340 if quit then return () else readlineLoop
343 runCommand :: String -> GHCi Bool
344 runCommand c = ghciHandle handler (doCommand c)
346 -- This is the exception handler for exceptions generated by the
347 -- user's code; it normally just prints out the exception. The
348 -- handler must be recursive, in case showing the exception causes
349 -- more exceptions to be raised.
351 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
352 -- raising another exception. We therefore don't put the recursive
353 -- handler arond the flushing operation, so if stderr is closed
354 -- GHCi will just die gracefully rather than going into an infinite loop.
355 handler :: Exception -> GHCi Bool
356 handler exception = do
358 io installSignalHandlers
359 ghciHandle handler (showException exception >> return False)
361 showException (DynException dyn) =
362 case fromDynamic dyn of
363 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
364 Just Interrupted -> io (putStrLn "Interrupted.")
365 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
366 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
367 Just other_ghc_ex -> io (print other_ghc_ex)
369 showException other_exception
370 = io (putStrLn ("*** Exception: " ++ show other_exception))
372 doCommand (':' : command) = specialCommand command
374 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
377 runStmt :: String -> GHCi [Name]
379 | null (filter (not.isSpace) stmt) = return []
381 = do st <- getGHCiState
382 dflags <- io getDynFlags
383 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
384 (new_cmstate, result) <-
385 io $ withProgName (progname st) $ withArgs (args st) $
386 cmRunStmt (cmstate st) dflags' 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 -> DynFlags -> IO CmState
441 initInterpBuffering cmstate dflags
442 = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
445 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
446 other -> panic "interactiveUI:setBuffering"
448 (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags 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>'")
478 init_cms <- getCmState
479 dflags <- io getDynFlags
481 infoThings cms [] = return cms
482 infoThings cms (name:names) = do
483 (cms, stuff) <- io (cmInfoThing cms dflags name)
484 io (putStrLn (showSDocForUser unqual (
485 vcat (intersperse (text "") (map showThing stuff))))
489 unqual = cmGetPrintUnqual init_cms
491 showThing (ty_thing, fixity)
492 = vcat [ text "-- " <> showTyThing ty_thing,
493 showFixity fixity (getName ty_thing),
494 ppr (ifaceTyThing ty_thing) ]
497 | fix == defaultFixity = empty
498 | otherwise = ppr fix <+>
499 (if isSymOcc (nameOccName name)
501 else char '`' <> ppr name <> char '`')
503 showTyThing (AClass cl)
504 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
505 showTyThing (ADataCon dc)
506 = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
507 showTyThing (ATyCon ty)
509 = hcat [ppr ty, text " is a primitive type constructor"]
511 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
512 showTyThing (AnId id)
513 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
516 | isRecordSelector id =
517 case tyConClass_maybe (fieldLabelTyCon (
518 recordSelectorFieldLabel id)) of
519 Nothing -> text "record selector"
520 Just c -> text "method in class " <> ppr c
521 | otherwise = text "variable"
523 -- also print out the source location for home things
525 | isHomePackageName name && isGoodSrcLoc loc
526 = hsep [ text ", defined at", ppr loc ]
529 where loc = nameSrcLoc name
531 cms <- infoThings init_cms names
535 addModule :: [FilePath] -> GHCi ()
537 state <- getGHCiState
538 dflags <- io (getDynFlags)
539 io (revertCAFs) -- always revert CAFs on load/add.
540 let new_targets = files ++ targets state
541 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
542 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
543 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
544 setContextAfterLoad mods
545 modulesLoadedMsg ok mods dflags
547 changeDirectory :: String -> GHCi ()
548 changeDirectory ('~':d) = do
549 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
550 io (setCurrentDirectory (tilde ++ '/':d))
551 changeDirectory d = io (setCurrentDirectory d)
553 defineMacro :: String -> GHCi ()
555 let (macro_name, definition) = break isSpace s
556 cmds <- io (readIORef commands)
558 then throwDyn (CmdLineError "invalid macro name")
560 if (macro_name `elem` map fst cmds)
561 then throwDyn (CmdLineError
562 ("command `" ++ macro_name ++ "' is already defined"))
565 -- give the expression a type signature, so we can be sure we're getting
566 -- something of the right type.
567 let new_expr = '(' : definition ++ ") :: String -> IO String"
569 -- compile the expression
571 dflags <- io getDynFlags
572 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
573 setCmState new_cmstate
576 Just hv -> io (writeIORef commands --
577 ((macro_name, keepGoing (runMacro hv)) : cmds))
579 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
581 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
582 stringLoop (lines str)
584 undefineMacro :: String -> GHCi ()
585 undefineMacro macro_name = do
586 cmds <- io (readIORef commands)
587 if (macro_name `elem` map fst builtin_commands)
588 then throwDyn (CmdLineError
589 ("command `" ++ macro_name ++ "' cannot be undefined"))
591 if (macro_name `notElem` map fst cmds)
592 then throwDyn (CmdLineError
593 ("command `" ++ macro_name ++ "' not defined"))
595 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
598 loadModule :: [FilePath] -> GHCi ()
599 loadModule fs = timeIt (loadModule' fs)
601 loadModule' :: [FilePath] -> GHCi ()
602 loadModule' files = do
603 state <- getGHCiState
604 dflags <- io getDynFlags
606 -- do the dependency anal first, so that if it fails we don't throw
607 -- away the current set of modules.
608 graph <- io (cmDepAnal (cmstate state) dflags files)
610 -- Dependency anal ok, now unload everything
611 cmstate1 <- io (cmUnload (cmstate state) dflags)
612 setGHCiState state{ cmstate = cmstate1, targets = [] }
614 io (revertCAFs) -- always revert CAFs on load.
615 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
616 setGHCiState state{ cmstate = cmstate2, targets = files }
618 setContextAfterLoad mods
619 modulesLoadedMsg ok mods dflags
622 reloadModule :: String -> GHCi ()
624 state <- getGHCiState
625 dflags <- io getDynFlags
626 case targets state of
627 [] -> io (putStr "no current target\n")
629 -- do the dependency anal first, so that if it fails we don't throw
630 -- away the current set of modules.
631 graph <- io (cmDepAnal (cmstate state) dflags paths)
633 io (revertCAFs) -- always revert CAFs on reload.
635 <- io (cmLoadModules (cmstate state) dflags graph)
636 setGHCiState state{ cmstate=cmstate1 }
637 setContextAfterLoad mods
638 modulesLoadedMsg ok mods dflags
640 reloadModule _ = noArgs ":reload"
642 setContextAfterLoad [] = setContext prel
643 setContextAfterLoad (m:_) = do
644 cmstate <- getCmState
645 b <- io (cmModuleIsInterpreted cmstate m)
646 if b then setContext ('*':m) else setContext m
648 modulesLoadedMsg ok mods dflags =
649 when (verbosity dflags > 0) $ do
651 | null mods = text "none."
653 punctuate comma (map text mods)) <> text "."
656 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
658 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
661 typeOfExpr :: String -> GHCi ()
663 = do cms <- getCmState
664 dflags <- io getDynFlags
665 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
666 setCmState new_cmstate
669 Just tystr -> io (putStrLn tystr)
671 quit :: String -> GHCi Bool
674 shellEscape :: String -> GHCi Bool
675 shellEscape str = io (system str >> return False)
677 -----------------------------------------------------------------------------
678 -- Browing a module's contents
680 browseCmd :: String -> GHCi ()
683 ['*':m] | looksLikeModuleName m -> browseModule m False
684 [m] | looksLikeModuleName m -> browseModule m True
685 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
687 browseModule m exports_only = do
689 dflags <- io getDynFlags
691 is_interpreted <- io (cmModuleIsInterpreted cms m)
692 when (not is_interpreted && not exports_only) $
693 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
695 -- temporarily set the context to the module we're interested in,
696 -- just so we can get an appropriate PrintUnqualified
697 (as,bs) <- io (cmGetContext cms)
698 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
699 else cmSetContext cms dflags [m] [])
700 cms2 <- io (cmSetContext cms1 dflags as bs)
702 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
706 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
708 things' = filter wantToSee things
710 wantToSee (AnId id) = not (isImplicitId id)
711 wantToSee (ADataCon _) = False -- They'll come via their TyCon
714 thing_names = map getName things
716 thingDecl thing@(AnId id) = ifaceTyThing thing
718 thingDecl thing@(AClass c) =
719 let rn_decl = ifaceTyThing thing in
721 ClassDecl { tcdSigs = cons } ->
722 rn_decl{ tcdSigs = filter methodIsVisible cons }
725 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
727 thingDecl thing@(ATyCon t) =
728 let rn_decl = ifaceTyThing thing in
730 TyData { tcdCons = DataCons cons } ->
731 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
734 conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
736 io (putStrLn (showSDocForUser unqual (
737 vcat (map (ppr . thingDecl) things')))
742 -----------------------------------------------------------------------------
743 -- Setting the module context
746 | all sensible mods = fn mods
747 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
749 (fn, mods) = case str of
750 '+':stuff -> (addToContext, words stuff)
751 '-':stuff -> (removeFromContext, words stuff)
752 stuff -> (newContext, words stuff)
754 sensible ('*':m) = looksLikeModuleName m
755 sensible m = looksLikeModuleName m
759 dflags <- io getDynFlags
760 (as,bs) <- separate cms mods [] []
761 let bs' = if null as && prel `notElem` bs then prel:bs else bs
762 cms' <- io (cmSetContext cms dflags as bs')
765 separate cmstate [] as bs = return (as,bs)
766 separate cmstate (('*':m):ms) as bs = do
767 b <- io (cmModuleIsInterpreted cmstate m)
768 if b then separate cmstate ms (m:as) bs
769 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
770 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
775 addToContext mods = do
777 dflags <- io getDynFlags
778 (as,bs) <- io (cmGetContext cms)
780 (as',bs') <- separate cms mods [] []
782 let as_to_add = as' \\ (as ++ bs)
783 bs_to_add = bs' \\ (as ++ bs)
785 cms' <- io (cmSetContext cms dflags
786 (as ++ as_to_add) (bs ++ bs_to_add))
790 removeFromContext mods = do
792 dflags <- io getDynFlags
793 (as,bs) <- io (cmGetContext cms)
795 (as_to_remove,bs_to_remove) <- separate cms mods [] []
797 let as' = as \\ (as_to_remove ++ bs_to_remove)
798 bs' = bs \\ (as_to_remove ++ bs_to_remove)
800 cms' <- io (cmSetContext cms dflags as' bs')
803 ----------------------------------------------------------------------------
806 -- set options in the interpreter. Syntax is exactly the same as the
807 -- ghc command line, except that certain options aren't available (-C,
810 -- This is pretty fragile: most options won't work as expected. ToDo:
811 -- figure out which ones & disallow them.
813 setCmd :: String -> GHCi ()
815 = do st <- getGHCiState
816 let opts = options st
817 io $ putStrLn (showSDoc (
818 text "options currently set: " <>
821 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
825 ("args":args) -> setArgs args
826 ("prog":prog) -> setProg prog
827 wds -> setOptions wds
831 setGHCiState st{ args = args }
835 setGHCiState st{ progname = prog }
837 io (hPutStrLn stderr "syntax: :set prog <progname>")
840 do -- first, deal with the GHCi opts (+s, +t, etc.)
841 let (plus_opts, minus_opts) = partition isPlus wds
842 mapM_ setOpt plus_opts
844 -- now, the GHC flags
845 pkgs_before <- io (readIORef v_ExplicitPackages)
846 leftovers <- io (processArgs static_flags minus_opts [])
847 pkgs_after <- io (readIORef v_ExplicitPackages)
849 -- update things if the users wants more packages
850 let new_packages = pkgs_after \\ pkgs_before
851 when (not (null new_packages)) $
852 newPackages new_packages
854 -- don't forget about the extra command-line flags from the
855 -- extra_ghc_opts fields in the new packages
856 new_package_details <- io (getPackageDetails new_packages)
857 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
858 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
860 -- then, dynamic flags
863 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
866 if (not (null leftovers))
867 then throwDyn (CmdLineError ("unrecognised flags: " ++
872 unsetOptions :: String -> GHCi ()
874 = do -- first, deal with the GHCi opts (+s, +t, etc.)
876 (minus_opts, rest1) = partition isMinus opts
877 (plus_opts, rest2) = partition isPlus rest1
879 if (not (null rest2))
880 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
883 mapM_ unsetOpt plus_opts
885 -- can't do GHC flags for now
886 if (not (null minus_opts))
887 then throwDyn (CmdLineError "can't unset GHC command-line flags")
890 isMinus ('-':s) = True
893 isPlus ('+':s) = True
897 = case strToGHCiOpt str of
898 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
899 Just o -> setOption o
902 = case strToGHCiOpt str of
903 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
904 Just o -> unsetOption o
906 strToGHCiOpt :: String -> (Maybe GHCiOption)
907 strToGHCiOpt "s" = Just ShowTiming
908 strToGHCiOpt "t" = Just ShowType
909 strToGHCiOpt "r" = Just RevertCAFs
910 strToGHCiOpt _ = Nothing
912 optToStr :: GHCiOption -> String
913 optToStr ShowTiming = "s"
914 optToStr ShowType = "t"
915 optToStr RevertCAFs = "r"
917 newPackages new_pkgs = do -- The new packages are already in v_Packages
918 state <- getGHCiState
919 dflags <- io getDynFlags
920 cmstate1 <- io (cmUnload (cmstate state) dflags)
921 setGHCiState state{ cmstate = cmstate1, targets = [] }
922 io (linkPackages dflags new_pkgs)
923 setContextAfterLoad []
925 -- ---------------------------------------------------------------------------
930 ["modules" ] -> showModules
931 ["bindings"] -> showBindings
932 ["linker"] -> io showLinkerState
933 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
937 let (mg, hpt) = cmGetModInfo cms
938 mapM_ (showModule hpt) mg
941 showModule :: HomePackageTable -> ModSummary -> GHCi ()
942 showModule hpt mod_summary
943 = case lookupModuleEnv hpt mod of
944 Nothing -> panic "missing linkable"
945 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
947 obj_linkable = isObjectLinkable (hm_linkable mod_info)
949 mod = ms_mod mod_summary
950 locn = ms_location mod_summary
955 unqual = cmGetPrintUnqual cms
956 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
958 io (mapM_ showBinding (cmGetBindings cms))
962 -----------------------------------------------------------------------------
965 data GHCiState = GHCiState
969 targets :: [FilePath],
971 options :: [GHCiOption]
975 = ShowTiming -- show time/allocs after evaluation
976 | ShowType -- show the type of expressions
977 | RevertCAFs -- revert CAFs after every evaluation
980 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
982 startGHCi :: GHCi a -> GHCiState -> IO a
983 startGHCi g state = do ref <- newIORef state; unGHCi g ref
985 instance Monad GHCi where
986 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
987 return a = GHCi $ \s -> return a
989 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
990 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
991 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
993 getGHCiState = GHCi $ \r -> readIORef r
994 setGHCiState s = GHCi $ \r -> writeIORef r s
996 -- for convenience...
997 getCmState = getGHCiState >>= return . cmstate
998 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1000 isOptionSet :: GHCiOption -> GHCi Bool
1002 = do st <- getGHCiState
1003 return (opt `elem` options st)
1005 setOption :: GHCiOption -> GHCi ()
1007 = do st <- getGHCiState
1008 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1010 unsetOption :: GHCiOption -> GHCi ()
1012 = do st <- getGHCiState
1013 setGHCiState (st{ options = filter (/= opt) (options st) })
1015 io :: IO a -> GHCi a
1016 io m = GHCi { unGHCi = \s -> m >>= return }
1018 -----------------------------------------------------------------------------
1019 -- recursive exception handlers
1021 -- Don't forget to unblock async exceptions in the handler, or if we're
1022 -- in an exception loop (eg. let a = error a in a) the ^C exception
1023 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1025 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1026 ghciHandle h (GHCi m) = GHCi $ \s ->
1027 Exception.catch (m s)
1028 (\e -> unGHCi (ghciUnblock (h e)) s)
1030 ghciUnblock :: GHCi a -> GHCi a
1031 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1033 -----------------------------------------------------------------------------
1034 -- timing & statistics
1036 timeIt :: GHCi a -> GHCi a
1038 = do b <- isOptionSet ShowTiming
1041 else do allocs1 <- io $ getAllocations
1042 time1 <- io $ getCPUTime
1044 allocs2 <- io $ getAllocations
1045 time2 <- io $ getCPUTime
1046 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1049 foreign import ccall "getAllocations" getAllocations :: IO Int
1051 printTimes :: Int -> Integer -> IO ()
1052 printTimes allocs psecs
1053 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1054 secs_str = showFFloat (Just 2) secs
1055 putStrLn (showSDoc (
1056 parens (text (secs_str "") <+> text "secs" <> comma <+>
1057 int allocs <+> text "bytes")))
1059 -----------------------------------------------------------------------------
1066 -- Have to turn off buffering again, because we just
1067 -- reverted stdout, stderr & stdin to their defaults.
1069 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1070 -- Make it "safe", just in case