1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.162 2003/12/10 14:15:21 simonmar 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 ("unset", keepGoing unsetOptions),
101 ("undef", keepGoing undefineMacro),
105 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
106 keepGoing a str = a str >> return False
108 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
109 keepGoingPaths a str = a (toArgs str) >> return False
111 shortHelpText = "use :? for help.\n"
113 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
115 \ Commands available from the prompt:\n\
117 \ <stmt> evaluate/run <stmt>\n\
118 \ :add <filename> ... add module(s) to the current target set\n\
119 \ :browse [*]<module> display the names defined by <module>\n\
120 \ :cd <dir> change directory to <dir>\n\
121 \ :def <cmd> <expr> define a command :<cmd>\n\
122 \ :help, :? display this list of commands\n\
123 \ :info [<name> ...] display information about the given names\n\
124 \ :load <filename> ... load module(s) and their dependents\n\
125 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
126 \ :reload reload the current module set\n\
128 \ :set <option> ... set options\n\
129 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
130 \ :set prog <progname> set the value returned by System.getProgName\n\
132 \ :show modules show the currently loaded modules\n\
133 \ :show bindings show the current bindings made at the prompt\n\
135 \ :type <expr> show the type of <expr>\n\
136 \ :undef <cmd> undefine user-defined command :<cmd>\n\
137 \ :unset <option> ... unset options\n\
139 \ :!<command> run the shell command <command>\n\
141 \ Options for `:set' and `:unset':\n\
143 \ +r revert top-level expressions after each evaluation\n\
144 \ +s print timing/memory stats after each evaluation\n\
145 \ +t print type after evaluation\n\
146 \ -<flags> most GHC command line flags can also be set here\n\
147 \ (eg. -v2, -fglasgow-exts, etc.)\n\
150 interactiveUI :: [FilePath] -> Maybe String -> IO ()
151 interactiveUI srcs maybe_expr = do
152 dflags <- getDynFlags
154 cmstate <- cmInit Interactive dflags;
157 hSetBuffering stdout NoBuffering
159 -- Initialise buffering for the *interpreted* I/O system
160 initInterpBuffering cmstate
162 -- We don't want the cmd line to buffer any input that might be
163 -- intended for the program, so unbuffer stdin.
164 hSetBuffering stdin NoBuffering
166 -- initial context is just the Prelude
167 cmstate <- cmSetContext cmstate [] ["Prelude"]
169 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
173 startGHCi (runGHCi srcs dflags maybe_expr)
174 GHCiState{ progname = "<interactive>",
180 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
181 Readline.resetTerminal Nothing
186 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
187 runGHCi paths dflags maybe_expr = do
188 read_dot_files <- io (readIORef v_Read_DotGHCi)
190 when (read_dot_files) $ do
193 exists <- io (doesFileExist file)
195 dir_ok <- io (checkPerms ".")
196 file_ok <- io (checkPerms file)
197 when (dir_ok && file_ok) $ do
198 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
201 Right hdl -> fileLoop hdl False
203 when (read_dot_files) $ do
204 -- Read in $HOME/.ghci
205 either_dir <- io (IO.try (getEnv "HOME"))
209 cwd <- io (getCurrentDirectory)
210 when (dir /= cwd) $ do
211 let file = dir ++ "/.ghci"
212 ok <- io (checkPerms file)
214 either_hdl <- io (IO.try (openFile file ReadMode))
217 Right hdl -> fileLoop hdl False
219 -- Perform a :load for files given on the GHCi command line
220 when (not (null paths)) $
221 ghciHandle showException $
224 -- if verbosity is greater than 0, or we are connected to a
225 -- terminal, display the prompt in the interactive loop.
226 is_tty <- io (hIsTerminalDevice stdin)
227 let show_prompt = verbosity dflags > 0 || is_tty
231 -- enter the interactive loop
232 interactiveLoop is_tty show_prompt
234 -- just evaluate the expression we were given
239 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
242 interactiveLoop is_tty show_prompt = do
243 -- Ignore ^C exceptions caught here
244 ghciHandleDyn (\e -> case e of
245 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
246 _other -> return ()) $ do
248 -- read commands from stdin
249 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
252 else fileLoop stdin show_prompt
254 fileLoop stdin show_prompt
258 -- NOTE: We only read .ghci files if they are owned by the current user,
259 -- and aren't world writable. Otherwise, we could be accidentally
260 -- running code planted by a malicious third party.
262 -- Furthermore, We only read ./.ghci if . is owned by the current user
263 -- and isn't writable by anyone else. I think this is sufficient: we
264 -- don't need to check .. and ../.. etc. because "." always refers to
265 -- the same directory while a process is running.
267 checkPerms :: String -> IO Bool
269 #ifdef mingw32_HOST_OS
272 DriverUtil.handle (\_ -> return False) $ do
273 st <- getFileStatus name
275 if fileOwner st /= me then do
276 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
279 let mode = fileMode st
280 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
281 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
283 putStrLn $ "*** WARNING: " ++ name ++
284 " is writable by someone else, IGNORING!"
289 fileLoop :: Handle -> Bool -> GHCi ()
290 fileLoop hdl prompt = do
291 cmstate <- getCmState
292 (mod,imports) <- io (cmGetContext cmstate)
293 when prompt (io (putStr (mkPrompt mod imports)))
294 l <- io (IO.try (hGetLine hdl))
296 Left e | isEOFError e -> return ()
297 | otherwise -> io (ioError e)
299 case remove_spaces l of
300 "" -> fileLoop hdl prompt
301 l -> do quit <- runCommand l
302 if quit then return () else fileLoop hdl prompt
304 stringLoop :: [String] -> GHCi ()
305 stringLoop [] = return ()
306 stringLoop (s:ss) = do
307 case remove_spaces s of
309 l -> do quit <- runCommand l
310 if quit then return () else stringLoop ss
312 mkPrompt toplevs exports
313 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
315 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
316 readlineLoop :: GHCi ()
318 cmstate <- getCmState
319 (mod,imports) <- io (cmGetContext cmstate)
321 l <- io (readline (mkPrompt mod imports)
322 `finally` setNonBlockingFD 0)
323 -- readline sometimes puts stdin into blocking mode,
324 -- so we need to put it back for the IO library
328 case remove_spaces l of
333 if quit then return () else readlineLoop
336 runCommand :: String -> GHCi Bool
337 runCommand c = ghciHandle handler (doCommand c)
339 -- This is the exception handler for exceptions generated by the
340 -- user's code; it normally just prints out the exception. The
341 -- handler must be recursive, in case showing the exception causes
342 -- more exceptions to be raised.
344 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
345 -- raising another exception. We therefore don't put the recursive
346 -- handler arond the flushing operation, so if stderr is closed
347 -- GHCi will just die gracefully rather than going into an infinite loop.
348 handler :: Exception -> GHCi Bool
349 handler exception = do
351 io installSignalHandlers
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 cm_state' = cmSetDFlags (cmstate st)
377 (dopt_unset dflags Opt_WarnUnusedBinds)
378 (new_cmstate, result) <-
379 io $ withProgName (progname st) $ withArgs (args st) $
380 cmRunStmt cm_state' stmt
381 setGHCiState st{cmstate = new_cmstate}
383 CmRunFailed -> return []
384 CmRunException e -> showException e >> return []
385 CmRunOk names -> return names
387 -- possibly print the type and revert CAFs after evaluating an expression
389 = do b <- isOptionSet ShowType
390 cmstate <- getCmState
391 when b (mapM_ (showTypeOfName cmstate) names)
394 io installSignalHandlers
395 b <- isOptionSet RevertCAFs
396 io (when b revertCAFs)
399 showTypeOfName :: CmState -> Name -> GHCi ()
400 showTypeOfName cmstate n
401 = do maybe_str <- io (cmTypeOfName cmstate n)
404 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
406 specialCommand :: String -> GHCi Bool
407 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
408 specialCommand str = do
409 let (cmd,rest) = break isSpace str
410 cmds <- io (readIORef commands)
411 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
412 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
413 ++ shortHelpText) >> return False)
414 [(_,f)] -> f (dropWhile isSpace rest)
415 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
416 " matches multiple commands (" ++
417 foldr1 (\a b -> a ++ ',':b) (map fst cs)
418 ++ ")") >> return False)
420 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
423 -----------------------------------------------------------------------------
424 -- To flush buffers for the *interpreted* computation we need
425 -- to refer to *its* stdout/stderr handles
427 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
428 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
430 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
431 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
432 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
434 initInterpBuffering :: CmState -> IO ()
435 initInterpBuffering cmstate
436 = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
439 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
440 other -> panic "interactiveUI:setBuffering"
442 maybe_hval <- cmCompileExpr cmstate flush_cmd
444 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
445 _ -> panic "interactiveUI:flush"
447 turnOffBuffering -- Turn it off right now
452 flushInterpBuffers :: GHCi ()
454 = io $ do Monad.join (readIORef flush_interp)
457 turnOffBuffering :: IO ()
459 = do Monad.join (readIORef turn_off_buffering)
462 -----------------------------------------------------------------------------
465 help :: String -> GHCi ()
466 help _ = io (putStr helpText)
468 info :: String -> GHCi ()
469 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
472 init_cms <- getCmState
474 infoThings cms [] = return cms
475 infoThings cms (name:names) = do
476 stuff <- io (cmInfoThing cms name)
477 io (putStrLn (showSDocForUser unqual (
478 vcat (intersperse (text "") (map showThing stuff))))
482 unqual = cmGetPrintUnqual init_cms
484 showThing (decl, fixity)
485 = vcat [ text "-- " <> showTyThing decl,
486 showFixity fixity (ifName decl),
490 | fix == defaultFixity = empty
491 | otherwise = ppr fix <+>
494 else char '`' <> ppr name <> char '`')
496 showTyThing decl = ppr decl
499 showTyThing (AClass cl)
500 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
501 showTyThing (ADataCon dc)
502 = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
503 showTyThing (ATyCon ty)
505 = hcat [ppr ty, text " is a primitive type constructor"]
507 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
508 showTyThing (AnId id)
509 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
512 = case globalIdDetails id of
513 RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
514 ClassOpId cls -> text "method in class" <+> ppr cls
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
526 infoThings init_cms names
529 addModule :: [FilePath] -> GHCi ()
531 state <- getGHCiState
532 io (revertCAFs) -- always revert CAFs on load/add.
533 files <- mapM expandPath files
534 let new_targets = files ++ targets state
535 graph <- io (cmDepAnal (cmstate state) new_targets)
536 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
537 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
538 setContextAfterLoad mods
539 dflags <- io getDynFlags
540 modulesLoadedMsg ok mods dflags
542 changeDirectory :: String -> GHCi ()
543 changeDirectory dir = do
544 state <- getGHCiState
545 when (targets state /= []) $
546 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\
547 \because the search path has changed.\n"
548 cmstate1 <- io (cmUnload (cmstate state))
549 setGHCiState state{ cmstate = cmstate1, targets = [] }
550 setContextAfterLoad []
551 dir <- expandPath dir
552 io (setCurrentDirectory dir)
554 defineMacro :: String -> GHCi ()
556 let (macro_name, definition) = break isSpace s
557 cmds <- io (readIORef commands)
559 then throwDyn (CmdLineError "invalid macro name")
561 if (macro_name `elem` map fst cmds)
562 then throwDyn (CmdLineError
563 ("command `" ++ macro_name ++ "' is already defined"))
566 -- give the expression a type signature, so we can be sure we're getting
567 -- something of the right type.
568 let new_expr = '(' : definition ++ ") :: String -> IO String"
570 -- compile the expression
572 maybe_hv <- io (cmCompileExpr cms new_expr)
575 Just hv -> io (writeIORef commands --
576 ((macro_name, keepGoing (runMacro hv)) : cmds))
578 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
580 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
581 stringLoop (lines str)
583 undefineMacro :: String -> GHCi ()
584 undefineMacro macro_name = do
585 cmds <- io (readIORef commands)
586 if (macro_name `elem` map fst builtin_commands)
587 then throwDyn (CmdLineError
588 ("command `" ++ macro_name ++ "' cannot be undefined"))
590 if (macro_name `notElem` map fst cmds)
591 then throwDyn (CmdLineError
592 ("command `" ++ macro_name ++ "' not defined"))
594 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
597 loadModule :: [FilePath] -> GHCi ()
598 loadModule fs = timeIt (loadModule' fs)
600 loadModule' :: [FilePath] -> GHCi ()
601 loadModule' files = do
602 state <- getGHCiState
605 files <- mapM expandPath files
607 -- do the dependency anal first, so that if it fails we don't throw
608 -- away the current set of modules.
609 graph <- io (cmDepAnal (cmstate state) files)
611 -- Dependency anal ok, now unload everything
612 cmstate1 <- io (cmUnload (cmstate state))
613 setGHCiState state{ cmstate = cmstate1, targets = [] }
615 io (revertCAFs) -- always revert CAFs on load.
616 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
617 setGHCiState state{ cmstate = cmstate2, targets = files }
619 setContextAfterLoad mods
620 dflags <- io (getDynFlags)
621 modulesLoadedMsg ok mods dflags
624 reloadModule :: String -> GHCi ()
626 state <- getGHCiState
627 case targets state of
628 [] -> io (putStr "no current target\n")
630 -- do the dependency anal first, so that if it fails we don't throw
631 -- away the current set of modules.
632 graph <- io (cmDepAnal (cmstate state) paths)
634 io (revertCAFs) -- always revert CAFs on reload.
636 <- io (cmLoadModules (cmstate state) graph)
637 setGHCiState state{ cmstate=cmstate1 }
638 setContextAfterLoad mods
639 dflags <- io getDynFlags
640 modulesLoadedMsg ok mods dflags
642 reloadModule _ = noArgs ":reload"
644 setContextAfterLoad [] = setContext prel
645 setContextAfterLoad (m:_) = do
646 cmstate <- getCmState
647 b <- io (cmModuleIsInterpreted cmstate m)
648 if b then setContext ('*':m) else setContext m
650 modulesLoadedMsg ok mods dflags =
651 when (verbosity dflags > 0) $ do
653 | null mods = text "none."
655 punctuate comma (map text mods)) <> text "."
658 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
660 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
663 typeOfExpr :: String -> GHCi ()
665 = do cms <- getCmState
666 maybe_tystr <- io (cmTypeOfExpr cms str)
669 Just tystr -> io (putStrLn tystr)
671 quit :: String -> GHCi Bool
674 shellEscape :: String -> GHCi Bool
675 shellEscape str = io (system str >> return False)
677 -----------------------------------------------------------------------------
678 -- Browing a module's contents
680 browseCmd :: String -> GHCi ()
683 ['*':m] | looksLikeModuleName m -> browseModule m False
684 [m] | looksLikeModuleName m -> browseModule m True
685 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
687 browseModule m exports_only = do
690 is_interpreted <- io (cmModuleIsInterpreted cms m)
691 when (not is_interpreted && not exports_only) $
692 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
694 -- Temporarily set the context to the module we're interested in,
695 -- just so we can get an appropriate PrintUnqualified
696 (as,bs) <- io (cmGetContext cms)
697 cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
698 else cmSetContext cms [m] [])
699 cms2 <- io (cmSetContext cms1 as bs)
701 things <- io (cmBrowseModule cms2 m exports_only)
703 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
705 io (putStrLn (showSDocForUser unqual (
706 vcat (map ppr things)
709 -----------------------------------------------------------------------------
710 -- Setting the module context
713 | all sensible mods = fn mods
714 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
716 (fn, mods) = case str of
717 '+':stuff -> (addToContext, words stuff)
718 '-':stuff -> (removeFromContext, words stuff)
719 stuff -> (newContext, words stuff)
721 sensible ('*':m) = looksLikeModuleName m
722 sensible m = looksLikeModuleName m
726 (as,bs) <- separate cms mods [] []
727 let bs' = if null as && prel `notElem` bs then prel:bs else bs
728 cms' <- io (cmSetContext cms as bs')
731 separate cmstate [] as bs = return (as,bs)
732 separate cmstate (('*':m):ms) as bs = do
733 b <- io (cmModuleIsInterpreted cmstate m)
734 if b then separate cmstate ms (m:as) bs
735 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
736 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
741 addToContext mods = do
743 (as,bs) <- io (cmGetContext cms)
745 (as',bs') <- separate cms mods [] []
747 let as_to_add = as' \\ (as ++ bs)
748 bs_to_add = bs' \\ (as ++ bs)
750 cms' <- io (cmSetContext cms
751 (as ++ as_to_add) (bs ++ bs_to_add))
755 removeFromContext mods = do
757 (as,bs) <- io (cmGetContext cms)
759 (as_to_remove,bs_to_remove) <- separate cms mods [] []
761 let as' = as \\ (as_to_remove ++ bs_to_remove)
762 bs' = bs \\ (as_to_remove ++ bs_to_remove)
764 cms' <- io (cmSetContext cms as' bs')
767 ----------------------------------------------------------------------------
770 -- set options in the interpreter. Syntax is exactly the same as the
771 -- ghc command line, except that certain options aren't available (-C,
774 -- This is pretty fragile: most options won't work as expected. ToDo:
775 -- figure out which ones & disallow them.
777 setCmd :: String -> GHCi ()
779 = do st <- getGHCiState
780 let opts = options st
781 io $ putStrLn (showSDoc (
782 text "options currently set: " <>
785 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
789 ("args":args) -> setArgs args
790 ("prog":prog) -> setProg prog
791 wds -> setOptions wds
795 setGHCiState st{ args = args }
799 setGHCiState st{ progname = prog }
801 io (hPutStrLn stderr "syntax: :set prog <progname>")
804 do -- first, deal with the GHCi opts (+s, +t, etc.)
805 let (plus_opts, minus_opts) = partition isPlus wds
806 mapM_ setOpt plus_opts
808 -- now, the GHC flags
809 pkgs_before <- io (readIORef v_ExplicitPackages)
810 leftovers <- io (processArgs static_flags minus_opts [])
811 pkgs_after <- io (readIORef v_ExplicitPackages)
813 -- update things if the users wants more packages
814 let new_packages = pkgs_after \\ pkgs_before
815 when (not (null new_packages)) $
816 newPackages new_packages
818 -- don't forget about the extra command-line flags from the
819 -- extra_ghc_opts fields in the new packages
820 new_package_details <- io (getPackageDetails new_packages)
821 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
822 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
824 -- then, dynamic flags
827 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
830 if (not (null leftovers))
831 then throwDyn (CmdLineError ("unrecognised flags: " ++
836 unsetOptions :: String -> GHCi ()
838 = do -- first, deal with the GHCi opts (+s, +t, etc.)
840 (minus_opts, rest1) = partition isMinus opts
841 (plus_opts, rest2) = partition isPlus rest1
843 if (not (null rest2))
844 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
847 mapM_ unsetOpt plus_opts
849 -- can't do GHC flags for now
850 if (not (null minus_opts))
851 then throwDyn (CmdLineError "can't unset GHC command-line flags")
854 isMinus ('-':s) = True
857 isPlus ('+':s) = True
861 = case strToGHCiOpt str of
862 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
863 Just o -> setOption o
866 = case strToGHCiOpt str of
867 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
868 Just o -> unsetOption o
870 strToGHCiOpt :: String -> (Maybe GHCiOption)
871 strToGHCiOpt "s" = Just ShowTiming
872 strToGHCiOpt "t" = Just ShowType
873 strToGHCiOpt "r" = Just RevertCAFs
874 strToGHCiOpt _ = Nothing
876 optToStr :: GHCiOption -> String
877 optToStr ShowTiming = "s"
878 optToStr ShowType = "t"
879 optToStr RevertCAFs = "r"
881 newPackages new_pkgs = do -- The new packages are already in v_Packages
882 state <- getGHCiState
883 cmstate1 <- io (cmUnload (cmstate state))
884 setGHCiState state{ cmstate = cmstate1, targets = [] }
885 dflags <- io getDynFlags
886 io (linkPackages dflags new_pkgs)
887 setContextAfterLoad []
889 -- ---------------------------------------------------------------------------
894 ["modules" ] -> showModules
895 ["bindings"] -> showBindings
896 ["linker"] -> io showLinkerState
897 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
901 let (mg, hpt) = cmGetModInfo cms
902 mapM_ (showModule hpt) mg
905 showModule :: HomePackageTable -> ModSummary -> GHCi ()
906 showModule hpt mod_summary
907 = case lookupModuleEnv hpt mod of
908 Nothing -> panic "missing linkable"
909 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
911 obj_linkable = isObjectLinkable (hm_linkable mod_info)
913 mod = ms_mod mod_summary
914 locn = ms_location mod_summary
919 unqual = cmGetPrintUnqual cms
920 -- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
921 showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
923 io (mapM_ showBinding (cmGetBindings cms))
927 -----------------------------------------------------------------------------
930 data GHCiState = GHCiState
934 targets :: [FilePath],
936 options :: [GHCiOption]
940 = ShowTiming -- show time/allocs after evaluation
941 | ShowType -- show the type of expressions
942 | RevertCAFs -- revert CAFs after every evaluation
945 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
947 startGHCi :: GHCi a -> GHCiState -> IO a
948 startGHCi g state = do ref <- newIORef state; unGHCi g ref
950 instance Monad GHCi where
951 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
952 return a = GHCi $ \s -> return a
954 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
955 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
956 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
958 getGHCiState = GHCi $ \r -> readIORef r
959 setGHCiState s = GHCi $ \r -> writeIORef r s
961 -- for convenience...
962 getCmState = getGHCiState >>= return . cmstate
963 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
965 isOptionSet :: GHCiOption -> GHCi Bool
967 = do st <- getGHCiState
968 return (opt `elem` options st)
970 setOption :: GHCiOption -> GHCi ()
972 = do st <- getGHCiState
973 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
975 unsetOption :: GHCiOption -> GHCi ()
977 = do st <- getGHCiState
978 setGHCiState (st{ options = filter (/= opt) (options st) })
981 io m = GHCi { unGHCi = \s -> m >>= return }
983 -----------------------------------------------------------------------------
984 -- recursive exception handlers
986 -- Don't forget to unblock async exceptions in the handler, or if we're
987 -- in an exception loop (eg. let a = error a in a) the ^C exception
988 -- may never be delivered. Thanks to Marcin for pointing out the bug.
990 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
991 ghciHandle h (GHCi m) = GHCi $ \s ->
992 Exception.catch (m s)
993 (\e -> unGHCi (ghciUnblock (h e)) s)
995 ghciUnblock :: GHCi a -> GHCi a
996 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
998 -----------------------------------------------------------------------------
999 -- timing & statistics
1001 timeIt :: GHCi a -> GHCi a
1003 = do b <- isOptionSet ShowTiming
1006 else do allocs1 <- io $ getAllocations
1007 time1 <- io $ getCPUTime
1009 allocs2 <- io $ getAllocations
1010 time2 <- io $ getCPUTime
1011 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1014 foreign import ccall "getAllocations" getAllocations :: IO Int
1016 printTimes :: Int -> Integer -> IO ()
1017 printTimes allocs psecs
1018 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1019 secs_str = showFFloat (Just 2) secs
1020 putStrLn (showSDoc (
1021 parens (text (secs_str "") <+> text "secs" <> comma <+>
1022 int allocs <+> text "bytes")))
1024 -----------------------------------------------------------------------------
1031 -- Have to turn off buffering again, because we just
1032 -- reverted stdout, stderr & stdin to their defaults.
1034 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1035 -- Make it "safe", just in case
1037 -- -----------------------------------------------------------------------------
1040 expandPath :: String -> GHCi String
1042 case dropWhile isSpace path of
1044 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1045 return (tilde ++ '/':d)