1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.161 2003/10/09 11:58:53 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 HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
22 import IfaceSyn ( IfaceDecl( ifName ) )
25 import DriverUtil ( remove_spaces )
26 import Linker ( showLinkerState, linkPackages )
28 import IdInfo ( GlobalIdDetails(..) )
29 import Id ( isImplicitId, idName, globalIdDetails )
30 import Class ( className )
31 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
32 import DataCon ( dataConName )
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 hiding ( showException )
47 #ifndef mingw32_HOST_OS
48 import DriverUtil( handle )
50 #if __GLASGOW_HASKELL__ > 504
55 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
56 import Control.Concurrent ( yield ) -- Used in readline loop
57 import System.Console.Readline as Readline
62 import Control.Exception as Exception
64 import Control.Concurrent
70 import System.Environment
71 import System.Directory
72 import System.IO as IO
74 import Control.Monad as Monad
76 import GHC.Exts ( unsafeCoerce# )
78 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
80 import System.Posix.Internals ( setNonBlockingFD )
82 -----------------------------------------------------------------------------
86 \ / _ \\ /\\ /\\/ __(_)\n\
87 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
88 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
89 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
91 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
93 builtin_commands :: [(String, String -> GHCi Bool)]
95 ("add", keepGoingPaths addModule),
96 ("browse", keepGoing browseCmd),
97 ("cd", keepGoing changeDirectory),
98 ("def", keepGoing defineMacro),
99 ("help", keepGoing help),
100 ("?", keepGoing help),
101 ("info", keepGoing info),
102 ("load", keepGoingPaths loadModule),
103 ("module", keepGoing setContext),
104 ("reload", keepGoing reloadModule),
105 ("set", keepGoing setCmd),
106 ("show", keepGoing showCmd),
107 ("type", keepGoing typeOfExpr),
108 ("unset", keepGoing unsetOptions),
109 ("undef", keepGoing undefineMacro),
113 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
114 keepGoing a str = a str >> return False
116 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
117 keepGoingPaths a str = a (toArgs str) >> return False
119 shortHelpText = "use :? for help.\n"
121 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
123 \ Commands available from the prompt:\n\
125 \ <stmt> evaluate/run <stmt>\n\
126 \ :add <filename> ... add module(s) to the current target set\n\
127 \ :browse [*]<module> display the names defined by <module>\n\
128 \ :cd <dir> change directory to <dir>\n\
129 \ :def <cmd> <expr> define a command :<cmd>\n\
130 \ :help, :? display this list of commands\n\
131 \ :info [<name> ...] display information about the given names\n\
132 \ :load <filename> ... load module(s) and their dependents\n\
133 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
134 \ :reload reload the current module set\n\
136 \ :set <option> ... set options\n\
137 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
138 \ :set prog <progname> set the value returned by System.getProgName\n\
140 \ :show modules show the currently loaded modules\n\
141 \ :show bindings show the current bindings made at the prompt\n\
143 \ :type <expr> show the type of <expr>\n\
144 \ :undef <cmd> undefine user-defined command :<cmd>\n\
145 \ :unset <option> ... unset options\n\
147 \ :!<command> run the shell command <command>\n\
149 \ Options for `:set' and `:unset':\n\
151 \ +r revert top-level expressions after each evaluation\n\
152 \ +s print timing/memory stats after each evaluation\n\
153 \ +t print type after evaluation\n\
154 \ -<flags> most GHC command line flags can also be set here\n\
155 \ (eg. -v2, -fglasgow-exts, etc.)\n\
158 interactiveUI :: [FilePath] -> Maybe String -> IO ()
159 interactiveUI srcs maybe_expr = do
160 dflags <- getDynFlags
162 cmstate <- cmInit Interactive dflags;
165 hSetBuffering stdout NoBuffering
167 -- Initialise buffering for the *interpreted* I/O system
168 initInterpBuffering cmstate
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 [] ["Prelude"]
177 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
181 startGHCi (runGHCi srcs dflags maybe_expr)
182 GHCiState{ progname = "<interactive>",
188 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
189 Readline.resetTerminal Nothing
194 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
195 runGHCi paths dflags maybe_expr = 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 $
232 -- if verbosity is greater than 0, or we are connected to a
233 -- terminal, display the prompt in the interactive loop.
234 is_tty <- io (hIsTerminalDevice stdin)
235 let show_prompt = verbosity dflags > 0 || is_tty
239 -- enter the interactive loop
240 interactiveLoop is_tty show_prompt
242 -- just evaluate the expression we were given
247 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
250 interactiveLoop is_tty show_prompt = do
251 -- Ignore ^C exceptions caught here
252 ghciHandleDyn (\e -> case e of
253 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
254 _other -> return ()) $ do
256 -- read commands from stdin
257 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
260 else fileLoop stdin show_prompt
262 fileLoop stdin show_prompt
266 -- NOTE: We only read .ghci files if they are owned by the current user,
267 -- and aren't world writable. Otherwise, we could be accidentally
268 -- running code planted by a malicious third party.
270 -- Furthermore, We only read ./.ghci if . is owned by the current user
271 -- and isn't writable by anyone else. I think this is sufficient: we
272 -- don't need to check .. and ../.. etc. because "." always refers to
273 -- the same directory while a process is running.
275 checkPerms :: String -> IO Bool
277 #ifdef mingw32_HOST_OS
280 DriverUtil.handle (\_ -> return False) $ do
281 st <- getFileStatus name
283 if fileOwner st /= me then do
284 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
287 let mode = fileMode st
288 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
289 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
291 putStrLn $ "*** WARNING: " ++ name ++
292 " is writable by someone else, IGNORING!"
297 fileLoop :: Handle -> Bool -> GHCi ()
298 fileLoop hdl prompt = do
299 cmstate <- getCmState
300 (mod,imports) <- io (cmGetContext cmstate)
301 when prompt (io (putStr (mkPrompt mod imports)))
302 l <- io (IO.try (hGetLine hdl))
304 Left e | isEOFError e -> return ()
305 | otherwise -> io (ioError e)
307 case remove_spaces l of
308 "" -> fileLoop hdl prompt
309 l -> do quit <- runCommand l
310 if quit then return () else fileLoop hdl prompt
312 stringLoop :: [String] -> GHCi ()
313 stringLoop [] = return ()
314 stringLoop (s:ss) = do
315 case remove_spaces s of
317 l -> do quit <- runCommand l
318 if quit then return () else stringLoop ss
320 mkPrompt toplevs exports
321 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
323 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
324 readlineLoop :: GHCi ()
326 cmstate <- getCmState
327 (mod,imports) <- io (cmGetContext cmstate)
329 l <- io (readline (mkPrompt mod imports)
330 `finally` setNonBlockingFD 0)
331 -- readline sometimes puts stdin into blocking mode,
332 -- so we need to put it back for the IO library
336 case remove_spaces l of
341 if quit then return () else readlineLoop
344 runCommand :: String -> GHCi Bool
345 runCommand c = ghciHandle handler (doCommand c)
347 -- This is the exception handler for exceptions generated by the
348 -- user's code; it normally just prints out the exception. The
349 -- handler must be recursive, in case showing the exception causes
350 -- more exceptions to be raised.
352 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
353 -- raising another exception. We therefore don't put the recursive
354 -- handler arond the flushing operation, so if stderr is closed
355 -- GHCi will just die gracefully rather than going into an infinite loop.
356 handler :: Exception -> GHCi Bool
357 handler exception = do
359 io installSignalHandlers
360 ghciHandle handler (showException exception >> return False)
362 showException (DynException dyn) =
363 case fromDynamic dyn of
364 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
365 Just Interrupted -> io (putStrLn "Interrupted.")
366 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
367 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
368 Just other_ghc_ex -> io (print other_ghc_ex)
370 showException other_exception
371 = io (putStrLn ("*** Exception: " ++ show other_exception))
373 doCommand (':' : command) = specialCommand command
375 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
378 runStmt :: String -> GHCi [Name]
380 | null (filter (not.isSpace) stmt) = return []
382 = do st <- getGHCiState
383 dflags <- io getDynFlags
384 let cm_state' = cmSetDFlags (cmstate st)
385 (dopt_unset dflags Opt_WarnUnusedBinds)
386 (new_cmstate, result) <-
387 io $ withProgName (progname st) $ withArgs (args st) $
388 cmRunStmt cm_state' stmt
389 setGHCiState st{cmstate = new_cmstate}
391 CmRunFailed -> return []
392 CmRunException e -> showException e >> return []
393 CmRunOk names -> return names
395 -- possibly print the type and revert CAFs after evaluating an expression
397 = do b <- isOptionSet ShowType
398 cmstate <- getCmState
399 when b (mapM_ (showTypeOfName cmstate) names)
402 io installSignalHandlers
403 b <- isOptionSet RevertCAFs
404 io (when b revertCAFs)
407 showTypeOfName :: CmState -> Name -> GHCi ()
408 showTypeOfName cmstate n
409 = do maybe_str <- io (cmTypeOfName cmstate n)
412 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
414 specialCommand :: String -> GHCi Bool
415 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
416 specialCommand str = do
417 let (cmd,rest) = break isSpace str
418 cmds <- io (readIORef commands)
419 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
420 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
421 ++ shortHelpText) >> return False)
422 [(_,f)] -> f (dropWhile isSpace rest)
423 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
424 " matches multiple commands (" ++
425 foldr1 (\a b -> a ++ ',':b) (map fst cs)
426 ++ ")") >> return False)
428 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
431 -----------------------------------------------------------------------------
432 -- To flush buffers for the *interpreted* computation we need
433 -- to refer to *its* stdout/stderr handles
435 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
436 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
438 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
439 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
440 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
442 initInterpBuffering :: CmState -> IO ()
443 initInterpBuffering cmstate
444 = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
447 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
448 other -> panic "interactiveUI:setBuffering"
450 maybe_hval <- cmCompileExpr cmstate flush_cmd
452 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
453 _ -> panic "interactiveUI:flush"
455 turnOffBuffering -- Turn it off right now
460 flushInterpBuffers :: GHCi ()
462 = io $ do Monad.join (readIORef flush_interp)
465 turnOffBuffering :: IO ()
467 = do Monad.join (readIORef turn_off_buffering)
470 -----------------------------------------------------------------------------
473 help :: String -> GHCi ()
474 help _ = io (putStr helpText)
476 info :: String -> GHCi ()
477 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
480 init_cms <- getCmState
482 infoThings cms [] = return cms
483 infoThings cms (name:names) = do
484 stuff <- io (cmInfoThing cms name)
485 io (putStrLn (showSDocForUser unqual (
486 vcat (intersperse (text "") (map showThing stuff))))
490 unqual = cmGetPrintUnqual init_cms
492 showThing (decl, fixity)
493 = vcat [ text "-- " <> showTyThing decl,
494 showFixity fixity (ifName decl),
498 | fix == defaultFixity = empty
499 | otherwise = ppr fix <+>
502 else char '`' <> ppr name <> char '`')
504 showTyThing decl = ppr decl
507 showTyThing (AClass cl)
508 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
509 showTyThing (ADataCon dc)
510 = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
511 showTyThing (ATyCon ty)
513 = hcat [ppr ty, text " is a primitive type constructor"]
515 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
516 showTyThing (AnId id)
517 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
520 = case globalIdDetails id of
521 RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
522 ClassOpId cls -> text "method in class" <+> ppr cls
523 otherwise -> text "variable"
525 -- also print out the source location for home things
527 | isHomePackageName name && isGoodSrcLoc loc
528 = hsep [ text ", defined at", ppr loc ]
531 where loc = nameSrcLoc name
534 infoThings init_cms names
537 addModule :: [FilePath] -> GHCi ()
539 state <- getGHCiState
540 io (revertCAFs) -- always revert CAFs on load/add.
541 files <- mapM expandPath files
542 let new_targets = files ++ targets state
543 graph <- io (cmDepAnal (cmstate state) new_targets)
544 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
545 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
546 setContextAfterLoad mods
547 dflags <- io getDynFlags
548 modulesLoadedMsg ok mods dflags
550 changeDirectory :: String -> GHCi ()
551 changeDirectory dir = do
552 state <- getGHCiState
553 when (targets state /= []) $
554 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\
555 \because the search path has changed.\n"
556 cmstate1 <- io (cmUnload (cmstate state))
557 setGHCiState state{ cmstate = cmstate1, targets = [] }
558 setContextAfterLoad []
559 dir <- expandPath dir
560 io (setCurrentDirectory dir)
562 defineMacro :: String -> GHCi ()
564 let (macro_name, definition) = break isSpace s
565 cmds <- io (readIORef commands)
567 then throwDyn (CmdLineError "invalid macro name")
569 if (macro_name `elem` map fst cmds)
570 then throwDyn (CmdLineError
571 ("command `" ++ macro_name ++ "' is already defined"))
574 -- give the expression a type signature, so we can be sure we're getting
575 -- something of the right type.
576 let new_expr = '(' : definition ++ ") :: String -> IO String"
578 -- compile the expression
580 maybe_hv <- io (cmCompileExpr cms new_expr)
583 Just hv -> io (writeIORef commands --
584 ((macro_name, keepGoing (runMacro hv)) : cmds))
586 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
588 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
589 stringLoop (lines str)
591 undefineMacro :: String -> GHCi ()
592 undefineMacro macro_name = do
593 cmds <- io (readIORef commands)
594 if (macro_name `elem` map fst builtin_commands)
595 then throwDyn (CmdLineError
596 ("command `" ++ macro_name ++ "' cannot be undefined"))
598 if (macro_name `notElem` map fst cmds)
599 then throwDyn (CmdLineError
600 ("command `" ++ macro_name ++ "' not defined"))
602 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
605 loadModule :: [FilePath] -> GHCi ()
606 loadModule fs = timeIt (loadModule' fs)
608 loadModule' :: [FilePath] -> GHCi ()
609 loadModule' files = do
610 state <- getGHCiState
613 files <- mapM expandPath files
615 -- do the dependency anal first, so that if it fails we don't throw
616 -- away the current set of modules.
617 graph <- io (cmDepAnal (cmstate state) files)
619 -- Dependency anal ok, now unload everything
620 cmstate1 <- io (cmUnload (cmstate state))
621 setGHCiState state{ cmstate = cmstate1, targets = [] }
623 io (revertCAFs) -- always revert CAFs on load.
624 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
625 setGHCiState state{ cmstate = cmstate2, targets = files }
627 setContextAfterLoad mods
628 dflags <- io (getDynFlags)
629 modulesLoadedMsg ok mods dflags
632 reloadModule :: String -> GHCi ()
634 state <- getGHCiState
635 case targets state of
636 [] -> io (putStr "no current target\n")
638 -- do the dependency anal first, so that if it fails we don't throw
639 -- away the current set of modules.
640 graph <- io (cmDepAnal (cmstate state) paths)
642 io (revertCAFs) -- always revert CAFs on reload.
644 <- io (cmLoadModules (cmstate state) graph)
645 setGHCiState state{ cmstate=cmstate1 }
646 setContextAfterLoad mods
647 dflags <- io getDynFlags
648 modulesLoadedMsg ok mods dflags
650 reloadModule _ = noArgs ":reload"
652 setContextAfterLoad [] = setContext prel
653 setContextAfterLoad (m:_) = do
654 cmstate <- getCmState
655 b <- io (cmModuleIsInterpreted cmstate m)
656 if b then setContext ('*':m) else setContext m
658 modulesLoadedMsg ok mods dflags =
659 when (verbosity dflags > 0) $ do
661 | null mods = text "none."
663 punctuate comma (map text mods)) <> text "."
666 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
668 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
671 typeOfExpr :: String -> GHCi ()
673 = do cms <- getCmState
674 maybe_tystr <- io (cmTypeOfExpr cms str)
677 Just tystr -> io (putStrLn tystr)
679 quit :: String -> GHCi Bool
682 shellEscape :: String -> GHCi Bool
683 shellEscape str = io (system str >> return False)
685 -----------------------------------------------------------------------------
686 -- Browing a module's contents
688 browseCmd :: String -> GHCi ()
691 ['*':m] | looksLikeModuleName m -> browseModule m False
692 [m] | looksLikeModuleName m -> browseModule m True
693 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
695 browseModule m exports_only = do
698 is_interpreted <- io (cmModuleIsInterpreted cms m)
699 when (not is_interpreted && not exports_only) $
700 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
702 -- Temporarily set the context to the module we're interested in,
703 -- just so we can get an appropriate PrintUnqualified
704 (as,bs) <- io (cmGetContext cms)
705 cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
706 else cmSetContext cms [m] [])
707 cms2 <- io (cmSetContext cms1 as bs)
709 things <- io (cmBrowseModule cms2 m exports_only)
711 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
713 io (putStrLn (showSDocForUser unqual (
714 vcat (map ppr things)
717 -----------------------------------------------------------------------------
718 -- Setting the module context
721 | all sensible mods = fn mods
722 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
724 (fn, mods) = case str of
725 '+':stuff -> (addToContext, words stuff)
726 '-':stuff -> (removeFromContext, words stuff)
727 stuff -> (newContext, words stuff)
729 sensible ('*':m) = looksLikeModuleName m
730 sensible m = looksLikeModuleName m
734 (as,bs) <- separate cms mods [] []
735 let bs' = if null as && prel `notElem` bs then prel:bs else bs
736 cms' <- io (cmSetContext cms as bs')
739 separate cmstate [] as bs = return (as,bs)
740 separate cmstate (('*':m):ms) as bs = do
741 b <- io (cmModuleIsInterpreted cmstate m)
742 if b then separate cmstate ms (m:as) bs
743 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
744 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
749 addToContext mods = do
751 (as,bs) <- io (cmGetContext cms)
753 (as',bs') <- separate cms mods [] []
755 let as_to_add = as' \\ (as ++ bs)
756 bs_to_add = bs' \\ (as ++ bs)
758 cms' <- io (cmSetContext cms
759 (as ++ as_to_add) (bs ++ bs_to_add))
763 removeFromContext mods = do
765 (as,bs) <- io (cmGetContext cms)
767 (as_to_remove,bs_to_remove) <- separate cms mods [] []
769 let as' = as \\ (as_to_remove ++ bs_to_remove)
770 bs' = bs \\ (as_to_remove ++ bs_to_remove)
772 cms' <- io (cmSetContext cms as' bs')
775 ----------------------------------------------------------------------------
778 -- set options in the interpreter. Syntax is exactly the same as the
779 -- ghc command line, except that certain options aren't available (-C,
782 -- This is pretty fragile: most options won't work as expected. ToDo:
783 -- figure out which ones & disallow them.
785 setCmd :: String -> GHCi ()
787 = do st <- getGHCiState
788 let opts = options st
789 io $ putStrLn (showSDoc (
790 text "options currently set: " <>
793 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
797 ("args":args) -> setArgs args
798 ("prog":prog) -> setProg prog
799 wds -> setOptions wds
803 setGHCiState st{ args = args }
807 setGHCiState st{ progname = prog }
809 io (hPutStrLn stderr "syntax: :set prog <progname>")
812 do -- first, deal with the GHCi opts (+s, +t, etc.)
813 let (plus_opts, minus_opts) = partition isPlus wds
814 mapM_ setOpt plus_opts
816 -- now, the GHC flags
817 pkgs_before <- io (readIORef v_ExplicitPackages)
818 leftovers <- io (processArgs static_flags minus_opts [])
819 pkgs_after <- io (readIORef v_ExplicitPackages)
821 -- update things if the users wants more packages
822 let new_packages = pkgs_after \\ pkgs_before
823 when (not (null new_packages)) $
824 newPackages new_packages
826 -- don't forget about the extra command-line flags from the
827 -- extra_ghc_opts fields in the new packages
828 new_package_details <- io (getPackageDetails new_packages)
829 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
830 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
832 -- then, dynamic flags
835 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
838 if (not (null leftovers))
839 then throwDyn (CmdLineError ("unrecognised flags: " ++
844 unsetOptions :: String -> GHCi ()
846 = do -- first, deal with the GHCi opts (+s, +t, etc.)
848 (minus_opts, rest1) = partition isMinus opts
849 (plus_opts, rest2) = partition isPlus rest1
851 if (not (null rest2))
852 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
855 mapM_ unsetOpt plus_opts
857 -- can't do GHC flags for now
858 if (not (null minus_opts))
859 then throwDyn (CmdLineError "can't unset GHC command-line flags")
862 isMinus ('-':s) = True
865 isPlus ('+':s) = True
869 = case strToGHCiOpt str of
870 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
871 Just o -> setOption o
874 = case strToGHCiOpt str of
875 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
876 Just o -> unsetOption o
878 strToGHCiOpt :: String -> (Maybe GHCiOption)
879 strToGHCiOpt "s" = Just ShowTiming
880 strToGHCiOpt "t" = Just ShowType
881 strToGHCiOpt "r" = Just RevertCAFs
882 strToGHCiOpt _ = Nothing
884 optToStr :: GHCiOption -> String
885 optToStr ShowTiming = "s"
886 optToStr ShowType = "t"
887 optToStr RevertCAFs = "r"
889 newPackages new_pkgs = do -- The new packages are already in v_Packages
890 state <- getGHCiState
891 cmstate1 <- io (cmUnload (cmstate state))
892 setGHCiState state{ cmstate = cmstate1, targets = [] }
893 dflags <- io getDynFlags
894 io (linkPackages dflags new_pkgs)
895 setContextAfterLoad []
897 -- ---------------------------------------------------------------------------
902 ["modules" ] -> showModules
903 ["bindings"] -> showBindings
904 ["linker"] -> io showLinkerState
905 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
909 let (mg, hpt) = cmGetModInfo cms
910 mapM_ (showModule hpt) mg
913 showModule :: HomePackageTable -> ModSummary -> GHCi ()
914 showModule hpt mod_summary
915 = case lookupModuleEnv hpt mod of
916 Nothing -> panic "missing linkable"
917 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
919 obj_linkable = isObjectLinkable (hm_linkable mod_info)
921 mod = ms_mod mod_summary
922 locn = ms_location mod_summary
927 unqual = cmGetPrintUnqual cms
928 -- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
929 showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
931 io (mapM_ showBinding (cmGetBindings cms))
935 -----------------------------------------------------------------------------
938 data GHCiState = GHCiState
942 targets :: [FilePath],
944 options :: [GHCiOption]
948 = ShowTiming -- show time/allocs after evaluation
949 | ShowType -- show the type of expressions
950 | RevertCAFs -- revert CAFs after every evaluation
953 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
955 startGHCi :: GHCi a -> GHCiState -> IO a
956 startGHCi g state = do ref <- newIORef state; unGHCi g ref
958 instance Monad GHCi where
959 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
960 return a = GHCi $ \s -> return a
962 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
963 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
964 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
966 getGHCiState = GHCi $ \r -> readIORef r
967 setGHCiState s = GHCi $ \r -> writeIORef r s
969 -- for convenience...
970 getCmState = getGHCiState >>= return . cmstate
971 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
973 isOptionSet :: GHCiOption -> GHCi Bool
975 = do st <- getGHCiState
976 return (opt `elem` options st)
978 setOption :: GHCiOption -> GHCi ()
980 = do st <- getGHCiState
981 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
983 unsetOption :: GHCiOption -> GHCi ()
985 = do st <- getGHCiState
986 setGHCiState (st{ options = filter (/= opt) (options st) })
989 io m = GHCi { unGHCi = \s -> m >>= return }
991 -----------------------------------------------------------------------------
992 -- recursive exception handlers
994 -- Don't forget to unblock async exceptions in the handler, or if we're
995 -- in an exception loop (eg. let a = error a in a) the ^C exception
996 -- may never be delivered. Thanks to Marcin for pointing out the bug.
998 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
999 ghciHandle h (GHCi m) = GHCi $ \s ->
1000 Exception.catch (m s)
1001 (\e -> unGHCi (ghciUnblock (h e)) s)
1003 ghciUnblock :: GHCi a -> GHCi a
1004 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1006 -----------------------------------------------------------------------------
1007 -- timing & statistics
1009 timeIt :: GHCi a -> GHCi a
1011 = do b <- isOptionSet ShowTiming
1014 else do allocs1 <- io $ getAllocations
1015 time1 <- io $ getCPUTime
1017 allocs2 <- io $ getAllocations
1018 time2 <- io $ getCPUTime
1019 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1022 foreign import ccall "getAllocations" getAllocations :: IO Int
1024 printTimes :: Int -> Integer -> IO ()
1025 printTimes allocs psecs
1026 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1027 secs_str = showFFloat (Just 2) secs
1028 putStrLn (showSDoc (
1029 parens (text (secs_str "") <+> text "secs" <> comma <+>
1030 int allocs <+> text "bytes")))
1032 -----------------------------------------------------------------------------
1039 -- Have to turn off buffering again, because we just
1040 -- reverted stdout, stderr & stdin to their defaults.
1042 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1043 -- Make it "safe", just in case
1045 -- -----------------------------------------------------------------------------
1048 expandPath :: String -> GHCi String
1050 case dropWhile isSpace path of
1052 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1053 return (tilde ++ '/':d)