1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.147 2003/02/20 13:12:40 simonpj 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 IdInfo ( GlobalIdDetails(..) )
30 import Id ( isImplicitId, idName, globalIdDetails )
31 import Class ( className )
32 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
33 import DataCon ( dataConName )
34 import FieldLabel ( fieldLabelTyCon )
35 import SrcLoc ( isGoodSrcLoc )
36 import Module ( showModMsg, lookupModuleEnv )
37 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
39 import OccName ( isSymOcc )
40 import BasicTypes ( defaultFixity, SuccessFlag(..) )
43 import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
44 restoreDynFlags, dopt_unset )
45 import Panic hiding ( showException )
48 #ifndef mingw32_TARGET_OS
52 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
53 import Control.Concurrent ( yield ) -- Used in readline loop
54 import System.Console.Readline as Readline
59 import Control.Exception as Exception
61 import Control.Concurrent
67 import System.Environment
68 import System.Directory
69 import System.IO as IO
71 import Control.Monad as Monad
73 import GHC.Exts ( unsafeCoerce# )
75 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
77 import GHC.Posix ( 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 ("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 \ :undef <cmd> undefine user-defined command :<cmd>\n\
142 \ :unset <option> ... unset options\n\
144 \ :!<command> run the shell command <command>\n\
146 \ Options for `:set' and `:unset':\n\
148 \ +r revert top-level expressions after each evaluation\n\
149 \ +s print timing/memory stats after each evaluation\n\
150 \ +t print type after evaluation\n\
151 \ -<flags> most GHC command line flags can also be set here\n\
152 \ (eg. -v2, -fglasgow-exts, etc.)\n\
155 interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO ()
156 interactiveUI cmstate paths cmdline_objs = do
158 hSetBuffering stdout NoBuffering
160 dflags <- getDynFlags
164 -- link packages requested explicitly on the command-line
165 expl <- readIORef v_ExplicitPackages
166 linkPackages dflags expl
168 -- link libraries from the command-line
169 linkLibraries dflags cmdline_objs
171 -- Initialise buffering for the *interpreted* I/O system
172 cmstate <- initInterpBuffering cmstate dflags
174 -- We don't want the cmd line to buffer any input that might be
175 -- intended for the program, so unbuffer stdin.
176 hSetBuffering stdin NoBuffering
178 -- initial context is just the Prelude
179 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
181 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
185 startGHCi (runGHCi paths dflags)
186 GHCiState{ progname = "<interactive>",
192 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
193 Readline.resetTerminal Nothing
198 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
199 runGHCi paths dflags = do
200 read_dot_files <- io (readIORef v_Read_DotGHCi)
202 when (read_dot_files) $ do
205 exists <- io (doesFileExist file)
207 dir_ok <- io (checkPerms ".")
208 file_ok <- io (checkPerms file)
209 when (dir_ok && file_ok) $ do
210 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
213 Right hdl -> fileLoop hdl False
215 when (read_dot_files) $ do
216 -- Read in $HOME/.ghci
217 either_dir <- io (IO.try (getEnv "HOME"))
221 cwd <- io (getCurrentDirectory)
222 when (dir /= cwd) $ do
223 let file = dir ++ "/.ghci"
224 ok <- io (checkPerms file)
226 either_hdl <- io (IO.try (openFile file ReadMode))
229 Right hdl -> fileLoop hdl False
231 -- perform a :load for files given on the GHCi command line
232 when (not (null paths)) $
233 ghciHandle showException $
236 -- enter the interactive loop
237 #if defined(mingw32_TARGET_OS)
238 -- always show prompt, since hIsTerminalDevice returns True for Consoles
239 -- only, which we may or may not be running under (cf. Emacs sub-shells.)
242 is_tty <- io (hIsTerminalDevice stdin)
243 interactiveLoop is_tty
247 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
250 interactiveLoop is_tty = do
251 -- ignore ^C exceptions caught here
252 ghciHandleDyn (\e -> case e of
253 Interrupted -> ghciUnblock (interactiveLoop is_tty)
254 _other -> return ()) $ do
256 -- read commands from stdin
257 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
260 else fileLoop stdin False -- turn off prompt for non-TTY input
262 fileLoop stdin is_tty
266 -- NOTE: We only read .ghci files if they are owned by the current user,
267 -- and aren't world writable. Otherwise, we could be accidentally
268 -- running code planted by a malicious third party.
270 -- Furthermore, We only read ./.ghci if . is owned by the current user
271 -- and isn't writable by anyone else. I think this is sufficient: we
272 -- don't need to check .. and ../.. etc. because "." always refers to
273 -- the same directory while a process is running.
275 checkPerms :: String -> IO Bool
277 #ifdef mingw32_TARGET_OS
280 DriverUtil.handle (\_ -> return False) $ do
281 st <- getFileStatus name
283 if fileOwner st /= me then do
284 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
287 let mode = fileMode st
288 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
289 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
291 putStrLn $ "*** WARNING: " ++ name ++
292 " is writable by someone else, IGNORING!"
297 fileLoop :: Handle -> Bool -> GHCi ()
298 fileLoop hdl prompt = do
299 cmstate <- getCmState
300 (mod,imports) <- io (cmGetContext cmstate)
301 when prompt (io (putStr (mkPrompt mod imports)))
302 l <- io (IO.try (hGetLine hdl))
304 Left e | isEOFError e -> return ()
305 | otherwise -> io (ioError e)
307 case remove_spaces l of
308 "" -> fileLoop hdl prompt
309 l -> do quit <- runCommand l
310 if quit then return () else fileLoop hdl prompt
312 stringLoop :: [String] -> GHCi ()
313 stringLoop [] = return ()
314 stringLoop (s:ss) = do
315 case remove_spaces s of
317 l -> do quit <- runCommand l
318 if quit then return () else stringLoop ss
320 mkPrompt toplevs exports
321 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
323 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
324 readlineLoop :: GHCi ()
326 cmstate <- getCmState
327 (mod,imports) <- io (cmGetContext cmstate)
329 l <- io (readline (mkPrompt mod imports)
330 `finally` setNonBlockingFD 0)
331 -- readline sometimes puts stdin into blocking mode,
332 -- so we need to put it back for the IO library
336 case remove_spaces l of
341 if quit then return () else readlineLoop
344 runCommand :: String -> GHCi Bool
345 runCommand c = ghciHandle handler (doCommand c)
347 -- This is the exception handler for exceptions generated by the
348 -- user's code; it normally just prints out the exception. The
349 -- handler must be recursive, in case showing the exception causes
350 -- more exceptions to be raised.
352 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
353 -- raising another exception. We therefore don't put the recursive
354 -- handler arond the flushing operation, so if stderr is closed
355 -- GHCi will just die gracefully rather than going into an infinite loop.
356 handler :: Exception -> GHCi Bool
357 handler exception = do
359 io installSignalHandlers
360 ghciHandle handler (showException exception >> return False)
362 showException (DynException dyn) =
363 case fromDynamic dyn of
364 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
365 Just Interrupted -> io (putStrLn "Interrupted.")
366 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
367 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
368 Just other_ghc_ex -> io (print other_ghc_ex)
370 showException other_exception
371 = io (putStrLn ("*** Exception: " ++ show other_exception))
373 doCommand (':' : command) = specialCommand command
375 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
378 runStmt :: String -> GHCi [Name]
380 | null (filter (not.isSpace) stmt) = return []
382 = do st <- getGHCiState
383 dflags <- io getDynFlags
384 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
385 (new_cmstate, result) <-
386 io $ withProgName (progname st) $ withArgs (args st) $
387 cmRunStmt (cmstate st) dflags' stmt
388 setGHCiState st{cmstate = new_cmstate}
390 CmRunFailed -> return []
391 CmRunException e -> showException e >> return []
392 CmRunOk names -> return names
394 -- possibly print the type and revert CAFs after evaluating an expression
396 = do b <- isOptionSet ShowType
397 cmstate <- getCmState
398 when b (mapM_ (showTypeOfName cmstate) names)
401 io installSignalHandlers
402 b <- isOptionSet RevertCAFs
403 io (when b revertCAFs)
406 showTypeOfName :: CmState -> Name -> GHCi ()
407 showTypeOfName cmstate n
408 = do maybe_str <- io (cmTypeOfName cmstate n)
411 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
413 specialCommand :: String -> GHCi Bool
414 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
415 specialCommand str = do
416 let (cmd,rest) = break isSpace str
417 cmds <- io (readIORef commands)
418 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
419 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
420 ++ shortHelpText) >> return False)
421 [(_,f)] -> f (dropWhile isSpace rest)
422 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
423 " matches multiple commands (" ++
424 foldr1 (\a b -> a ++ ',':b) (map fst cs)
425 ++ ")") >> return False)
427 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
430 -----------------------------------------------------------------------------
431 -- To flush buffers for the *interpreted* computation we need
432 -- to refer to *its* stdout/stderr handles
434 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
435 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
437 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
438 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
439 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
441 initInterpBuffering :: CmState -> DynFlags -> IO CmState
442 initInterpBuffering cmstate dflags
443 = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
446 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
447 other -> panic "interactiveUI:setBuffering"
449 (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
451 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
452 _ -> panic "interactiveUI:flush"
454 turnOffBuffering -- Turn it off right now
459 flushInterpBuffers :: GHCi ()
461 = io $ do Monad.join (readIORef flush_interp)
464 turnOffBuffering :: IO ()
466 = do Monad.join (readIORef turn_off_buffering)
469 -----------------------------------------------------------------------------
472 help :: String -> GHCi ()
473 help _ = io (putStr helpText)
475 info :: String -> GHCi ()
476 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
479 init_cms <- getCmState
480 dflags <- io getDynFlags
482 infoThings cms [] = return cms
483 infoThings cms (name:names) = do
484 (cms, stuff) <- io (cmInfoThing cms dflags name)
485 io (putStrLn (showSDocForUser unqual (
486 vcat (intersperse (text "") (map showThing stuff))))
490 unqual = cmGetPrintUnqual init_cms
492 showThing (ty_thing, fixity)
493 = vcat [ text "-- " <> showTyThing ty_thing,
494 showFixity fixity (getName ty_thing),
495 ppr (ifaceTyThing ty_thing) ]
498 | fix == defaultFixity = empty
499 | otherwise = ppr fix <+>
500 (if isSymOcc (nameOccName name)
502 else char '`' <> ppr name <> char '`')
504 showTyThing (AClass cl)
505 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
506 showTyThing (ADataCon dc)
507 = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
508 showTyThing (ATyCon ty)
510 = hcat [ppr ty, text " is a primitive type constructor"]
512 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
513 showTyThing (AnId id)
514 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
517 = case globalIdDetails id of
518 RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
519 ClassOpId cls -> text "method in class" <+> ppr cls
520 otherwise -> text "variable"
522 -- also print out the source location for home things
524 | isHomePackageName name && isGoodSrcLoc loc
525 = hsep [ text ", defined at", ppr loc ]
528 where loc = nameSrcLoc name
530 cms <- infoThings init_cms names
534 addModule :: [FilePath] -> GHCi ()
536 state <- getGHCiState
537 dflags <- io (getDynFlags)
538 io (revertCAFs) -- always revert CAFs on load/add.
539 let new_targets = files ++ targets state
540 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
541 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
542 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
543 setContextAfterLoad mods
544 modulesLoadedMsg ok mods dflags
546 changeDirectory :: String -> GHCi ()
547 changeDirectory ('~':d) = do
548 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
549 io (setCurrentDirectory (tilde ++ '/':d))
550 changeDirectory d = io (setCurrentDirectory d)
552 defineMacro :: String -> GHCi ()
554 let (macro_name, definition) = break isSpace s
555 cmds <- io (readIORef commands)
557 then throwDyn (CmdLineError "invalid macro name")
559 if (macro_name `elem` map fst cmds)
560 then throwDyn (CmdLineError
561 ("command `" ++ macro_name ++ "' is already defined"))
564 -- give the expression a type signature, so we can be sure we're getting
565 -- something of the right type.
566 let new_expr = '(' : definition ++ ") :: String -> IO String"
568 -- compile the expression
570 dflags <- io getDynFlags
571 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
572 setCmState new_cmstate
575 Just hv -> io (writeIORef commands --
576 ((macro_name, keepGoing (runMacro hv)) : cmds))
578 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
580 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
581 stringLoop (lines str)
583 undefineMacro :: String -> GHCi ()
584 undefineMacro macro_name = do
585 cmds <- io (readIORef commands)
586 if (macro_name `elem` map fst builtin_commands)
587 then throwDyn (CmdLineError
588 ("command `" ++ macro_name ++ "' cannot be undefined"))
590 if (macro_name `notElem` map fst cmds)
591 then throwDyn (CmdLineError
592 ("command `" ++ macro_name ++ "' not defined"))
594 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
597 loadModule :: [FilePath] -> GHCi ()
598 loadModule fs = timeIt (loadModule' fs)
600 loadModule' :: [FilePath] -> GHCi ()
601 loadModule' files = do
602 state <- getGHCiState
603 dflags <- io getDynFlags
605 -- do the dependency anal first, so that if it fails we don't throw
606 -- away the current set of modules.
607 graph <- io (cmDepAnal (cmstate state) dflags files)
609 -- Dependency anal ok, now unload everything
610 cmstate1 <- io (cmUnload (cmstate state) dflags)
611 setGHCiState state{ cmstate = cmstate1, targets = [] }
613 io (revertCAFs) -- always revert CAFs on load.
614 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
615 setGHCiState state{ cmstate = cmstate2, targets = files }
617 setContextAfterLoad mods
618 modulesLoadedMsg ok mods dflags
621 reloadModule :: String -> GHCi ()
623 state <- getGHCiState
624 dflags <- io getDynFlags
625 case targets state of
626 [] -> io (putStr "no current target\n")
628 -- do the dependency anal first, so that if it fails we don't throw
629 -- away the current set of modules.
630 graph <- io (cmDepAnal (cmstate state) dflags paths)
632 io (revertCAFs) -- always revert CAFs on reload.
634 <- io (cmLoadModules (cmstate state) dflags graph)
635 setGHCiState state{ cmstate=cmstate1 }
636 setContextAfterLoad mods
637 modulesLoadedMsg ok mods dflags
639 reloadModule _ = noArgs ":reload"
641 setContextAfterLoad [] = setContext prel
642 setContextAfterLoad (m:_) = do
643 cmstate <- getCmState
644 b <- io (cmModuleIsInterpreted cmstate m)
645 if b then setContext ('*':m) else setContext m
647 modulesLoadedMsg ok mods dflags =
648 when (verbosity dflags > 0) $ do
650 | null mods = text "none."
652 punctuate comma (map text mods)) <> text "."
655 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
657 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
660 typeOfExpr :: String -> GHCi ()
662 = do cms <- getCmState
663 dflags <- io getDynFlags
664 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
665 setCmState new_cmstate
668 Just tystr -> io (putStrLn tystr)
670 quit :: String -> GHCi Bool
673 shellEscape :: String -> GHCi Bool
674 shellEscape str = io (system str >> return False)
676 -----------------------------------------------------------------------------
677 -- Browing a module's contents
679 browseCmd :: String -> GHCi ()
682 ['*':m] | looksLikeModuleName m -> browseModule m False
683 [m] | looksLikeModuleName m -> browseModule m True
684 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
686 browseModule m exports_only = do
688 dflags <- io getDynFlags
690 is_interpreted <- io (cmModuleIsInterpreted cms m)
691 when (not is_interpreted && not exports_only) $
692 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
694 -- temporarily set the context to the module we're interested in,
695 -- just so we can get an appropriate PrintUnqualified
696 (as,bs) <- io (cmGetContext cms)
697 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
698 else cmSetContext cms dflags [m] [])
699 cms2 <- io (cmSetContext cms1 dflags as bs)
701 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
705 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
707 things' = filter wantToSee things
709 wantToSee (AnId id) = not (isImplicitId id)
710 wantToSee (ADataCon _) = False -- They'll come via their TyCon
713 thing_names = map getName things
715 thingDecl thing@(AnId id) = ifaceTyThing thing
717 thingDecl thing@(AClass c) =
718 let rn_decl = ifaceTyThing thing in
720 ClassDecl { tcdSigs = cons } ->
721 rn_decl{ tcdSigs = filter methodIsVisible cons }
724 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
726 thingDecl thing@(ATyCon t) =
727 let rn_decl = ifaceTyThing thing in
729 TyData { tcdCons = DataCons cons } ->
730 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
733 conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
735 io (putStrLn (showSDocForUser unqual (
736 vcat (map (ppr . thingDecl) things')))
741 -----------------------------------------------------------------------------
742 -- Setting the module context
745 | all sensible mods = fn mods
746 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
748 (fn, mods) = case str of
749 '+':stuff -> (addToContext, words stuff)
750 '-':stuff -> (removeFromContext, words stuff)
751 stuff -> (newContext, words stuff)
753 sensible ('*':m) = looksLikeModuleName m
754 sensible m = looksLikeModuleName m
758 dflags <- io getDynFlags
759 (as,bs) <- separate cms mods [] []
760 let bs' = if null as && prel `notElem` bs then prel:bs else bs
761 cms' <- io (cmSetContext cms dflags as bs')
764 separate cmstate [] as bs = return (as,bs)
765 separate cmstate (('*':m):ms) as bs = do
766 b <- io (cmModuleIsInterpreted cmstate m)
767 if b then separate cmstate ms (m:as) bs
768 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
769 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
774 addToContext mods = do
776 dflags <- io getDynFlags
777 (as,bs) <- io (cmGetContext cms)
779 (as',bs') <- separate cms mods [] []
781 let as_to_add = as' \\ (as ++ bs)
782 bs_to_add = bs' \\ (as ++ bs)
784 cms' <- io (cmSetContext cms dflags
785 (as ++ as_to_add) (bs ++ bs_to_add))
789 removeFromContext mods = do
791 dflags <- io getDynFlags
792 (as,bs) <- io (cmGetContext cms)
794 (as_to_remove,bs_to_remove) <- separate cms mods [] []
796 let as' = as \\ (as_to_remove ++ bs_to_remove)
797 bs' = bs \\ (as_to_remove ++ bs_to_remove)
799 cms' <- io (cmSetContext cms dflags as' bs')
802 ----------------------------------------------------------------------------
805 -- set options in the interpreter. Syntax is exactly the same as the
806 -- ghc command line, except that certain options aren't available (-C,
809 -- This is pretty fragile: most options won't work as expected. ToDo:
810 -- figure out which ones & disallow them.
812 setCmd :: String -> GHCi ()
814 = do st <- getGHCiState
815 let opts = options st
816 io $ putStrLn (showSDoc (
817 text "options currently set: " <>
820 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
824 ("args":args) -> setArgs args
825 ("prog":prog) -> setProg prog
826 wds -> setOptions wds
830 setGHCiState st{ args = args }
834 setGHCiState st{ progname = prog }
836 io (hPutStrLn stderr "syntax: :set prog <progname>")
839 do -- first, deal with the GHCi opts (+s, +t, etc.)
840 let (plus_opts, minus_opts) = partition isPlus wds
841 mapM_ setOpt plus_opts
843 -- now, the GHC flags
844 pkgs_before <- io (readIORef v_ExplicitPackages)
845 leftovers <- io (processArgs static_flags minus_opts [])
846 pkgs_after <- io (readIORef v_ExplicitPackages)
848 -- update things if the users wants more packages
849 let new_packages = pkgs_after \\ pkgs_before
850 when (not (null new_packages)) $
851 newPackages new_packages
853 -- don't forget about the extra command-line flags from the
854 -- extra_ghc_opts fields in the new packages
855 new_package_details <- io (getPackageDetails new_packages)
856 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
857 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
859 -- then, dynamic flags
862 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
865 if (not (null leftovers))
866 then throwDyn (CmdLineError ("unrecognised flags: " ++
871 unsetOptions :: String -> GHCi ()
873 = do -- first, deal with the GHCi opts (+s, +t, etc.)
875 (minus_opts, rest1) = partition isMinus opts
876 (plus_opts, rest2) = partition isPlus rest1
878 if (not (null rest2))
879 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
882 mapM_ unsetOpt plus_opts
884 -- can't do GHC flags for now
885 if (not (null minus_opts))
886 then throwDyn (CmdLineError "can't unset GHC command-line flags")
889 isMinus ('-':s) = True
892 isPlus ('+':s) = True
896 = case strToGHCiOpt str of
897 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
898 Just o -> setOption o
901 = case strToGHCiOpt str of
902 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
903 Just o -> unsetOption o
905 strToGHCiOpt :: String -> (Maybe GHCiOption)
906 strToGHCiOpt "s" = Just ShowTiming
907 strToGHCiOpt "t" = Just ShowType
908 strToGHCiOpt "r" = Just RevertCAFs
909 strToGHCiOpt _ = Nothing
911 optToStr :: GHCiOption -> String
912 optToStr ShowTiming = "s"
913 optToStr ShowType = "t"
914 optToStr RevertCAFs = "r"
916 newPackages new_pkgs = do -- The new packages are already in v_Packages
917 state <- getGHCiState
918 dflags <- io getDynFlags
919 cmstate1 <- io (cmUnload (cmstate state) dflags)
920 setGHCiState state{ cmstate = cmstate1, targets = [] }
921 io (linkPackages dflags new_pkgs)
922 setContextAfterLoad []
924 -- ---------------------------------------------------------------------------
929 ["modules" ] -> showModules
930 ["bindings"] -> showBindings
931 ["linker"] -> io showLinkerState
932 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
936 let (mg, hpt) = cmGetModInfo cms
937 mapM_ (showModule hpt) mg
940 showModule :: HomePackageTable -> ModSummary -> GHCi ()
941 showModule hpt mod_summary
942 = case lookupModuleEnv hpt mod of
943 Nothing -> panic "missing linkable"
944 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
946 obj_linkable = isObjectLinkable (hm_linkable mod_info)
948 mod = ms_mod mod_summary
949 locn = ms_location mod_summary
954 unqual = cmGetPrintUnqual cms
955 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
957 io (mapM_ showBinding (cmGetBindings cms))
961 -----------------------------------------------------------------------------
964 data GHCiState = GHCiState
968 targets :: [FilePath],
970 options :: [GHCiOption]
974 = ShowTiming -- show time/allocs after evaluation
975 | ShowType -- show the type of expressions
976 | RevertCAFs -- revert CAFs after every evaluation
979 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
981 startGHCi :: GHCi a -> GHCiState -> IO a
982 startGHCi g state = do ref <- newIORef state; unGHCi g ref
984 instance Monad GHCi where
985 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
986 return a = GHCi $ \s -> return a
988 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
989 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
990 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
992 getGHCiState = GHCi $ \r -> readIORef r
993 setGHCiState s = GHCi $ \r -> writeIORef r s
995 -- for convenience...
996 getCmState = getGHCiState >>= return . cmstate
997 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
999 isOptionSet :: GHCiOption -> GHCi Bool
1001 = do st <- getGHCiState
1002 return (opt `elem` options st)
1004 setOption :: GHCiOption -> GHCi ()
1006 = do st <- getGHCiState
1007 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1009 unsetOption :: GHCiOption -> GHCi ()
1011 = do st <- getGHCiState
1012 setGHCiState (st{ options = filter (/= opt) (options st) })
1014 io :: IO a -> GHCi a
1015 io m = GHCi { unGHCi = \s -> m >>= return }
1017 -----------------------------------------------------------------------------
1018 -- recursive exception handlers
1020 -- Don't forget to unblock async exceptions in the handler, or if we're
1021 -- in an exception loop (eg. let a = error a in a) the ^C exception
1022 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1024 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1025 ghciHandle h (GHCi m) = GHCi $ \s ->
1026 Exception.catch (m s)
1027 (\e -> unGHCi (ghciUnblock (h e)) s)
1029 ghciUnblock :: GHCi a -> GHCi a
1030 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1032 -----------------------------------------------------------------------------
1033 -- timing & statistics
1035 timeIt :: GHCi a -> GHCi a
1037 = do b <- isOptionSet ShowTiming
1040 else do allocs1 <- io $ getAllocations
1041 time1 <- io $ getCPUTime
1043 allocs2 <- io $ getAllocations
1044 time2 <- io $ getCPUTime
1045 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1048 foreign import ccall "getAllocations" getAllocations :: IO Int
1050 printTimes :: Int -> Integer -> IO ()
1051 printTimes allocs psecs
1052 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1053 secs_str = showFFloat (Just 2) secs
1054 putStrLn (showSDoc (
1055 parens (text (secs_str "") <+> text "secs" <> comma <+>
1056 int allocs <+> text "bytes")))
1058 -----------------------------------------------------------------------------
1065 -- Have to turn off buffering again, because we just
1066 -- reverted stdout, stderr & stdin to their defaults.
1068 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1069 -- Make it "safe", just in case