1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.165 2004/04/05 11:14:30 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 \ :kind <type> show the kind of <type>\n\
138 \ :undef <cmd> undefine user-defined command :<cmd>\n\
139 \ :unset <option> ... unset options\n\
141 \ :!<command> run the shell command <command>\n\
143 \ Options for `:set' and `:unset':\n\
145 \ +r revert top-level expressions after each evaluation\n\
146 \ +s print timing/memory stats after each evaluation\n\
147 \ +t print type after evaluation\n\
148 \ -<flags> most GHC command line flags can also be set here\n\
149 \ (eg. -v2, -fglasgow-exts, etc.)\n\
152 interactiveUI :: [FilePath] -> Maybe String -> IO ()
153 interactiveUI srcs maybe_expr = do
154 dflags <- getDynFlags
156 cmstate <- cmInit Interactive dflags;
159 hSetBuffering stdout NoBuffering
161 -- Initialise buffering for the *interpreted* I/O system
162 initInterpBuffering cmstate
164 -- We don't want the cmd line to buffer any input that might be
165 -- intended for the program, so unbuffer stdin.
166 hSetBuffering stdin NoBuffering
168 -- initial context is just the Prelude
169 cmstate <- cmSetContext cmstate [] ["Prelude"]
171 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
175 startGHCi (runGHCi srcs dflags maybe_expr)
176 GHCiState{ progname = "<interactive>",
182 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
183 Readline.resetTerminal Nothing
188 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
189 runGHCi paths dflags maybe_expr = do
190 read_dot_files <- io (readIORef v_Read_DotGHCi)
192 when (read_dot_files) $ do
195 exists <- io (doesFileExist file)
197 dir_ok <- io (checkPerms ".")
198 file_ok <- io (checkPerms file)
199 when (dir_ok && file_ok) $ do
200 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
203 Right hdl -> fileLoop hdl False
205 when (read_dot_files) $ do
206 -- Read in $HOME/.ghci
207 either_dir <- io (IO.try (getEnv "HOME"))
211 cwd <- io (getCurrentDirectory)
212 when (dir /= cwd) $ do
213 let file = dir ++ "/.ghci"
214 ok <- io (checkPerms file)
216 either_hdl <- io (IO.try (openFile file ReadMode))
219 Right hdl -> fileLoop hdl False
221 -- Perform a :load for files given on the GHCi command line
222 when (not (null paths)) $
223 ghciHandle showException $
226 -- if verbosity is greater than 0, or we are connected to a
227 -- terminal, display the prompt in the interactive loop.
228 is_tty <- io (hIsTerminalDevice stdin)
229 let show_prompt = verbosity dflags > 0 || is_tty
233 -- enter the interactive loop
234 interactiveLoop is_tty show_prompt
236 -- just evaluate the expression we were given
241 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
244 interactiveLoop is_tty show_prompt = do
245 -- Ignore ^C exceptions caught here
246 ghciHandleDyn (\e -> case e of
247 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
248 _other -> return ()) $ do
250 -- read commands from stdin
251 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
254 else fileLoop stdin show_prompt
256 fileLoop stdin show_prompt
260 -- NOTE: We only read .ghci files if they are owned by the current user,
261 -- and aren't world writable. Otherwise, we could be accidentally
262 -- running code planted by a malicious third party.
264 -- Furthermore, We only read ./.ghci if . is owned by the current user
265 -- and isn't writable by anyone else. I think this is sufficient: we
266 -- don't need to check .. and ../.. etc. because "." always refers to
267 -- the same directory while a process is running.
269 checkPerms :: String -> IO Bool
271 #ifdef mingw32_HOST_OS
274 DriverUtil.handle (\_ -> return False) $ do
275 st <- getFileStatus name
277 if fileOwner st /= me then do
278 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
281 let mode = fileMode st
282 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
283 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
285 putStrLn $ "*** WARNING: " ++ name ++
286 " is writable by someone else, IGNORING!"
291 fileLoop :: Handle -> Bool -> GHCi ()
292 fileLoop hdl prompt = do
293 cmstate <- getCmState
294 (mod,imports) <- io (cmGetContext cmstate)
295 when prompt (io (putStr (mkPrompt mod imports)))
296 l <- io (IO.try (hGetLine hdl))
298 Left e | isEOFError e -> return ()
299 | otherwise -> io (ioError e)
301 case remove_spaces l of
302 "" -> fileLoop hdl prompt
303 l -> do quit <- runCommand l
304 if quit then return () else fileLoop hdl prompt
306 stringLoop :: [String] -> GHCi ()
307 stringLoop [] = return ()
308 stringLoop (s:ss) = do
309 case remove_spaces s of
311 l -> do quit <- runCommand l
312 if quit then return () else stringLoop ss
314 mkPrompt toplevs exports
315 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
317 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
318 readlineLoop :: GHCi ()
320 cmstate <- getCmState
321 (mod,imports) <- io (cmGetContext cmstate)
323 l <- io (readline (mkPrompt mod imports)
324 `finally` setNonBlockingFD 0)
325 -- readline sometimes puts stdin into blocking mode,
326 -- so we need to put it back for the IO library
330 case remove_spaces l of
335 if quit then return () else readlineLoop
338 runCommand :: String -> GHCi Bool
339 runCommand c = ghciHandle handler (doCommand c)
341 -- This is the exception handler for exceptions generated by the
342 -- user's code; it normally just prints out the exception. The
343 -- handler must be recursive, in case showing the exception causes
344 -- more exceptions to be raised.
346 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
347 -- raising another exception. We therefore don't put the recursive
348 -- handler arond the flushing operation, so if stderr is closed
349 -- GHCi will just die gracefully rather than going into an infinite loop.
350 handler :: Exception -> GHCi Bool
351 handler exception = do
353 io installSignalHandlers
354 ghciHandle handler (showException exception >> return False)
356 showException (DynException dyn) =
357 case fromDynamic dyn of
358 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
359 Just Interrupted -> io (putStrLn "Interrupted.")
360 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
361 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
362 Just other_ghc_ex -> io (print other_ghc_ex)
364 showException other_exception
365 = io (putStrLn ("*** Exception: " ++ show other_exception))
367 doCommand (':' : command) = specialCommand command
369 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
372 runStmt :: String -> GHCi [Name]
374 | null (filter (not.isSpace) stmt) = return []
376 = do st <- getGHCiState
377 dflags <- io getDynFlags
378 let cm_state' = cmSetDFlags (cmstate st)
379 (dopt_unset dflags Opt_WarnUnusedBinds)
380 (new_cmstate, result) <-
381 io $ withProgName (progname st) $ withArgs (args st) $
382 cmRunStmt cm_state' 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 io installSignalHandlers
397 b <- isOptionSet RevertCAFs
398 io (when b revertCAFs)
401 showTypeOfName :: CmState -> Name -> GHCi ()
402 showTypeOfName cmstate n
403 = do maybe_str <- io (cmTypeOfName cmstate n)
406 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
408 specialCommand :: String -> GHCi Bool
409 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
410 specialCommand str = do
411 let (cmd,rest) = break isSpace str
412 cmds <- io (readIORef commands)
413 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
414 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
415 ++ shortHelpText) >> return False)
416 [(_,f)] -> f (dropWhile isSpace rest)
417 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
418 " matches multiple commands (" ++
419 foldr1 (\a b -> a ++ ',':b) (map fst cs)
420 ++ ")") >> return False)
422 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
425 -----------------------------------------------------------------------------
426 -- To flush buffers for the *interpreted* computation we need
427 -- to refer to *its* stdout/stderr handles
429 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
430 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
432 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
433 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
434 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
436 initInterpBuffering :: CmState -> IO ()
437 initInterpBuffering cmstate
438 = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
441 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
442 other -> panic "interactiveUI:setBuffering"
444 maybe_hval <- cmCompileExpr cmstate flush_cmd
446 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
447 _ -> panic "interactiveUI:flush"
449 turnOffBuffering -- Turn it off right now
454 flushInterpBuffers :: GHCi ()
456 = io $ do Monad.join (readIORef flush_interp)
459 turnOffBuffering :: IO ()
461 = do Monad.join (readIORef turn_off_buffering)
464 -----------------------------------------------------------------------------
467 help :: String -> GHCi ()
468 help _ = io (putStr helpText)
470 info :: String -> GHCi ()
471 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
474 init_cms <- getCmState
476 infoThings cms [] = return cms
477 infoThings cms (name:names) = do
478 stuff <- io (cmInfoThing cms name)
479 io (putStrLn (showSDocForUser unqual (
480 vcat (intersperse (text "") (map showThing stuff))))
484 unqual = cmGetPrintUnqual init_cms
486 showThing (decl, fixity)
487 = vcat [ text "-- " <> showTyThing decl,
488 showFixity fixity (ifName decl),
492 | fix == defaultFixity = empty
493 | otherwise = ppr fix <+>
496 else char '`' <> ppr name <> char '`')
498 showTyThing decl = ppr decl
501 showTyThing (AClass cl)
502 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
503 showTyThing (ADataCon dc)
504 = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
505 showTyThing (ATyCon ty)
507 = hcat [ppr ty, text " is a primitive type constructor"]
509 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
510 showTyThing (AnId id)
511 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
514 = case globalIdDetails id of
515 RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
516 ClassOpId cls -> text "method in class" <+> ppr cls
517 otherwise -> text "variable"
519 -- also print out the source location for home things
521 | isHomePackageName name && isGoodSrcLoc loc
522 = hsep [ text ", defined at", ppr loc ]
525 where loc = nameSrcLoc name
528 infoThings init_cms names
531 addModule :: [FilePath] -> GHCi ()
533 state <- getGHCiState
534 io (revertCAFs) -- always revert CAFs on load/add.
535 files <- mapM expandPath files
536 let new_targets = files ++ targets state
537 graph <- io (cmDepAnal (cmstate state) new_targets)
538 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
539 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
540 setContextAfterLoad mods
541 dflags <- io getDynFlags
542 modulesLoadedMsg ok mods dflags
544 changeDirectory :: String -> GHCi ()
545 changeDirectory dir = do
546 state <- getGHCiState
547 when (targets state /= []) $
548 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\
549 \because the search path has changed.\n"
550 cmstate1 <- io (cmUnload (cmstate state))
551 setGHCiState state{ cmstate = cmstate1, targets = [] }
552 setContextAfterLoad []
553 dir <- expandPath dir
554 io (setCurrentDirectory dir)
556 defineMacro :: String -> GHCi ()
558 let (macro_name, definition) = break isSpace s
559 cmds <- io (readIORef commands)
561 then throwDyn (CmdLineError "invalid macro name")
563 if (macro_name `elem` map fst cmds)
564 then throwDyn (CmdLineError
565 ("command `" ++ macro_name ++ "' is already defined"))
568 -- give the expression a type signature, so we can be sure we're getting
569 -- something of the right type.
570 let new_expr = '(' : definition ++ ") :: String -> IO String"
572 -- compile the expression
574 maybe_hv <- io (cmCompileExpr cms new_expr)
577 Just hv -> io (writeIORef commands --
578 ((macro_name, keepGoing (runMacro hv)) : cmds))
580 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
582 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
583 stringLoop (lines str)
585 undefineMacro :: String -> GHCi ()
586 undefineMacro macro_name = do
587 cmds <- io (readIORef commands)
588 if (macro_name `elem` map fst builtin_commands)
589 then throwDyn (CmdLineError
590 ("command `" ++ macro_name ++ "' cannot be undefined"))
592 if (macro_name `notElem` map fst cmds)
593 then throwDyn (CmdLineError
594 ("command `" ++ macro_name ++ "' not defined"))
596 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
599 loadModule :: [FilePath] -> GHCi ()
600 loadModule fs = timeIt (loadModule' fs)
602 loadModule' :: [FilePath] -> GHCi ()
603 loadModule' files = do
604 state <- getGHCiState
607 files <- mapM expandPath files
609 -- do the dependency anal first, so that if it fails we don't throw
610 -- away the current set of modules.
611 graph <- io (cmDepAnal (cmstate state) files)
613 -- Dependency anal ok, now unload everything
614 cmstate1 <- io (cmUnload (cmstate state))
615 setGHCiState state{ cmstate = cmstate1, targets = [] }
617 io (revertCAFs) -- always revert CAFs on load.
618 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
619 setGHCiState state{ cmstate = cmstate2, targets = files }
621 setContextAfterLoad mods
622 dflags <- io (getDynFlags)
623 modulesLoadedMsg ok mods dflags
626 reloadModule :: String -> GHCi ()
628 state <- getGHCiState
629 case targets state of
630 [] -> io (putStr "no current target\n")
632 -- do the dependency anal first, so that if it fails we don't throw
633 -- away the current set of modules.
634 graph <- io (cmDepAnal (cmstate state) paths)
636 io (revertCAFs) -- always revert CAFs on reload.
638 <- io (cmLoadModules (cmstate state) graph)
639 setGHCiState state{ cmstate=cmstate1 }
640 setContextAfterLoad mods
641 dflags <- io getDynFlags
642 modulesLoadedMsg ok mods dflags
644 reloadModule _ = noArgs ":reload"
646 setContextAfterLoad [] = setContext prel
647 setContextAfterLoad (m:_) = do
648 cmstate <- getCmState
649 b <- io (cmModuleIsInterpreted cmstate m)
650 if b then setContext ('*':m) else setContext m
652 modulesLoadedMsg ok mods dflags =
653 when (verbosity dflags > 0) $ do
655 | null mods = text "none."
657 punctuate comma (map text mods)) <> text "."
660 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
662 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
665 typeOfExpr :: String -> GHCi ()
667 = do cms <- getCmState
668 maybe_tystr <- io (cmTypeOfExpr cms str)
671 Just tystr -> io (putStrLn tystr)
673 kindOfType :: String -> GHCi ()
675 = do cms <- getCmState
676 maybe_tystr <- io (cmKindOfType cms str)
679 Just tystr -> io (putStrLn tystr)
681 quit :: String -> GHCi Bool
684 shellEscape :: String -> GHCi Bool
685 shellEscape str = io (system str >> return False)
687 -----------------------------------------------------------------------------
688 -- Browsing a module's contents
690 browseCmd :: String -> GHCi ()
693 ['*':m] | looksLikeModuleName m -> browseModule m False
694 [m] | looksLikeModuleName m -> browseModule m True
695 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
697 browseModule m exports_only = do
700 is_interpreted <- io (cmModuleIsInterpreted cms m)
701 when (not is_interpreted && not exports_only) $
702 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
704 -- Temporarily set the context to the module we're interested in,
705 -- just so we can get an appropriate PrintUnqualified
706 (as,bs) <- io (cmGetContext cms)
707 cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
708 else cmSetContext cms [m] [])
709 cms2 <- io (cmSetContext cms1 as bs)
711 things <- io (cmBrowseModule cms2 m exports_only)
713 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
715 io (putStrLn (showSDocForUser unqual (
716 vcat (map ppr things)
719 -----------------------------------------------------------------------------
720 -- Setting the module context
723 | all sensible mods = fn mods
724 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
726 (fn, mods) = case str of
727 '+':stuff -> (addToContext, words stuff)
728 '-':stuff -> (removeFromContext, words stuff)
729 stuff -> (newContext, words stuff)
731 sensible ('*':m) = looksLikeModuleName m
732 sensible m = looksLikeModuleName m
736 (as,bs) <- separate cms mods [] []
737 let bs' = if null as && prel `notElem` bs then prel:bs else bs
738 cms' <- io (cmSetContext cms as bs')
741 separate cmstate [] as bs = return (as,bs)
742 separate cmstate (('*':m):ms) as bs = do
743 b <- io (cmModuleIsInterpreted cmstate m)
744 if b then separate cmstate ms (m:as) bs
745 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
746 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
751 addToContext mods = do
753 (as,bs) <- io (cmGetContext cms)
755 (as',bs') <- separate cms mods [] []
757 let as_to_add = as' \\ (as ++ bs)
758 bs_to_add = bs' \\ (as ++ bs)
760 cms' <- io (cmSetContext cms
761 (as ++ as_to_add) (bs ++ bs_to_add))
765 removeFromContext mods = do
767 (as,bs) <- io (cmGetContext cms)
769 (as_to_remove,bs_to_remove) <- separate cms mods [] []
771 let as' = as \\ (as_to_remove ++ bs_to_remove)
772 bs' = bs \\ (as_to_remove ++ bs_to_remove)
774 cms' <- io (cmSetContext cms as' bs')
777 ----------------------------------------------------------------------------
780 -- set options in the interpreter. Syntax is exactly the same as the
781 -- ghc command line, except that certain options aren't available (-C,
784 -- This is pretty fragile: most options won't work as expected. ToDo:
785 -- figure out which ones & disallow them.
787 setCmd :: String -> GHCi ()
789 = do st <- getGHCiState
790 let opts = options st
791 io $ putStrLn (showSDoc (
792 text "options currently set: " <>
795 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
799 ("args":args) -> setArgs args
800 ("prog":prog) -> setProg prog
801 wds -> setOptions wds
805 setGHCiState st{ args = args }
809 setGHCiState st{ progname = prog }
811 io (hPutStrLn stderr "syntax: :set prog <progname>")
814 do -- first, deal with the GHCi opts (+s, +t, etc.)
815 let (plus_opts, minus_opts) = partition isPlus wds
816 mapM_ setOpt plus_opts
818 -- now, the GHC flags
819 pkgs_before <- io (readIORef v_ExplicitPackages)
820 leftovers <- io (processArgs static_flags minus_opts [])
821 pkgs_after <- io (readIORef v_ExplicitPackages)
823 -- update things if the users wants more packages
824 let new_packages = pkgs_after \\ pkgs_before
825 when (not (null new_packages)) $
826 newPackages new_packages
828 -- don't forget about the extra command-line flags from the
829 -- extra_ghc_opts fields in the new packages
830 new_package_details <- io (getPackageDetails new_packages)
831 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
832 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
834 -- then, dynamic flags
837 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
840 if (not (null leftovers))
841 then throwDyn (CmdLineError ("unrecognised flags: " ++
846 unsetOptions :: String -> GHCi ()
848 = do -- first, deal with the GHCi opts (+s, +t, etc.)
850 (minus_opts, rest1) = partition isMinus opts
851 (plus_opts, rest2) = partition isPlus rest1
853 if (not (null rest2))
854 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
857 mapM_ unsetOpt plus_opts
859 -- can't do GHC flags for now
860 if (not (null minus_opts))
861 then throwDyn (CmdLineError "can't unset GHC command-line flags")
864 isMinus ('-':s) = True
867 isPlus ('+':s) = True
871 = case strToGHCiOpt str of
872 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
873 Just o -> setOption o
876 = case strToGHCiOpt str of
877 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
878 Just o -> unsetOption o
880 strToGHCiOpt :: String -> (Maybe GHCiOption)
881 strToGHCiOpt "s" = Just ShowTiming
882 strToGHCiOpt "t" = Just ShowType
883 strToGHCiOpt "r" = Just RevertCAFs
884 strToGHCiOpt _ = Nothing
886 optToStr :: GHCiOption -> String
887 optToStr ShowTiming = "s"
888 optToStr ShowType = "t"
889 optToStr RevertCAFs = "r"
891 newPackages new_pkgs = do -- The new packages are already in v_Packages
892 state <- getGHCiState
893 cmstate1 <- io (cmUnload (cmstate state))
894 setGHCiState state{ cmstate = cmstate1, targets = [] }
895 dflags <- io getDynFlags
896 io (linkPackages dflags new_pkgs)
897 setContextAfterLoad []
899 -- ---------------------------------------------------------------------------
904 ["modules" ] -> showModules
905 ["bindings"] -> showBindings
906 ["linker"] -> io showLinkerState
907 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
911 let (mg, hpt) = cmGetModInfo cms
912 mapM_ (showModule hpt) mg
915 showModule :: HomePackageTable -> ModSummary -> GHCi ()
916 showModule hpt mod_summary
917 = case lookupModuleEnv hpt mod of
918 Nothing -> panic "missing linkable"
919 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
921 obj_linkable = isObjectLinkable (hm_linkable mod_info)
923 mod = ms_mod mod_summary
924 locn = ms_location mod_summary
929 unqual = cmGetPrintUnqual cms
930 -- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
931 showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
933 io (mapM_ showBinding (cmGetBindings cms))
937 -----------------------------------------------------------------------------
940 data GHCiState = GHCiState
944 targets :: [FilePath],
946 options :: [GHCiOption]
950 = ShowTiming -- show time/allocs after evaluation
951 | ShowType -- show the type of expressions
952 | RevertCAFs -- revert CAFs after every evaluation
955 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
957 startGHCi :: GHCi a -> GHCiState -> IO a
958 startGHCi g state = do ref <- newIORef state; unGHCi g ref
960 instance Monad GHCi where
961 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
962 return a = GHCi $ \s -> return a
964 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
965 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
966 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
968 getGHCiState = GHCi $ \r -> readIORef r
969 setGHCiState s = GHCi $ \r -> writeIORef r s
971 -- for convenience...
972 getCmState = getGHCiState >>= return . cmstate
973 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
975 isOptionSet :: GHCiOption -> GHCi Bool
977 = do st <- getGHCiState
978 return (opt `elem` options st)
980 setOption :: GHCiOption -> GHCi ()
982 = do st <- getGHCiState
983 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
985 unsetOption :: GHCiOption -> GHCi ()
987 = do st <- getGHCiState
988 setGHCiState (st{ options = filter (/= opt) (options st) })
991 io m = GHCi { unGHCi = \s -> m >>= return }
993 -----------------------------------------------------------------------------
994 -- recursive exception handlers
996 -- Don't forget to unblock async exceptions in the handler, or if we're
997 -- in an exception loop (eg. let a = error a in a) the ^C exception
998 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1000 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1001 ghciHandle h (GHCi m) = GHCi $ \s ->
1002 Exception.catch (m s)
1003 (\e -> unGHCi (ghciUnblock (h e)) s)
1005 ghciUnblock :: GHCi a -> GHCi a
1006 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1008 -----------------------------------------------------------------------------
1009 -- timing & statistics
1011 timeIt :: GHCi a -> GHCi a
1013 = do b <- isOptionSet ShowTiming
1016 else do allocs1 <- io $ getAllocations
1017 time1 <- io $ getCPUTime
1019 allocs2 <- io $ getAllocations
1020 time2 <- io $ getCPUTime
1021 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1024 foreign import ccall "getAllocations" getAllocations :: IO Int
1026 printTimes :: Int -> Integer -> IO ()
1027 printTimes allocs psecs
1028 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1029 secs_str = showFFloat (Just 2) secs
1030 putStrLn (showSDoc (
1031 parens (text (secs_str "") <+> text "secs" <> comma <+>
1032 int allocs <+> text "bytes")))
1034 -----------------------------------------------------------------------------
1041 -- Have to turn off buffering again, because we just
1042 -- reverted stdout, stderr & stdin to their defaults.
1044 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1045 -- Make it "safe", just in case
1047 -- -----------------------------------------------------------------------------
1050 expandPath :: String -> GHCi String
1052 case dropWhile isSpace path of
1054 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1055 return (tilde ++ '/':d)