1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.139 2002/12/12 13:21:46 ross 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 )
27 import Finder ( flushFinderCache )
29 import Id ( isRecordSelector, recordSelectorFieldLabel,
30 isDataConWrapId, isDataConId, idName )
31 import Class ( className )
32 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
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 ( GhcException(..), showGhcException )
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 Foreign ( nullPtr )
75 import Foreign.C.String ( CString, peekCString, withCString )
76 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
78 import GHC.Posix ( setNonBlockingFD )
80 -----------------------------------------------------------------------------
84 \ / _ \\ /\\ /\\/ __(_)\n\
85 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
86 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
87 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
89 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
91 builtin_commands :: [(String, String -> GHCi Bool)]
93 ("add", keepGoing addModule),
94 ("browse", keepGoing browseCmd),
95 ("cd", keepGoing changeDirectory),
96 ("def", keepGoing defineMacro),
97 ("help", keepGoing help),
98 ("?", keepGoing help),
99 ("info", keepGoing info),
100 ("load", keepGoing loadModule),
101 ("module", keepGoing setContext),
102 ("reload", keepGoing reloadModule),
103 ("set", keepGoing setCmd),
104 ("show", keepGoing showCmd),
105 ("type", keepGoing typeOfExpr),
106 ("unset", keepGoing unsetOptions),
107 ("undef", keepGoing undefineMacro),
111 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
112 keepGoing a str = a str >> return False
114 shortHelpText = "use :? for help.\n"
116 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
118 \ Commands available from the prompt:\n\
120 \ <stmt> evaluate/run <stmt>\n\
121 \ :add <filename> ... add module(s) to the current target set\n\
122 \ :browse [*]<module> display the names defined by <module>\n\
123 \ :cd <dir> change directory to <dir>\n\
124 \ :def <cmd> <expr> define a command :<cmd>\n\
125 \ :help, :? display this list of commands\n\
126 \ :info [<name> ...] display information about the given names\n\
127 \ :load <filename> ... load module(s) and their dependents\n\
128 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
129 \ :reload reload the current module set\n\
131 \ :set <option> ... set options\n\
132 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
133 \ :set prog <progname> set the value returned by System.getProgName\n\
135 \ :show modules show the currently loaded modules\n\
136 \ :show bindings show the current bindings made at the prompt\n\
138 \ :type <expr> show the type of <expr>\n\
139 \ :undef <cmd> undefine user-defined command :<cmd>\n\
140 \ :unset <option> ... unset options\n\
142 \ :!<command> run the shell command <command>\n\
144 \ Options for `:set' and `:unset':\n\
146 \ +r revert top-level expressions after each evaluation\n\
147 \ +s print timing/memory stats after each evaluation\n\
148 \ +t print type after evaluation\n\
149 \ -<flags> most GHC command line flags can also be set here\n\
150 \ (eg. -v2, -fglasgow-exts, etc.)\n\
153 interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO ()
154 interactiveUI cmstate paths cmdline_objs = do
156 hSetBuffering stdout NoBuffering
158 dflags <- getDynFlags
160 -- packages are loaded "on-demand" now
162 linkLibraries dflags cmdline_objs
164 -- Initialise buffering for the *interpreted* I/O system
165 cmstate <- initInterpBuffering cmstate dflags
167 -- We don't want the cmd line to buffer any input that might be
168 -- intended for the program, so unbuffer stdin.
169 hSetBuffering stdin NoBuffering
171 -- initial context is just the Prelude
172 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
174 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
178 startGHCi (runGHCi paths dflags)
179 GHCiState{ progname = "<interactive>",
185 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
186 Readline.resetTerminal Nothing
191 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
192 runGHCi paths dflags = do
193 read_dot_files <- io (readIORef v_Read_DotGHCi)
195 when (read_dot_files) $ do
198 exists <- io (doesFileExist file)
200 dir_ok <- io (checkPerms ".")
201 file_ok <- io (checkPerms file)
202 when (dir_ok && file_ok) $ do
203 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
206 Right hdl -> fileLoop hdl False
208 when (read_dot_files) $ do
209 -- Read in $HOME/.ghci
210 either_dir <- io (IO.try (getEnv "HOME"))
214 cwd <- io (getCurrentDirectory)
215 when (dir /= cwd) $ do
216 let file = dir ++ "/.ghci"
217 ok <- io (checkPerms file)
219 either_hdl <- io (IO.try (openFile file ReadMode))
222 Right hdl -> fileLoop hdl False
224 -- perform a :load for files given on the GHCi command line
225 when (not (null paths)) $
226 ghciHandle showException $
227 loadModule (unwords paths)
229 -- enter the interactive loop
230 #if defined(mingw32_TARGET_OS)
231 -- always show prompt, since hIsTerminalDevice returns True for Consoles
232 -- only, which we may or may not be running under (cf. Emacs sub-shells.)
235 is_tty <- io (hIsTerminalDevice stdin)
236 interactiveLoop is_tty
240 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
243 interactiveLoop is_tty = do
244 -- ignore ^C exceptions caught here
245 ghciHandleDyn (\e -> case e of
246 Interrupted -> ghciUnblock (interactiveLoop is_tty)
247 _other -> return ()) $ do
249 -- read commands from stdin
250 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
253 else fileLoop stdin False -- turn off prompt for non-TTY input
255 fileLoop stdin is_tty
259 -- NOTE: We only read .ghci files if they are owned by the current user,
260 -- and aren't world writable. Otherwise, we could be accidentally
261 -- running code planted by a malicious third party.
263 -- Furthermore, We only read ./.ghci if . is owned by the current user
264 -- and isn't writable by anyone else. I think this is sufficient: we
265 -- don't need to check .. and ../.. etc. because "." always refers to
266 -- the same directory while a process is running.
268 checkPerms :: String -> IO Bool
270 #ifdef mingw32_TARGET_OS
273 DriverUtil.handle (\_ -> return False) $ do
274 st <- getFileStatus name
276 if fileOwner st /= me then do
277 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
280 let mode = fileMode st
281 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
282 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
284 putStrLn $ "*** WARNING: " ++ name ++
285 " is writable by someone else, IGNORING!"
290 fileLoop :: Handle -> Bool -> GHCi ()
291 fileLoop hdl prompt = do
292 cmstate <- getCmState
293 (mod,imports) <- io (cmGetContext cmstate)
294 when prompt (io (putStr (mkPrompt mod imports)))
295 l <- io (IO.try (hGetLine hdl))
297 Left e | isEOFError e -> return ()
298 | otherwise -> io (ioError e)
300 case remove_spaces l of
301 "" -> fileLoop hdl prompt
302 l -> do quit <- runCommand l
303 if quit then return () else fileLoop hdl prompt
305 stringLoop :: [String] -> GHCi ()
306 stringLoop [] = return ()
307 stringLoop (s:ss) = do
308 case remove_spaces s of
310 l -> do quit <- runCommand l
311 if quit then return () else stringLoop ss
313 mkPrompt toplevs exports
314 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
316 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
317 readlineLoop :: GHCi ()
319 cmstate <- getCmState
320 (mod,imports) <- io (cmGetContext cmstate)
322 l <- io (readline (mkPrompt mod imports)
323 `finally` setNonBlockingFD 0)
324 -- readline sometimes puts stdin into blocking mode,
325 -- so we need to put it back for the IO library
329 case remove_spaces l of
334 if quit then return () else readlineLoop
337 runCommand :: String -> GHCi Bool
338 runCommand c = ghciHandle handler (doCommand c)
340 -- This is the exception handler for exceptions generated by the
341 -- user's code; it normally just prints out the exception. The
342 -- handler must be recursive, in case showing the exception causes
343 -- more exceptions to be raised.
345 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
346 -- raising another exception. We therefore don't put the recursive
347 -- handler arond the flushing operation, so if stderr is closed
348 -- GHCi will just die gracefully rather than going into an infinite loop.
349 handler :: Exception -> GHCi Bool
350 handler exception = do
352 ghciHandle handler (showException exception >> return False)
354 showException (DynException dyn) =
355 case fromDynamic dyn of
356 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
357 Just Interrupted -> io (putStrLn "Interrupted.")
358 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
359 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
360 Just other_ghc_ex -> io (print other_ghc_ex)
362 showException other_exception
363 = io (putStrLn ("*** Exception: " ++ show other_exception))
365 doCommand (':' : command) = specialCommand command
367 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
370 runStmt :: String -> GHCi [Name]
372 | null (filter (not.isSpace) stmt) = return []
374 = do st <- getGHCiState
375 dflags <- io getDynFlags
376 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
377 (new_cmstate, result) <-
378 io $ withProgName (progname st) $ withArgs (args st) $
379 cmRunStmt (cmstate st) dflags' stmt
380 setGHCiState st{cmstate = new_cmstate}
382 CmRunFailed -> return []
383 CmRunException e -> showException e >> return []
384 CmRunOk names -> return names
386 -- possibly print the type and revert CAFs after evaluating an expression
388 = do b <- isOptionSet ShowType
389 cmstate <- getCmState
390 when b (mapM_ (showTypeOfName cmstate) names)
393 b <- isOptionSet RevertCAFs
394 io (when b revertCAFs)
397 showTypeOfName :: CmState -> Name -> GHCi ()
398 showTypeOfName cmstate n
399 = do maybe_str <- io (cmTypeOfName cmstate n)
402 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
404 specialCommand :: String -> GHCi Bool
405 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
406 specialCommand str = do
407 let (cmd,rest) = break isSpace str
408 cmds <- io (readIORef commands)
409 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
410 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
411 ++ shortHelpText) >> return False)
412 [(_,f)] -> f (dropWhile isSpace rest)
413 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
414 " matches multiple commands (" ++
415 foldr1 (\a b -> a ++ ',':b) (map fst cs)
416 ++ ")") >> return False)
418 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
421 -----------------------------------------------------------------------------
422 -- To flush buffers for the *interpreted* computation we need
423 -- to refer to *its* stdout/stderr handles
425 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
426 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
428 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
429 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
430 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
432 initInterpBuffering :: CmState -> DynFlags -> IO CmState
433 initInterpBuffering cmstate dflags
434 = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
437 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
438 other -> panic "interactiveUI:setBuffering"
440 (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
442 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
443 _ -> panic "interactiveUI:flush"
445 turnOffBuffering -- Turn it off right now
450 flushInterpBuffers :: GHCi ()
452 = io $ do Monad.join (readIORef flush_interp)
455 turnOffBuffering :: IO ()
457 = do Monad.join (readIORef turn_off_buffering)
460 -----------------------------------------------------------------------------
463 help :: String -> GHCi ()
464 help _ = io (putStr helpText)
466 info :: String -> GHCi ()
467 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
470 init_cms <- getCmState
471 dflags <- io getDynFlags
473 infoThings cms [] = return cms
474 infoThings cms (name:names) = do
475 (cms, stuff) <- io (cmInfoThing cms dflags name)
476 io (putStrLn (showSDocForUser unqual (
477 vcat (intersperse (text "") (map showThing stuff))))
481 unqual = cmGetPrintUnqual init_cms
483 showThing (ty_thing, fixity)
484 = vcat [ text "-- " <> showTyThing ty_thing,
485 showFixity fixity (getName ty_thing),
486 ppr (ifaceTyThing ty_thing) ]
489 | fix == defaultFixity = empty
490 | otherwise = ppr fix <+>
491 (if isSymOcc (nameOccName name)
493 else char '`' <> ppr name <> char '`')
495 showTyThing (AClass cl)
496 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
497 showTyThing (ATyCon ty)
499 = hcat [ppr ty, text " is a primitive type constructor"]
501 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
502 showTyThing (AnId id)
503 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
506 | isRecordSelector id =
507 case tyConClass_maybe (fieldLabelTyCon (
508 recordSelectorFieldLabel id)) of
509 Nothing -> text "record selector"
510 Just c -> text "method in class " <> ppr c
511 | isDataConWrapId id = text "data constructor"
512 | otherwise = text "variable"
514 -- also print out the source location for home things
516 | isHomePackageName name && isGoodSrcLoc loc
517 = hsep [ text ", defined at", ppr loc ]
520 where loc = nameSrcLoc name
522 cms <- infoThings init_cms names
526 addModule :: String -> GHCi ()
528 let files = words str
529 state <- getGHCiState
530 dflags <- io (getDynFlags)
531 io (revertCAFs) -- always revert CAFs on load/add.
532 let new_targets = files ++ targets state
533 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
534 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
535 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
536 setContextAfterLoad mods
537 modulesLoadedMsg ok mods dflags
539 changeDirectory :: String -> GHCi ()
540 changeDirectory ('~':d) = do
541 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
542 io (setCurrentDirectory (tilde ++ '/':d))
543 changeDirectory d = io (setCurrentDirectory d)
545 defineMacro :: String -> GHCi ()
547 let (macro_name, definition) = break isSpace s
548 cmds <- io (readIORef commands)
550 then throwDyn (CmdLineError "invalid macro name")
552 if (macro_name `elem` map fst cmds)
553 then throwDyn (CmdLineError
554 ("command `" ++ macro_name ++ "' is already defined"))
557 -- give the expression a type signature, so we can be sure we're getting
558 -- something of the right type.
559 let new_expr = '(' : definition ++ ") :: String -> IO String"
561 -- compile the expression
563 dflags <- io getDynFlags
564 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
565 setCmState new_cmstate
568 Just hv -> io (writeIORef commands --
569 ((macro_name, keepGoing (runMacro hv)) : cmds))
571 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
573 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
574 stringLoop (lines str)
576 undefineMacro :: String -> GHCi ()
577 undefineMacro macro_name = do
578 cmds <- io (readIORef commands)
579 if (macro_name `elem` map fst builtin_commands)
580 then throwDyn (CmdLineError
581 ("command `" ++ macro_name ++ "' cannot be undefined"))
583 if (macro_name `notElem` map fst cmds)
584 then throwDyn (CmdLineError
585 ("command `" ++ macro_name ++ "' not defined"))
587 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
590 loadModule :: String -> GHCi ()
591 loadModule str = timeIt (loadModule' str)
594 let files = words str
595 state <- getGHCiState
596 dflags <- io getDynFlags
598 -- do the dependency anal first, so that if it fails we don't throw
599 -- away the current set of modules.
600 graph <- io (cmDepAnal (cmstate state) dflags files)
602 -- Dependency anal ok, now unload everything
603 cmstate1 <- io (cmUnload (cmstate state) dflags)
604 setGHCiState state{ cmstate = cmstate1, targets = [] }
606 io (revertCAFs) -- always revert CAFs on load.
607 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
608 setGHCiState state{ cmstate = cmstate2, targets = files }
610 setContextAfterLoad mods
611 modulesLoadedMsg ok mods dflags
614 reloadModule :: String -> GHCi ()
616 state <- getGHCiState
617 dflags <- io getDynFlags
618 case targets state of
619 [] -> io (putStr "no current target\n")
621 -- do the dependency anal first, so that if it fails we don't throw
622 -- away the current set of modules.
623 graph <- io (cmDepAnal (cmstate state) dflags paths)
625 io (revertCAFs) -- always revert CAFs on reload.
627 <- io (cmLoadModules (cmstate state) dflags graph)
628 setGHCiState state{ cmstate=cmstate1 }
629 setContextAfterLoad mods
630 modulesLoadedMsg ok mods dflags
632 reloadModule _ = noArgs ":reload"
634 setContextAfterLoad [] = setContext prel
635 setContextAfterLoad (m:_) = do
636 cmstate <- getCmState
637 b <- io (cmModuleIsInterpreted cmstate m)
638 if b then setContext ('*':m) else setContext m
640 modulesLoadedMsg ok mods dflags =
641 when (verbosity dflags > 0) $ do
643 | null mods = text "none."
645 punctuate comma (map text mods)) <> text "."
648 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
650 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
653 typeOfExpr :: String -> GHCi ()
655 = do cms <- getCmState
656 dflags <- io getDynFlags
657 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
658 setCmState new_cmstate
661 Just tystr -> io (putStrLn tystr)
663 quit :: String -> GHCi Bool
666 shellEscape :: String -> GHCi Bool
667 shellEscape str = io (system str >> return False)
669 -----------------------------------------------------------------------------
670 -- Browing a module's contents
672 browseCmd :: String -> GHCi ()
675 ['*':m] | looksLikeModuleName m -> browseModule m False
676 [m] | looksLikeModuleName m -> browseModule m True
677 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
679 browseModule m exports_only = do
681 dflags <- io getDynFlags
683 is_interpreted <- io (cmModuleIsInterpreted cms m)
684 when (not is_interpreted && not exports_only) $
685 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
687 -- temporarily set the context to the module we're interested in,
688 -- just so we can get an appropriate PrintUnqualified
689 (as,bs) <- io (cmGetContext cms)
690 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
691 else cmSetContext cms dflags [m] [])
692 cms2 <- io (cmSetContext cms1 dflags as bs)
694 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
698 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
700 things' = filter wantToSee things
702 wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
705 thing_names = map getName things
707 thingDecl thing@(AnId id) = ifaceTyThing thing
709 thingDecl thing@(AClass c) =
710 let rn_decl = ifaceTyThing thing in
712 ClassDecl { tcdSigs = cons } ->
713 rn_decl{ tcdSigs = filter methodIsVisible cons }
716 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
718 thingDecl thing@(ATyCon t) =
719 let rn_decl = ifaceTyThing thing in
721 TyData { tcdCons = DataCons cons } ->
722 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
725 conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
727 io (putStrLn (showSDocForUser unqual (
728 vcat (map (ppr . thingDecl) things')))
733 -----------------------------------------------------------------------------
734 -- Setting the module context
737 | all sensible mods = fn mods
738 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
740 (fn, mods) = case str of
741 '+':stuff -> (addToContext, words stuff)
742 '-':stuff -> (removeFromContext, words stuff)
743 stuff -> (newContext, words stuff)
745 sensible ('*':m) = looksLikeModuleName m
746 sensible m = looksLikeModuleName m
750 dflags <- io getDynFlags
751 (as,bs) <- separate cms mods [] []
752 let bs' = if null as && prel `notElem` bs then prel:bs else bs
753 cms' <- io (cmSetContext cms dflags as bs')
756 separate cmstate [] as bs = return (as,bs)
757 separate cmstate (('*':m):ms) as bs = do
758 b <- io (cmModuleIsInterpreted cmstate m)
759 if b then separate cmstate ms (m:as) bs
760 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
761 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
766 addToContext mods = do
768 dflags <- io getDynFlags
769 (as,bs) <- io (cmGetContext cms)
771 (as',bs') <- separate cms mods [] []
773 let as_to_add = as' \\ (as ++ bs)
774 bs_to_add = bs' \\ (as ++ bs)
776 cms' <- io (cmSetContext cms dflags
777 (as ++ as_to_add) (bs ++ bs_to_add))
781 removeFromContext mods = do
783 dflags <- io getDynFlags
784 (as,bs) <- io (cmGetContext cms)
786 (as_to_remove,bs_to_remove) <- separate cms mods [] []
788 let as' = as \\ (as_to_remove ++ bs_to_remove)
789 bs' = bs \\ (as_to_remove ++ bs_to_remove)
791 cms' <- io (cmSetContext cms dflags as' bs')
794 ----------------------------------------------------------------------------
797 -- set options in the interpreter. Syntax is exactly the same as the
798 -- ghc command line, except that certain options aren't available (-C,
801 -- This is pretty fragile: most options won't work as expected. ToDo:
802 -- figure out which ones & disallow them.
804 setCmd :: String -> GHCi ()
806 = do st <- getGHCiState
807 let opts = options st
808 io $ putStrLn (showSDoc (
809 text "options currently set: " <>
812 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
816 ("args":args) -> setArgs args
817 ("prog":prog) -> setProg prog
818 wds -> setOptions wds
822 setGHCiState st{ args = args }
826 setGHCiState st{ progname = prog }
828 io (hPutStrLn stderr "syntax: :set prog <progname>")
831 do -- first, deal with the GHCi opts (+s, +t, etc.)
832 let (plus_opts, minus_opts) = partition isPlus wds
833 mapM_ setOpt plus_opts
835 -- now, the GHC flags
836 pkgs_before <- io (readIORef v_Packages)
837 leftovers <- io (processArgs static_flags minus_opts [])
838 pkgs_after <- io (readIORef v_Packages)
840 -- update things if the users wants more packages
841 let new_packages = pkgs_after \\ pkgs_before
842 when (not (null new_packages)) $
843 newPackages new_packages
845 -- don't forget about the extra command-line flags from the
846 -- extra_ghc_opts fields in the new packages
847 new_package_details <- io (getPackageDetails new_packages)
848 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
849 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
851 -- then, dynamic flags
854 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
857 if (not (null leftovers))
858 then throwDyn (CmdLineError ("unrecognised flags: " ++
863 unsetOptions :: String -> GHCi ()
865 = do -- first, deal with the GHCi opts (+s, +t, etc.)
867 (minus_opts, rest1) = partition isMinus opts
868 (plus_opts, rest2) = partition isPlus rest1
870 if (not (null rest2))
871 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
874 mapM_ unsetOpt plus_opts
876 -- can't do GHC flags for now
877 if (not (null minus_opts))
878 then throwDyn (CmdLineError "can't unset GHC command-line flags")
881 isMinus ('-':s) = True
884 isPlus ('+':s) = True
888 = case strToGHCiOpt str of
889 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
890 Just o -> setOption o
893 = case strToGHCiOpt str of
894 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
895 Just o -> unsetOption o
897 strToGHCiOpt :: String -> (Maybe GHCiOption)
898 strToGHCiOpt "s" = Just ShowTiming
899 strToGHCiOpt "t" = Just ShowType
900 strToGHCiOpt "r" = Just RevertCAFs
901 strToGHCiOpt _ = Nothing
903 optToStr :: GHCiOption -> String
904 optToStr ShowTiming = "s"
905 optToStr ShowType = "t"
906 optToStr RevertCAFs = "r"
908 newPackages new_pkgs = do -- The new packages are already in v_Packages
909 state <- getGHCiState
910 dflags <- io getDynFlags
911 cmstate1 <- io (cmUnload (cmstate state) dflags)
912 setGHCiState state{ cmstate = cmstate1, targets = [] }
913 setContextAfterLoad []
915 -----------------------------------------------------------------------------
920 ["modules" ] -> showModules
921 ["bindings"] -> showBindings
922 ["linker"] -> io showLinkerState
923 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
927 let (mg, hpt) = cmGetModInfo cms
928 mapM_ (showModule hpt) mg
931 showModule :: HomePackageTable -> ModSummary -> GHCi ()
932 showModule hpt mod_summary
933 = case lookupModuleEnv hpt mod of
934 Nothing -> panic "missing linkable"
935 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
937 obj_linkable = isObjectLinkable (hm_linkable mod_info)
939 mod = ms_mod mod_summary
940 locn = ms_location mod_summary
945 unqual = cmGetPrintUnqual cms
946 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
948 io (mapM_ showBinding (cmGetBindings cms))
952 -----------------------------------------------------------------------------
955 data GHCiState = GHCiState
959 targets :: [FilePath],
961 options :: [GHCiOption]
965 = ShowTiming -- show time/allocs after evaluation
966 | ShowType -- show the type of expressions
967 | RevertCAFs -- revert CAFs after every evaluation
970 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
972 startGHCi :: GHCi a -> GHCiState -> IO a
973 startGHCi g state = do ref <- newIORef state; unGHCi g ref
975 instance Monad GHCi where
976 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
977 return a = GHCi $ \s -> return a
979 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
980 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
981 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
983 getGHCiState = GHCi $ \r -> readIORef r
984 setGHCiState s = GHCi $ \r -> writeIORef r s
986 -- for convenience...
987 getCmState = getGHCiState >>= return . cmstate
988 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
990 isOptionSet :: GHCiOption -> GHCi Bool
992 = do st <- getGHCiState
993 return (opt `elem` options st)
995 setOption :: GHCiOption -> GHCi ()
997 = do st <- getGHCiState
998 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1000 unsetOption :: GHCiOption -> GHCi ()
1002 = do st <- getGHCiState
1003 setGHCiState (st{ options = filter (/= opt) (options st) })
1005 io :: IO a -> GHCi a
1006 io m = GHCi { unGHCi = \s -> m >>= return }
1008 -----------------------------------------------------------------------------
1009 -- recursive exception handlers
1011 -- Don't forget to unblock async exceptions in the handler, or if we're
1012 -- in an exception loop (eg. let a = error a in a) the ^C exception
1013 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1015 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1016 ghciHandle h (GHCi m) = GHCi $ \s ->
1017 Exception.catch (m s)
1018 (\e -> unGHCi (ghciUnblock (h e)) s)
1020 ghciUnblock :: GHCi a -> GHCi a
1021 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1023 -----------------------------------------------------------------------------
1024 -- timing & statistics
1026 timeIt :: GHCi a -> GHCi a
1028 = do b <- isOptionSet ShowTiming
1031 else do allocs1 <- io $ getAllocations
1032 time1 <- io $ getCPUTime
1034 allocs2 <- io $ getAllocations
1035 time2 <- io $ getCPUTime
1036 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1039 foreign import ccall "getAllocations" getAllocations :: IO Int
1041 printTimes :: Int -> Integer -> IO ()
1042 printTimes allocs psecs
1043 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1044 secs_str = showFFloat (Just 2) secs
1045 putStrLn (showSDoc (
1046 parens (text (secs_str "") <+> text "secs" <> comma <+>
1047 int allocs <+> text "bytes")))
1049 -----------------------------------------------------------------------------
1056 -- Have to turn off buffering again, because we just
1057 -- reverted stdout, stderr & stdin to their defaults.
1059 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1060 -- Make it "safe", just in case