1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.142 2002/12/27 12:20:06 panne 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, 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 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", keepGoing 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", keepGoing 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 shortHelpText = "use :? for help.\n"
114 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
116 \ Commands available from the prompt:\n\
118 \ <stmt> evaluate/run <stmt>\n\
119 \ :add <filename> ... add module(s) to the current target set\n\
120 \ :browse [*]<module> display the names defined by <module>\n\
121 \ :cd <dir> change directory to <dir>\n\
122 \ :def <cmd> <expr> define a command :<cmd>\n\
123 \ :help, :? display this list of commands\n\
124 \ :info [<name> ...] display information about the given names\n\
125 \ :load <filename> ... load module(s) and their dependents\n\
126 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
127 \ :reload reload the current module set\n\
129 \ :set <option> ... set options\n\
130 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
131 \ :set prog <progname> set the value returned by System.getProgName\n\
133 \ :show modules show the currently loaded modules\n\
134 \ :show bindings show the current bindings made at the prompt\n\
136 \ :type <expr> show the type of <expr>\n\
137 \ :undef <cmd> undefine user-defined command :<cmd>\n\
138 \ :unset <option> ... unset options\n\
140 \ :!<command> run the shell command <command>\n\
142 \ Options for `:set' and `:unset':\n\
144 \ +r revert top-level expressions after each evaluation\n\
145 \ +s print timing/memory stats after each evaluation\n\
146 \ +t print type after evaluation\n\
147 \ -<flags> most GHC command line flags can also be set here\n\
148 \ (eg. -v2, -fglasgow-exts, etc.)\n\
151 interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO ()
152 interactiveUI cmstate paths cmdline_objs = do
154 hSetBuffering stdout NoBuffering
156 dflags <- getDynFlags
160 -- link packages requested explicitly on the command-line
161 expl <- readIORef v_ExplicitPackages
162 linkPackages dflags expl
164 -- link libraries from the command-line
165 linkLibraries dflags cmdline_objs
167 -- Initialise buffering for the *interpreted* I/O system
168 cmstate <- initInterpBuffering cmstate dflags
170 -- We don't want the cmd line to buffer any input that might be
171 -- intended for the program, so unbuffer stdin.
172 hSetBuffering stdin NoBuffering
174 -- initial context is just the Prelude
175 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
177 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
181 startGHCi (runGHCi paths dflags)
182 GHCiState{ progname = "<interactive>",
188 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
189 Readline.resetTerminal Nothing
194 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
195 runGHCi paths dflags = do
196 read_dot_files <- io (readIORef v_Read_DotGHCi)
198 when (read_dot_files) $ do
201 exists <- io (doesFileExist file)
203 dir_ok <- io (checkPerms ".")
204 file_ok <- io (checkPerms file)
205 when (dir_ok && file_ok) $ do
206 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
209 Right hdl -> fileLoop hdl False
211 when (read_dot_files) $ do
212 -- Read in $HOME/.ghci
213 either_dir <- io (IO.try (getEnv "HOME"))
217 cwd <- io (getCurrentDirectory)
218 when (dir /= cwd) $ do
219 let file = dir ++ "/.ghci"
220 ok <- io (checkPerms file)
222 either_hdl <- io (IO.try (openFile file ReadMode))
225 Right hdl -> fileLoop hdl False
227 -- perform a :load for files given on the GHCi command line
228 when (not (null paths)) $
229 ghciHandle showException $
230 loadModule (unwords paths)
232 -- enter the interactive loop
233 #if defined(mingw32_TARGET_OS)
234 -- always show prompt, since hIsTerminalDevice returns True for Consoles
235 -- only, which we may or may not be running under (cf. Emacs sub-shells.)
238 is_tty <- io (hIsTerminalDevice stdin)
239 interactiveLoop is_tty
243 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
246 interactiveLoop is_tty = do
247 -- ignore ^C exceptions caught here
248 ghciHandleDyn (\e -> case e of
249 Interrupted -> ghciUnblock (interactiveLoop is_tty)
250 _other -> return ()) $ do
252 -- read commands from stdin
253 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
256 else fileLoop stdin False -- turn off prompt for non-TTY input
258 fileLoop stdin is_tty
262 -- NOTE: We only read .ghci files if they are owned by the current user,
263 -- and aren't world writable. Otherwise, we could be accidentally
264 -- running code planted by a malicious third party.
266 -- Furthermore, We only read ./.ghci if . is owned by the current user
267 -- and isn't writable by anyone else. I think this is sufficient: we
268 -- don't need to check .. and ../.. etc. because "." always refers to
269 -- the same directory while a process is running.
271 checkPerms :: String -> IO Bool
273 #ifdef mingw32_TARGET_OS
276 DriverUtil.handle (\_ -> return False) $ do
277 st <- getFileStatus name
279 if fileOwner st /= me then do
280 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
283 let mode = fileMode st
284 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
285 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
287 putStrLn $ "*** WARNING: " ++ name ++
288 " is writable by someone else, IGNORING!"
293 fileLoop :: Handle -> Bool -> GHCi ()
294 fileLoop hdl prompt = do
295 cmstate <- getCmState
296 (mod,imports) <- io (cmGetContext cmstate)
297 when prompt (io (putStr (mkPrompt mod imports)))
298 l <- io (IO.try (hGetLine hdl))
300 Left e | isEOFError e -> return ()
301 | otherwise -> io (ioError e)
303 case remove_spaces l of
304 "" -> fileLoop hdl prompt
305 l -> do quit <- runCommand l
306 if quit then return () else fileLoop hdl prompt
308 stringLoop :: [String] -> GHCi ()
309 stringLoop [] = return ()
310 stringLoop (s:ss) = do
311 case remove_spaces s of
313 l -> do quit <- runCommand l
314 if quit then return () else stringLoop ss
316 mkPrompt toplevs exports
317 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
319 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
320 readlineLoop :: GHCi ()
322 cmstate <- getCmState
323 (mod,imports) <- io (cmGetContext cmstate)
325 l <- io (readline (mkPrompt mod imports)
326 `finally` setNonBlockingFD 0)
327 -- readline sometimes puts stdin into blocking mode,
328 -- so we need to put it back for the IO library
332 case remove_spaces l of
337 if quit then return () else readlineLoop
340 runCommand :: String -> GHCi Bool
341 runCommand c = ghciHandle handler (doCommand c)
343 -- This is the exception handler for exceptions generated by the
344 -- user's code; it normally just prints out the exception. The
345 -- handler must be recursive, in case showing the exception causes
346 -- more exceptions to be raised.
348 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
349 -- raising another exception. We therefore don't put the recursive
350 -- handler arond the flushing operation, so if stderr is closed
351 -- GHCi will just die gracefully rather than going into an infinite loop.
352 handler :: Exception -> GHCi Bool
353 handler exception = do
355 ghciHandle handler (showException exception >> return False)
357 showException (DynException dyn) =
358 case fromDynamic dyn of
359 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
360 Just Interrupted -> io (putStrLn "Interrupted.")
361 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
362 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
363 Just other_ghc_ex -> io (print other_ghc_ex)
365 showException other_exception
366 = io (putStrLn ("*** Exception: " ++ show other_exception))
368 doCommand (':' : command) = specialCommand command
370 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
373 runStmt :: String -> GHCi [Name]
375 | null (filter (not.isSpace) stmt) = return []
377 = do st <- getGHCiState
378 dflags <- io getDynFlags
379 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
380 (new_cmstate, result) <-
381 io $ withProgName (progname st) $ withArgs (args st) $
382 cmRunStmt (cmstate st) dflags' stmt
383 setGHCiState st{cmstate = new_cmstate}
385 CmRunFailed -> return []
386 CmRunException e -> showException e >> return []
387 CmRunOk names -> return names
389 -- possibly print the type and revert CAFs after evaluating an expression
391 = do b <- isOptionSet ShowType
392 cmstate <- getCmState
393 when b (mapM_ (showTypeOfName cmstate) names)
396 b <- isOptionSet RevertCAFs
397 io (when b revertCAFs)
400 showTypeOfName :: CmState -> Name -> GHCi ()
401 showTypeOfName cmstate n
402 = do maybe_str <- io (cmTypeOfName cmstate n)
405 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
407 specialCommand :: String -> GHCi Bool
408 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
409 specialCommand str = do
410 let (cmd,rest) = break isSpace str
411 cmds <- io (readIORef commands)
412 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
413 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
414 ++ shortHelpText) >> return False)
415 [(_,f)] -> f (dropWhile isSpace rest)
416 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
417 " matches multiple commands (" ++
418 foldr1 (\a b -> a ++ ',':b) (map fst cs)
419 ++ ")") >> return False)
421 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
424 -----------------------------------------------------------------------------
425 -- To flush buffers for the *interpreted* computation we need
426 -- to refer to *its* stdout/stderr handles
428 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
429 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
431 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
432 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
433 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
435 initInterpBuffering :: CmState -> DynFlags -> IO CmState
436 initInterpBuffering cmstate dflags
437 = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
440 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
441 other -> panic "interactiveUI:setBuffering"
443 (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
445 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
446 _ -> panic "interactiveUI:flush"
448 turnOffBuffering -- Turn it off right now
453 flushInterpBuffers :: GHCi ()
455 = io $ do Monad.join (readIORef flush_interp)
458 turnOffBuffering :: IO ()
460 = do Monad.join (readIORef turn_off_buffering)
463 -----------------------------------------------------------------------------
466 help :: String -> GHCi ()
467 help _ = io (putStr helpText)
469 info :: String -> GHCi ()
470 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
473 init_cms <- getCmState
474 dflags <- io getDynFlags
476 infoThings cms [] = return cms
477 infoThings cms (name:names) = do
478 (cms, stuff) <- io (cmInfoThing cms dflags name)
479 io (putStrLn (showSDocForUser unqual (
480 vcat (intersperse (text "") (map showThing stuff))))
484 unqual = cmGetPrintUnqual init_cms
486 showThing (ty_thing, fixity)
487 = vcat [ text "-- " <> showTyThing ty_thing,
488 showFixity fixity (getName ty_thing),
489 ppr (ifaceTyThing ty_thing) ]
492 | fix == defaultFixity = empty
493 | otherwise = ppr fix <+>
494 (if isSymOcc (nameOccName name)
496 else char '`' <> ppr name <> char '`')
498 showTyThing (AClass cl)
499 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
500 showTyThing (ATyCon ty)
502 = hcat [ppr ty, text " is a primitive type constructor"]
504 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
505 showTyThing (AnId id)
506 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
509 | isRecordSelector id =
510 case tyConClass_maybe (fieldLabelTyCon (
511 recordSelectorFieldLabel id)) of
512 Nothing -> text "record selector"
513 Just c -> text "method in class " <> ppr c
514 | isDataConWrapId id = text "data constructor"
515 | otherwise = text "variable"
517 -- also print out the source location for home things
519 | isHomePackageName name && isGoodSrcLoc loc
520 = hsep [ text ", defined at", ppr loc ]
523 where loc = nameSrcLoc name
525 cms <- infoThings init_cms names
529 addModule :: String -> GHCi ()
531 let files = words str
532 state <- getGHCiState
533 dflags <- io (getDynFlags)
534 io (revertCAFs) -- always revert CAFs on load/add.
535 let new_targets = files ++ targets state
536 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
537 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
538 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
539 setContextAfterLoad mods
540 modulesLoadedMsg ok mods dflags
542 changeDirectory :: String -> GHCi ()
543 changeDirectory ('~':d) = do
544 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
545 io (setCurrentDirectory (tilde ++ '/':d))
546 changeDirectory d = io (setCurrentDirectory d)
548 defineMacro :: String -> GHCi ()
550 let (macro_name, definition) = break isSpace s
551 cmds <- io (readIORef commands)
553 then throwDyn (CmdLineError "invalid macro name")
555 if (macro_name `elem` map fst cmds)
556 then throwDyn (CmdLineError
557 ("command `" ++ macro_name ++ "' is already defined"))
560 -- give the expression a type signature, so we can be sure we're getting
561 -- something of the right type.
562 let new_expr = '(' : definition ++ ") :: String -> IO String"
564 -- compile the expression
566 dflags <- io getDynFlags
567 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
568 setCmState new_cmstate
571 Just hv -> io (writeIORef commands --
572 ((macro_name, keepGoing (runMacro hv)) : cmds))
574 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
576 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
577 stringLoop (lines str)
579 undefineMacro :: String -> GHCi ()
580 undefineMacro macro_name = do
581 cmds <- io (readIORef commands)
582 if (macro_name `elem` map fst builtin_commands)
583 then throwDyn (CmdLineError
584 ("command `" ++ macro_name ++ "' cannot be undefined"))
586 if (macro_name `notElem` map fst cmds)
587 then throwDyn (CmdLineError
588 ("command `" ++ macro_name ++ "' not defined"))
590 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
593 loadModule :: String -> GHCi ()
594 loadModule str = timeIt (loadModule' str)
597 let files = words str
598 state <- getGHCiState
599 dflags <- io getDynFlags
601 -- do the dependency anal first, so that if it fails we don't throw
602 -- away the current set of modules.
603 graph <- io (cmDepAnal (cmstate state) dflags files)
605 -- Dependency anal ok, now unload everything
606 cmstate1 <- io (cmUnload (cmstate state) dflags)
607 setGHCiState state{ cmstate = cmstate1, targets = [] }
609 io (revertCAFs) -- always revert CAFs on load.
610 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
611 setGHCiState state{ cmstate = cmstate2, targets = files }
613 setContextAfterLoad mods
614 modulesLoadedMsg ok mods dflags
617 reloadModule :: String -> GHCi ()
619 state <- getGHCiState
620 dflags <- io getDynFlags
621 case targets state of
622 [] -> io (putStr "no current target\n")
624 -- do the dependency anal first, so that if it fails we don't throw
625 -- away the current set of modules.
626 graph <- io (cmDepAnal (cmstate state) dflags paths)
628 io (revertCAFs) -- always revert CAFs on reload.
630 <- io (cmLoadModules (cmstate state) dflags graph)
631 setGHCiState state{ cmstate=cmstate1 }
632 setContextAfterLoad mods
633 modulesLoadedMsg ok mods dflags
635 reloadModule _ = noArgs ":reload"
637 setContextAfterLoad [] = setContext prel
638 setContextAfterLoad (m:_) = do
639 cmstate <- getCmState
640 b <- io (cmModuleIsInterpreted cmstate m)
641 if b then setContext ('*':m) else setContext m
643 modulesLoadedMsg ok mods dflags =
644 when (verbosity dflags > 0) $ do
646 | null mods = text "none."
648 punctuate comma (map text mods)) <> text "."
651 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
653 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
656 typeOfExpr :: String -> GHCi ()
658 = do cms <- getCmState
659 dflags <- io getDynFlags
660 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
661 setCmState new_cmstate
664 Just tystr -> io (putStrLn tystr)
666 quit :: String -> GHCi Bool
669 shellEscape :: String -> GHCi Bool
670 shellEscape str = io (system str >> return False)
672 -----------------------------------------------------------------------------
673 -- Browing a module's contents
675 browseCmd :: String -> GHCi ()
678 ['*':m] | looksLikeModuleName m -> browseModule m False
679 [m] | looksLikeModuleName m -> browseModule m True
680 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
682 browseModule m exports_only = do
684 dflags <- io getDynFlags
686 is_interpreted <- io (cmModuleIsInterpreted cms m)
687 when (not is_interpreted && not exports_only) $
688 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
690 -- temporarily set the context to the module we're interested in,
691 -- just so we can get an appropriate PrintUnqualified
692 (as,bs) <- io (cmGetContext cms)
693 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
694 else cmSetContext cms dflags [m] [])
695 cms2 <- io (cmSetContext cms1 dflags as bs)
697 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
701 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
703 things' = filter wantToSee things
705 wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
708 thing_names = map getName things
710 thingDecl thing@(AnId id) = ifaceTyThing thing
712 thingDecl thing@(AClass c) =
713 let rn_decl = ifaceTyThing thing in
715 ClassDecl { tcdSigs = cons } ->
716 rn_decl{ tcdSigs = filter methodIsVisible cons }
719 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
721 thingDecl thing@(ATyCon t) =
722 let rn_decl = ifaceTyThing thing in
724 TyData { tcdCons = DataCons cons } ->
725 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
728 conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
730 io (putStrLn (showSDocForUser unqual (
731 vcat (map (ppr . thingDecl) things')))
736 -----------------------------------------------------------------------------
737 -- Setting the module context
740 | all sensible mods = fn mods
741 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
743 (fn, mods) = case str of
744 '+':stuff -> (addToContext, words stuff)
745 '-':stuff -> (removeFromContext, words stuff)
746 stuff -> (newContext, words stuff)
748 sensible ('*':m) = looksLikeModuleName m
749 sensible m = looksLikeModuleName m
753 dflags <- io getDynFlags
754 (as,bs) <- separate cms mods [] []
755 let bs' = if null as && prel `notElem` bs then prel:bs else bs
756 cms' <- io (cmSetContext cms dflags as bs')
759 separate cmstate [] as bs = return (as,bs)
760 separate cmstate (('*':m):ms) as bs = do
761 b <- io (cmModuleIsInterpreted cmstate m)
762 if b then separate cmstate ms (m:as) bs
763 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
764 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
769 addToContext mods = do
771 dflags <- io getDynFlags
772 (as,bs) <- io (cmGetContext cms)
774 (as',bs') <- separate cms mods [] []
776 let as_to_add = as' \\ (as ++ bs)
777 bs_to_add = bs' \\ (as ++ bs)
779 cms' <- io (cmSetContext cms dflags
780 (as ++ as_to_add) (bs ++ bs_to_add))
784 removeFromContext mods = do
786 dflags <- io getDynFlags
787 (as,bs) <- io (cmGetContext cms)
789 (as_to_remove,bs_to_remove) <- separate cms mods [] []
791 let as' = as \\ (as_to_remove ++ bs_to_remove)
792 bs' = bs \\ (as_to_remove ++ bs_to_remove)
794 cms' <- io (cmSetContext cms dflags as' bs')
797 ----------------------------------------------------------------------------
800 -- set options in the interpreter. Syntax is exactly the same as the
801 -- ghc command line, except that certain options aren't available (-C,
804 -- This is pretty fragile: most options won't work as expected. ToDo:
805 -- figure out which ones & disallow them.
807 setCmd :: String -> GHCi ()
809 = do st <- getGHCiState
810 let opts = options st
811 io $ putStrLn (showSDoc (
812 text "options currently set: " <>
815 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
819 ("args":args) -> setArgs args
820 ("prog":prog) -> setProg prog
821 wds -> setOptions wds
825 setGHCiState st{ args = args }
829 setGHCiState st{ progname = prog }
831 io (hPutStrLn stderr "syntax: :set prog <progname>")
834 do -- first, deal with the GHCi opts (+s, +t, etc.)
835 let (plus_opts, minus_opts) = partition isPlus wds
836 mapM_ setOpt plus_opts
838 -- now, the GHC flags
839 pkgs_before <- io (readIORef v_ExplicitPackages)
840 leftovers <- io (processArgs static_flags minus_opts [])
841 pkgs_after <- io (readIORef v_ExplicitPackages)
843 -- update things if the users wants more packages
844 let new_packages = pkgs_after \\ pkgs_before
845 when (not (null new_packages)) $
846 newPackages new_packages
848 -- don't forget about the extra command-line flags from the
849 -- extra_ghc_opts fields in the new packages
850 new_package_details <- io (getPackageDetails new_packages)
851 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
852 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
854 -- then, dynamic flags
857 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
860 if (not (null leftovers))
861 then throwDyn (CmdLineError ("unrecognised flags: " ++
866 unsetOptions :: String -> GHCi ()
868 = do -- first, deal with the GHCi opts (+s, +t, etc.)
870 (minus_opts, rest1) = partition isMinus opts
871 (plus_opts, rest2) = partition isPlus rest1
873 if (not (null rest2))
874 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
877 mapM_ unsetOpt plus_opts
879 -- can't do GHC flags for now
880 if (not (null minus_opts))
881 then throwDyn (CmdLineError "can't unset GHC command-line flags")
884 isMinus ('-':s) = True
887 isPlus ('+':s) = True
891 = case strToGHCiOpt str of
892 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
893 Just o -> setOption o
896 = case strToGHCiOpt str of
897 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
898 Just o -> unsetOption o
900 strToGHCiOpt :: String -> (Maybe GHCiOption)
901 strToGHCiOpt "s" = Just ShowTiming
902 strToGHCiOpt "t" = Just ShowType
903 strToGHCiOpt "r" = Just RevertCAFs
904 strToGHCiOpt _ = Nothing
906 optToStr :: GHCiOption -> String
907 optToStr ShowTiming = "s"
908 optToStr ShowType = "t"
909 optToStr RevertCAFs = "r"
911 newPackages new_pkgs = do -- The new packages are already in v_Packages
912 state <- getGHCiState
913 dflags <- io getDynFlags
914 cmstate1 <- io (cmUnload (cmstate state) dflags)
915 setGHCiState state{ cmstate = cmstate1, targets = [] }
916 io (linkPackages dflags new_pkgs)
917 setContextAfterLoad []
919 -- ---------------------------------------------------------------------------
924 ["modules" ] -> showModules
925 ["bindings"] -> showBindings
926 ["linker"] -> io showLinkerState
927 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
931 let (mg, hpt) = cmGetModInfo cms
932 mapM_ (showModule hpt) mg
935 showModule :: HomePackageTable -> ModSummary -> GHCi ()
936 showModule hpt mod_summary
937 = case lookupModuleEnv hpt mod of
938 Nothing -> panic "missing linkable"
939 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
941 obj_linkable = isObjectLinkable (hm_linkable mod_info)
943 mod = ms_mod mod_summary
944 locn = ms_location mod_summary
949 unqual = cmGetPrintUnqual cms
950 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
952 io (mapM_ showBinding (cmGetBindings cms))
956 -----------------------------------------------------------------------------
959 data GHCiState = GHCiState
963 targets :: [FilePath],
965 options :: [GHCiOption]
969 = ShowTiming -- show time/allocs after evaluation
970 | ShowType -- show the type of expressions
971 | RevertCAFs -- revert CAFs after every evaluation
974 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
976 startGHCi :: GHCi a -> GHCiState -> IO a
977 startGHCi g state = do ref <- newIORef state; unGHCi g ref
979 instance Monad GHCi where
980 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
981 return a = GHCi $ \s -> return a
983 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
984 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
985 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
987 getGHCiState = GHCi $ \r -> readIORef r
988 setGHCiState s = GHCi $ \r -> writeIORef r s
990 -- for convenience...
991 getCmState = getGHCiState >>= return . cmstate
992 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
994 isOptionSet :: GHCiOption -> GHCi Bool
996 = do st <- getGHCiState
997 return (opt `elem` options st)
999 setOption :: GHCiOption -> GHCi ()
1001 = do st <- getGHCiState
1002 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1004 unsetOption :: GHCiOption -> GHCi ()
1006 = do st <- getGHCiState
1007 setGHCiState (st{ options = filter (/= opt) (options st) })
1009 io :: IO a -> GHCi a
1010 io m = GHCi { unGHCi = \s -> m >>= return }
1012 -----------------------------------------------------------------------------
1013 -- recursive exception handlers
1015 -- Don't forget to unblock async exceptions in the handler, or if we're
1016 -- in an exception loop (eg. let a = error a in a) the ^C exception
1017 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1019 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1020 ghciHandle h (GHCi m) = GHCi $ \s ->
1021 Exception.catch (m s)
1022 (\e -> unGHCi (ghciUnblock (h e)) s)
1024 ghciUnblock :: GHCi a -> GHCi a
1025 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1027 -----------------------------------------------------------------------------
1028 -- timing & statistics
1030 timeIt :: GHCi a -> GHCi a
1032 = do b <- isOptionSet ShowTiming
1035 else do allocs1 <- io $ getAllocations
1036 time1 <- io $ getCPUTime
1038 allocs2 <- io $ getAllocations
1039 time2 <- io $ getCPUTime
1040 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1043 foreign import ccall "getAllocations" getAllocations :: IO Int
1045 printTimes :: Int -> Integer -> IO ()
1046 printTimes allocs psecs
1047 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1048 secs_str = showFFloat (Just 2) secs
1049 putStrLn (showSDoc (
1050 parens (text (secs_str "") <+> text "secs" <> comma <+>
1051 int allocs <+> text "bytes")))
1053 -----------------------------------------------------------------------------
1060 -- Have to turn off buffering again, because we just
1061 -- reverted stdout, stderr & stdin to their defaults.
1063 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1064 -- Make it "safe", just in case