1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.164 2004/04/05 10:50:26 simonpj Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2000
9 -----------------------------------------------------------------------------
10 module InteractiveUI (
11 interactiveUI, -- :: CmState -> [FilePath] -> IO ()
15 #include "../includes/config.h"
16 #include "HsVersions.h"
19 import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
20 isObjectLinkable, GhciMode(..) )
21 import IfaceSyn ( IfaceDecl( ifName ) )
24 import DriverUtil ( remove_spaces )
25 import Linker ( showLinkerState, linkPackages )
27 import Module ( showModMsg, lookupModuleEnv )
28 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
30 import OccName ( isSymOcc )
31 import BasicTypes ( defaultFixity, SuccessFlag(..) )
34 import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
35 restoreDynFlags, dopt_unset )
36 import Panic hiding ( showException )
39 #ifndef mingw32_HOST_OS
40 import DriverUtil( handle )
42 #if __GLASGOW_HASKELL__ > 504
47 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
48 import Control.Concurrent ( yield ) -- Used in readline loop
49 import System.Console.Readline as Readline
54 import Control.Exception as Exception
56 import Control.Concurrent
62 import System.Environment
63 import System.Directory
64 import System.IO as IO
66 import Control.Monad as Monad
68 import GHC.Exts ( unsafeCoerce# )
70 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
72 import System.Posix.Internals ( setNonBlockingFD )
74 -----------------------------------------------------------------------------
78 \ / _ \\ /\\ /\\/ __(_)\n\
79 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
80 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
81 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
83 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
85 builtin_commands :: [(String, String -> GHCi Bool)]
87 ("add", keepGoingPaths addModule),
88 ("browse", keepGoing browseCmd),
89 ("cd", keepGoing changeDirectory),
90 ("def", keepGoing defineMacro),
91 ("help", keepGoing help),
92 ("?", keepGoing help),
93 ("info", keepGoing info),
94 ("load", keepGoingPaths loadModule),
95 ("module", keepGoing setContext),
96 ("reload", keepGoing reloadModule),
97 ("set", keepGoing setCmd),
98 ("show", keepGoing showCmd),
99 ("type", keepGoing typeOfExpr),
100 ("kind", keepGoing kindOfType),
101 ("unset", keepGoing unsetOptions),
102 ("undef", keepGoing undefineMacro),
106 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
107 keepGoing a str = a str >> return False
109 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
110 keepGoingPaths a str = a (toArgs 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 :: [FilePath] -> Maybe String -> IO ()
152 interactiveUI srcs maybe_expr = do
153 dflags <- getDynFlags
155 cmstate <- cmInit Interactive dflags;
158 hSetBuffering stdout NoBuffering
160 -- Initialise buffering for the *interpreted* I/O system
161 initInterpBuffering cmstate
163 -- We don't want the cmd line to buffer any input that might be
164 -- intended for the program, so unbuffer stdin.
165 hSetBuffering stdin NoBuffering
167 -- initial context is just the Prelude
168 cmstate <- cmSetContext cmstate [] ["Prelude"]
170 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
174 startGHCi (runGHCi srcs dflags maybe_expr)
175 GHCiState{ progname = "<interactive>",
181 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
182 Readline.resetTerminal Nothing
187 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
188 runGHCi paths dflags maybe_expr = do
189 read_dot_files <- io (readIORef v_Read_DotGHCi)
191 when (read_dot_files) $ do
194 exists <- io (doesFileExist file)
196 dir_ok <- io (checkPerms ".")
197 file_ok <- io (checkPerms file)
198 when (dir_ok && file_ok) $ do
199 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
202 Right hdl -> fileLoop hdl False
204 when (read_dot_files) $ do
205 -- Read in $HOME/.ghci
206 either_dir <- io (IO.try (getEnv "HOME"))
210 cwd <- io (getCurrentDirectory)
211 when (dir /= cwd) $ do
212 let file = dir ++ "/.ghci"
213 ok <- io (checkPerms file)
215 either_hdl <- io (IO.try (openFile file ReadMode))
218 Right hdl -> fileLoop hdl False
220 -- Perform a :load for files given on the GHCi command line
221 when (not (null paths)) $
222 ghciHandle showException $
225 -- if verbosity is greater than 0, or we are connected to a
226 -- terminal, display the prompt in the interactive loop.
227 is_tty <- io (hIsTerminalDevice stdin)
228 let show_prompt = verbosity dflags > 0 || is_tty
232 -- enter the interactive loop
233 interactiveLoop is_tty show_prompt
235 -- just evaluate the expression we were given
240 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
243 interactiveLoop is_tty show_prompt = do
244 -- Ignore ^C exceptions caught here
245 ghciHandleDyn (\e -> case e of
246 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
247 _other -> return ()) $ do
249 -- read commands from stdin
250 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
253 else fileLoop stdin show_prompt
255 fileLoop stdin show_prompt
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_HOST_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 io installSignalHandlers
353 ghciHandle handler (showException exception >> return False)
355 showException (DynException dyn) =
356 case fromDynamic dyn of
357 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
358 Just Interrupted -> io (putStrLn "Interrupted.")
359 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
360 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
361 Just other_ghc_ex -> io (print other_ghc_ex)
363 showException other_exception
364 = io (putStrLn ("*** Exception: " ++ show other_exception))
366 doCommand (':' : command) = specialCommand command
368 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
371 runStmt :: String -> GHCi [Name]
373 | null (filter (not.isSpace) stmt) = return []
375 = do st <- getGHCiState
376 dflags <- io getDynFlags
377 let cm_state' = cmSetDFlags (cmstate st)
378 (dopt_unset dflags Opt_WarnUnusedBinds)
379 (new_cmstate, result) <-
380 io $ withProgName (progname st) $ withArgs (args st) $
381 cmRunStmt cm_state' stmt
382 setGHCiState st{cmstate = new_cmstate}
384 CmRunFailed -> return []
385 CmRunException e -> showException e >> return []
386 CmRunOk names -> return names
388 -- possibly print the type and revert CAFs after evaluating an expression
390 = do b <- isOptionSet ShowType
391 cmstate <- getCmState
392 when b (mapM_ (showTypeOfName cmstate) names)
395 io installSignalHandlers
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 -> IO ()
436 initInterpBuffering cmstate
437 = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
440 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
441 other -> panic "interactiveUI:setBuffering"
443 maybe_hval <- cmCompileExpr cmstate 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
475 infoThings cms [] = return cms
476 infoThings cms (name:names) = do
477 stuff <- io (cmInfoThing cms name)
478 io (putStrLn (showSDocForUser unqual (
479 vcat (intersperse (text "") (map showThing stuff))))
483 unqual = cmGetPrintUnqual init_cms
485 showThing (decl, fixity)
486 = vcat [ text "-- " <> showTyThing decl,
487 showFixity fixity (ifName decl),
491 | fix == defaultFixity = empty
492 | otherwise = ppr fix <+>
495 else char '`' <> ppr name <> char '`')
497 showTyThing decl = ppr decl
500 showTyThing (AClass cl)
501 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
502 showTyThing (ADataCon dc)
503 = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
504 showTyThing (ATyCon ty)
506 = hcat [ppr ty, text " is a primitive type constructor"]
508 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
509 showTyThing (AnId id)
510 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
513 = case globalIdDetails id of
514 RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
515 ClassOpId cls -> text "method in class" <+> ppr cls
516 otherwise -> text "variable"
518 -- also print out the source location for home things
520 | isHomePackageName name && isGoodSrcLoc loc
521 = hsep [ text ", defined at", ppr loc ]
524 where loc = nameSrcLoc name
527 infoThings init_cms names
530 addModule :: [FilePath] -> GHCi ()
532 state <- getGHCiState
533 io (revertCAFs) -- always revert CAFs on load/add.
534 files <- mapM expandPath files
535 let new_targets = files ++ targets state
536 graph <- io (cmDepAnal (cmstate state) new_targets)
537 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
538 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
539 setContextAfterLoad mods
540 dflags <- io getDynFlags
541 modulesLoadedMsg ok mods dflags
543 changeDirectory :: String -> GHCi ()
544 changeDirectory dir = do
545 state <- getGHCiState
546 when (targets state /= []) $
547 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\
548 \because the search path has changed.\n"
549 cmstate1 <- io (cmUnload (cmstate state))
550 setGHCiState state{ cmstate = cmstate1, targets = [] }
551 setContextAfterLoad []
552 dir <- expandPath dir
553 io (setCurrentDirectory dir)
555 defineMacro :: String -> GHCi ()
557 let (macro_name, definition) = break isSpace s
558 cmds <- io (readIORef commands)
560 then throwDyn (CmdLineError "invalid macro name")
562 if (macro_name `elem` map fst cmds)
563 then throwDyn (CmdLineError
564 ("command `" ++ macro_name ++ "' is already defined"))
567 -- give the expression a type signature, so we can be sure we're getting
568 -- something of the right type.
569 let new_expr = '(' : definition ++ ") :: String -> IO String"
571 -- compile the expression
573 maybe_hv <- io (cmCompileExpr cms new_expr)
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
606 files <- mapM expandPath files
608 -- do the dependency anal first, so that if it fails we don't throw
609 -- away the current set of modules.
610 graph <- io (cmDepAnal (cmstate state) files)
612 -- Dependency anal ok, now unload everything
613 cmstate1 <- io (cmUnload (cmstate state))
614 setGHCiState state{ cmstate = cmstate1, targets = [] }
616 io (revertCAFs) -- always revert CAFs on load.
617 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
618 setGHCiState state{ cmstate = cmstate2, targets = files }
620 setContextAfterLoad mods
621 dflags <- io (getDynFlags)
622 modulesLoadedMsg ok mods dflags
625 reloadModule :: String -> GHCi ()
627 state <- getGHCiState
628 case targets state of
629 [] -> io (putStr "no current target\n")
631 -- do the dependency anal first, so that if it fails we don't throw
632 -- away the current set of modules.
633 graph <- io (cmDepAnal (cmstate state) paths)
635 io (revertCAFs) -- always revert CAFs on reload.
637 <- io (cmLoadModules (cmstate state) graph)
638 setGHCiState state{ cmstate=cmstate1 }
639 setContextAfterLoad mods
640 dflags <- io getDynFlags
641 modulesLoadedMsg ok mods dflags
643 reloadModule _ = noArgs ":reload"
645 setContextAfterLoad [] = setContext prel
646 setContextAfterLoad (m:_) = do
647 cmstate <- getCmState
648 b <- io (cmModuleIsInterpreted cmstate m)
649 if b then setContext ('*':m) else setContext m
651 modulesLoadedMsg ok mods dflags =
652 when (verbosity dflags > 0) $ do
654 | null mods = text "none."
656 punctuate comma (map text mods)) <> text "."
659 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
661 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
664 typeOfExpr :: String -> GHCi ()
666 = do cms <- getCmState
667 maybe_tystr <- io (cmTypeOfExpr cms str)
670 Just tystr -> io (putStrLn tystr)
672 kindOfType :: String -> GHCi ()
674 = do cms <- getCmState
675 maybe_tystr <- io (cmKindOfType cms str)
678 Just tystr -> io (putStrLn tystr)
680 quit :: String -> GHCi Bool
683 shellEscape :: String -> GHCi Bool
684 shellEscape str = io (system str >> return False)
686 -----------------------------------------------------------------------------
687 -- Browsing a module's contents
689 browseCmd :: String -> GHCi ()
692 ['*':m] | looksLikeModuleName m -> browseModule m False
693 [m] | looksLikeModuleName m -> browseModule m True
694 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
696 browseModule m exports_only = do
699 is_interpreted <- io (cmModuleIsInterpreted cms m)
700 when (not is_interpreted && not exports_only) $
701 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
703 -- Temporarily set the context to the module we're interested in,
704 -- just so we can get an appropriate PrintUnqualified
705 (as,bs) <- io (cmGetContext cms)
706 cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
707 else cmSetContext cms [m] [])
708 cms2 <- io (cmSetContext cms1 as bs)
710 things <- io (cmBrowseModule cms2 m exports_only)
712 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
714 io (putStrLn (showSDocForUser unqual (
715 vcat (map ppr things)
718 -----------------------------------------------------------------------------
719 -- Setting the module context
722 | all sensible mods = fn mods
723 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
725 (fn, mods) = case str of
726 '+':stuff -> (addToContext, words stuff)
727 '-':stuff -> (removeFromContext, words stuff)
728 stuff -> (newContext, words stuff)
730 sensible ('*':m) = looksLikeModuleName m
731 sensible m = looksLikeModuleName m
735 (as,bs) <- separate cms mods [] []
736 let bs' = if null as && prel `notElem` bs then prel:bs else bs
737 cms' <- io (cmSetContext cms as bs')
740 separate cmstate [] as bs = return (as,bs)
741 separate cmstate (('*':m):ms) as bs = do
742 b <- io (cmModuleIsInterpreted cmstate m)
743 if b then separate cmstate ms (m:as) bs
744 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
745 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
750 addToContext mods = do
752 (as,bs) <- io (cmGetContext cms)
754 (as',bs') <- separate cms mods [] []
756 let as_to_add = as' \\ (as ++ bs)
757 bs_to_add = bs' \\ (as ++ bs)
759 cms' <- io (cmSetContext cms
760 (as ++ as_to_add) (bs ++ bs_to_add))
764 removeFromContext mods = do
766 (as,bs) <- io (cmGetContext cms)
768 (as_to_remove,bs_to_remove) <- separate cms mods [] []
770 let as' = as \\ (as_to_remove ++ bs_to_remove)
771 bs' = bs \\ (as_to_remove ++ bs_to_remove)
773 cms' <- io (cmSetContext cms as' bs')
776 ----------------------------------------------------------------------------
779 -- set options in the interpreter. Syntax is exactly the same as the
780 -- ghc command line, except that certain options aren't available (-C,
783 -- This is pretty fragile: most options won't work as expected. ToDo:
784 -- figure out which ones & disallow them.
786 setCmd :: String -> GHCi ()
788 = do st <- getGHCiState
789 let opts = options st
790 io $ putStrLn (showSDoc (
791 text "options currently set: " <>
794 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
798 ("args":args) -> setArgs args
799 ("prog":prog) -> setProg prog
800 wds -> setOptions wds
804 setGHCiState st{ args = args }
808 setGHCiState st{ progname = prog }
810 io (hPutStrLn stderr "syntax: :set prog <progname>")
813 do -- first, deal with the GHCi opts (+s, +t, etc.)
814 let (plus_opts, minus_opts) = partition isPlus wds
815 mapM_ setOpt plus_opts
817 -- now, the GHC flags
818 pkgs_before <- io (readIORef v_ExplicitPackages)
819 leftovers <- io (processArgs static_flags minus_opts [])
820 pkgs_after <- io (readIORef v_ExplicitPackages)
822 -- update things if the users wants more packages
823 let new_packages = pkgs_after \\ pkgs_before
824 when (not (null new_packages)) $
825 newPackages new_packages
827 -- don't forget about the extra command-line flags from the
828 -- extra_ghc_opts fields in the new packages
829 new_package_details <- io (getPackageDetails new_packages)
830 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
831 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
833 -- then, dynamic flags
836 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
839 if (not (null leftovers))
840 then throwDyn (CmdLineError ("unrecognised flags: " ++
845 unsetOptions :: String -> GHCi ()
847 = do -- first, deal with the GHCi opts (+s, +t, etc.)
849 (minus_opts, rest1) = partition isMinus opts
850 (plus_opts, rest2) = partition isPlus rest1
852 if (not (null rest2))
853 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
856 mapM_ unsetOpt plus_opts
858 -- can't do GHC flags for now
859 if (not (null minus_opts))
860 then throwDyn (CmdLineError "can't unset GHC command-line flags")
863 isMinus ('-':s) = True
866 isPlus ('+':s) = True
870 = case strToGHCiOpt str of
871 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
872 Just o -> setOption o
875 = case strToGHCiOpt str of
876 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
877 Just o -> unsetOption o
879 strToGHCiOpt :: String -> (Maybe GHCiOption)
880 strToGHCiOpt "s" = Just ShowTiming
881 strToGHCiOpt "t" = Just ShowType
882 strToGHCiOpt "r" = Just RevertCAFs
883 strToGHCiOpt _ = Nothing
885 optToStr :: GHCiOption -> String
886 optToStr ShowTiming = "s"
887 optToStr ShowType = "t"
888 optToStr RevertCAFs = "r"
890 newPackages new_pkgs = do -- The new packages are already in v_Packages
891 state <- getGHCiState
892 cmstate1 <- io (cmUnload (cmstate state))
893 setGHCiState state{ cmstate = cmstate1, targets = [] }
894 dflags <- io getDynFlags
895 io (linkPackages dflags new_pkgs)
896 setContextAfterLoad []
898 -- ---------------------------------------------------------------------------
903 ["modules" ] -> showModules
904 ["bindings"] -> showBindings
905 ["linker"] -> io showLinkerState
906 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
910 let (mg, hpt) = cmGetModInfo cms
911 mapM_ (showModule hpt) mg
914 showModule :: HomePackageTable -> ModSummary -> GHCi ()
915 showModule hpt mod_summary
916 = case lookupModuleEnv hpt mod of
917 Nothing -> panic "missing linkable"
918 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
920 obj_linkable = isObjectLinkable (hm_linkable mod_info)
922 mod = ms_mod mod_summary
923 locn = ms_location mod_summary
928 unqual = cmGetPrintUnqual cms
929 -- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
930 showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
932 io (mapM_ showBinding (cmGetBindings cms))
936 -----------------------------------------------------------------------------
939 data GHCiState = GHCiState
943 targets :: [FilePath],
945 options :: [GHCiOption]
949 = ShowTiming -- show time/allocs after evaluation
950 | ShowType -- show the type of expressions
951 | RevertCAFs -- revert CAFs after every evaluation
954 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
956 startGHCi :: GHCi a -> GHCiState -> IO a
957 startGHCi g state = do ref <- newIORef state; unGHCi g ref
959 instance Monad GHCi where
960 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
961 return a = GHCi $ \s -> return a
963 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
964 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
965 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
967 getGHCiState = GHCi $ \r -> readIORef r
968 setGHCiState s = GHCi $ \r -> writeIORef r s
970 -- for convenience...
971 getCmState = getGHCiState >>= return . cmstate
972 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
974 isOptionSet :: GHCiOption -> GHCi Bool
976 = do st <- getGHCiState
977 return (opt `elem` options st)
979 setOption :: GHCiOption -> GHCi ()
981 = do st <- getGHCiState
982 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
984 unsetOption :: GHCiOption -> GHCi ()
986 = do st <- getGHCiState
987 setGHCiState (st{ options = filter (/= opt) (options st) })
990 io m = GHCi { unGHCi = \s -> m >>= return }
992 -----------------------------------------------------------------------------
993 -- recursive exception handlers
995 -- Don't forget to unblock async exceptions in the handler, or if we're
996 -- in an exception loop (eg. let a = error a in a) the ^C exception
997 -- may never be delivered. Thanks to Marcin for pointing out the bug.
999 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1000 ghciHandle h (GHCi m) = GHCi $ \s ->
1001 Exception.catch (m s)
1002 (\e -> unGHCi (ghciUnblock (h e)) s)
1004 ghciUnblock :: GHCi a -> GHCi a
1005 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1007 -----------------------------------------------------------------------------
1008 -- timing & statistics
1010 timeIt :: GHCi a -> GHCi a
1012 = do b <- isOptionSet ShowTiming
1015 else do allocs1 <- io $ getAllocations
1016 time1 <- io $ getCPUTime
1018 allocs2 <- io $ getAllocations
1019 time2 <- io $ getCPUTime
1020 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1023 foreign import ccall "getAllocations" getAllocations :: IO Int
1025 printTimes :: Int -> Integer -> IO ()
1026 printTimes allocs psecs
1027 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1028 secs_str = showFFloat (Just 2) secs
1029 putStrLn (showSDoc (
1030 parens (text (secs_str "") <+> text "secs" <> comma <+>
1031 int allocs <+> text "bytes")))
1033 -----------------------------------------------------------------------------
1040 -- Have to turn off buffering again, because we just
1041 -- reverted stdout, stderr & stdin to their defaults.
1043 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1044 -- Make it "safe", just in case
1046 -- -----------------------------------------------------------------------------
1049 expandPath :: String -> GHCi String
1051 case dropWhile isSpace path of
1053 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1054 return (tilde ++ '/':d)