1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.152 2003/05/07 08:29:48 simonpj Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2000
9 -----------------------------------------------------------------------------
10 module InteractiveUI (
11 interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
15 #include "../includes/config.h"
16 #include "HsVersions.h"
19 import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
21 import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
22 import MkIface ( ifaceTyThing )
25 import DriverUtil ( remove_spaces, handle )
26 import Linker ( initLinker, showLinkerState, linkLibraries,
29 import IdInfo ( GlobalIdDetails(..) )
30 import Id ( isImplicitId, idName, globalIdDetails )
31 import Class ( className )
32 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
33 import DataCon ( dataConName )
34 import FieldLabel ( fieldLabelTyCon )
35 import SrcLoc ( isGoodSrcLoc )
36 import Module ( showModMsg, lookupModuleEnv )
37 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
39 import OccName ( isSymOcc )
40 import BasicTypes ( defaultFixity, SuccessFlag(..) )
43 import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
44 restoreDynFlags, dopt_unset )
45 import Panic hiding ( showException )
48 #ifndef mingw32_HOST_OS
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 :: CmState -> [FilePath] -> [FilePath] -> IO ()
159 interactiveUI cmstate paths cmdline_objs = do
161 hSetBuffering stdout NoBuffering
163 dflags <- getDynFlags
167 -- link packages requested explicitly on the command-line
168 expl <- readIORef v_ExplicitPackages
169 linkPackages dflags expl
171 -- link libraries from the command-line
172 linkLibraries dflags cmdline_objs
174 -- Initialise buffering for the *interpreted* I/O system
175 cmstate <- initInterpBuffering cmstate dflags
177 -- We don't want the cmd line to buffer any input that might be
178 -- intended for the program, so unbuffer stdin.
179 hSetBuffering stdin NoBuffering
181 -- initial context is just the Prelude
182 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
184 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
188 startGHCi (runGHCi paths dflags)
189 GHCiState{ progname = "<interactive>",
195 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
196 Readline.resetTerminal Nothing
201 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
202 runGHCi paths dflags = do
203 read_dot_files <- io (readIORef v_Read_DotGHCi)
205 when (read_dot_files) $ do
208 exists <- io (doesFileExist file)
210 dir_ok <- io (checkPerms ".")
211 file_ok <- io (checkPerms file)
212 when (dir_ok && file_ok) $ do
213 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
216 Right hdl -> fileLoop hdl False
218 when (read_dot_files) $ do
219 -- Read in $HOME/.ghci
220 either_dir <- io (IO.try (getEnv "HOME"))
224 cwd <- io (getCurrentDirectory)
225 when (dir /= cwd) $ do
226 let file = dir ++ "/.ghci"
227 ok <- io (checkPerms file)
229 either_hdl <- io (IO.try (openFile file ReadMode))
232 Right hdl -> fileLoop hdl False
234 -- perform a :load for files given on the GHCi command line
235 when (not (null paths)) $
236 ghciHandle showException $
239 -- enter the interactive loop
240 #if defined(mingw32_HOST_OS)
241 -- always show prompt, since hIsTerminalDevice returns True for Consoles
242 -- only, which we may or may not be running under (cf. Emacs sub-shells.)
245 is_tty <- io (hIsTerminalDevice stdin)
246 interactiveLoop is_tty
250 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
253 interactiveLoop is_tty = do
254 -- ignore ^C exceptions caught here
255 ghciHandleDyn (\e -> case e of
256 Interrupted -> ghciUnblock (interactiveLoop is_tty)
257 _other -> return ()) $ do
259 -- read commands from stdin
260 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
263 else fileLoop stdin False -- turn off prompt for non-TTY input
265 fileLoop stdin is_tty
269 -- NOTE: We only read .ghci files if they are owned by the current user,
270 -- and aren't world writable. Otherwise, we could be accidentally
271 -- running code planted by a malicious third party.
273 -- Furthermore, We only read ./.ghci if . is owned by the current user
274 -- and isn't writable by anyone else. I think this is sufficient: we
275 -- don't need to check .. and ../.. etc. because "." always refers to
276 -- the same directory while a process is running.
278 checkPerms :: String -> IO Bool
280 #ifdef mingw32_HOST_OS
283 DriverUtil.handle (\_ -> return False) $ do
284 st <- getFileStatus name
286 if fileOwner st /= me then do
287 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
290 let mode = fileMode st
291 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
292 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
294 putStrLn $ "*** WARNING: " ++ name ++
295 " is writable by someone else, IGNORING!"
300 fileLoop :: Handle -> Bool -> GHCi ()
301 fileLoop hdl prompt = do
302 cmstate <- getCmState
303 (mod,imports) <- io (cmGetContext cmstate)
304 when prompt (io (putStr (mkPrompt mod imports)))
305 l <- io (IO.try (hGetLine hdl))
307 Left e | isEOFError e -> return ()
308 | otherwise -> io (ioError e)
310 case remove_spaces l of
311 "" -> fileLoop hdl prompt
312 l -> do quit <- runCommand l
313 if quit then return () else fileLoop hdl prompt
315 stringLoop :: [String] -> GHCi ()
316 stringLoop [] = return ()
317 stringLoop (s:ss) = do
318 case remove_spaces s of
320 l -> do quit <- runCommand l
321 if quit then return () else stringLoop ss
323 mkPrompt toplevs exports
324 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
326 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
327 readlineLoop :: GHCi ()
329 cmstate <- getCmState
330 (mod,imports) <- io (cmGetContext cmstate)
332 l <- io (readline (mkPrompt mod imports)
333 `finally` setNonBlockingFD 0)
334 -- readline sometimes puts stdin into blocking mode,
335 -- so we need to put it back for the IO library
339 case remove_spaces l of
344 if quit then return () else readlineLoop
347 runCommand :: String -> GHCi Bool
348 runCommand c = ghciHandle handler (doCommand c)
350 -- This is the exception handler for exceptions generated by the
351 -- user's code; it normally just prints out the exception. The
352 -- handler must be recursive, in case showing the exception causes
353 -- more exceptions to be raised.
355 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
356 -- raising another exception. We therefore don't put the recursive
357 -- handler arond the flushing operation, so if stderr is closed
358 -- GHCi will just die gracefully rather than going into an infinite loop.
359 handler :: Exception -> GHCi Bool
360 handler exception = do
362 io installSignalHandlers
363 ghciHandle handler (showException exception >> return False)
365 showException (DynException dyn) =
366 case fromDynamic dyn of
367 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
368 Just Interrupted -> io (putStrLn "Interrupted.")
369 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
370 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
371 Just other_ghc_ex -> io (print other_ghc_ex)
373 showException other_exception
374 = io (putStrLn ("*** Exception: " ++ show other_exception))
376 doCommand (':' : command) = specialCommand command
378 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
381 runStmt :: String -> GHCi [Name]
383 | null (filter (not.isSpace) stmt) = return []
385 = do st <- getGHCiState
386 dflags <- io getDynFlags
387 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
388 (new_cmstate, result) <-
389 io $ withProgName (progname st) $ withArgs (args st) $
390 cmRunStmt (cmstate st) dflags' stmt
391 setGHCiState st{cmstate = new_cmstate}
393 CmRunFailed -> return []
394 CmRunException e -> showException e >> return []
395 CmRunOk names -> return names
397 -- possibly print the type and revert CAFs after evaluating an expression
399 = do b <- isOptionSet ShowType
400 cmstate <- getCmState
401 when b (mapM_ (showTypeOfName cmstate) names)
404 io installSignalHandlers
405 b <- isOptionSet RevertCAFs
406 io (when b revertCAFs)
409 showTypeOfName :: CmState -> Name -> GHCi ()
410 showTypeOfName cmstate n
411 = do maybe_str <- io (cmTypeOfName cmstate n)
414 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
416 specialCommand :: String -> GHCi Bool
417 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
418 specialCommand str = do
419 let (cmd,rest) = break isSpace str
420 cmds <- io (readIORef commands)
421 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
422 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
423 ++ shortHelpText) >> return False)
424 [(_,f)] -> f (dropWhile isSpace rest)
425 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
426 " matches multiple commands (" ++
427 foldr1 (\a b -> a ++ ',':b) (map fst cs)
428 ++ ")") >> return False)
430 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
433 -----------------------------------------------------------------------------
434 -- To flush buffers for the *interpreted* computation we need
435 -- to refer to *its* stdout/stderr handles
437 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
438 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
440 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
441 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
442 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
444 initInterpBuffering :: CmState -> DynFlags -> IO CmState
445 initInterpBuffering cmstate dflags
446 = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
449 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
450 other -> panic "interactiveUI:setBuffering"
452 (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
454 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
455 _ -> panic "interactiveUI:flush"
457 turnOffBuffering -- Turn it off right now
462 flushInterpBuffers :: GHCi ()
464 = io $ do Monad.join (readIORef flush_interp)
467 turnOffBuffering :: IO ()
469 = do Monad.join (readIORef turn_off_buffering)
472 -----------------------------------------------------------------------------
475 help :: String -> GHCi ()
476 help _ = io (putStr helpText)
478 info :: String -> GHCi ()
479 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
482 init_cms <- getCmState
483 dflags <- io getDynFlags
485 infoThings cms [] = return cms
486 infoThings cms (name:names) = do
487 (cms, stuff) <- io (cmInfoThing cms dflags name)
488 io (putStrLn (showSDocForUser unqual (
489 vcat (intersperse (text "") (map showThing stuff))))
493 unqual = cmGetPrintUnqual init_cms
495 showThing (ty_thing, fixity)
496 = vcat [ text "-- " <> showTyThing ty_thing,
497 showFixity fixity (getName ty_thing),
498 ppr (ifaceTyThing ty_thing) ]
501 | fix == defaultFixity = empty
502 | otherwise = ppr fix <+>
503 (if isSymOcc (nameOccName name)
505 else char '`' <> ppr name <> char '`')
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
533 cms <- infoThings init_cms names
537 addModule :: [FilePath] -> GHCi ()
539 state <- getGHCiState
540 dflags <- io (getDynFlags)
541 io (revertCAFs) -- always revert CAFs on load/add.
542 files <- mapM expandPath files
543 let new_targets = files ++ targets state
544 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
545 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
546 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
547 setContextAfterLoad mods
548 modulesLoadedMsg ok mods dflags
550 changeDirectory :: String -> GHCi ()
551 changeDirectory dir = do
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 dflags <- io getDynFlags
574 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
575 setCmState new_cmstate
578 Just hv -> io (writeIORef commands --
579 ((macro_name, keepGoing (runMacro hv)) : cmds))
581 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
583 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
584 stringLoop (lines str)
586 undefineMacro :: String -> GHCi ()
587 undefineMacro macro_name = do
588 cmds <- io (readIORef commands)
589 if (macro_name `elem` map fst builtin_commands)
590 then throwDyn (CmdLineError
591 ("command `" ++ macro_name ++ "' cannot be undefined"))
593 if (macro_name `notElem` map fst cmds)
594 then throwDyn (CmdLineError
595 ("command `" ++ macro_name ++ "' not defined"))
597 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
600 loadModule :: [FilePath] -> GHCi ()
601 loadModule fs = timeIt (loadModule' fs)
603 loadModule' :: [FilePath] -> GHCi ()
604 loadModule' files = do
605 state <- getGHCiState
606 dflags <- io getDynFlags
609 files <- mapM expandPath files
611 -- do the dependency anal first, so that if it fails we don't throw
612 -- away the current set of modules.
613 graph <- io (cmDepAnal (cmstate state) dflags files)
615 -- Dependency anal ok, now unload everything
616 cmstate1 <- io (cmUnload (cmstate state) dflags)
617 setGHCiState state{ cmstate = cmstate1, targets = [] }
619 io (revertCAFs) -- always revert CAFs on load.
620 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
621 setGHCiState state{ cmstate = cmstate2, targets = files }
623 setContextAfterLoad mods
624 modulesLoadedMsg ok mods dflags
627 reloadModule :: String -> GHCi ()
629 state <- getGHCiState
630 dflags <- io getDynFlags
631 case targets state of
632 [] -> io (putStr "no current target\n")
634 -- do the dependency anal first, so that if it fails we don't throw
635 -- away the current set of modules.
636 graph <- io (cmDepAnal (cmstate state) dflags paths)
638 io (revertCAFs) -- always revert CAFs on reload.
640 <- io (cmLoadModules (cmstate state) dflags graph)
641 setGHCiState state{ cmstate=cmstate1 }
642 setContextAfterLoad mods
643 modulesLoadedMsg ok mods dflags
645 reloadModule _ = noArgs ":reload"
647 setContextAfterLoad [] = setContext prel
648 setContextAfterLoad (m:_) = do
649 cmstate <- getCmState
650 b <- io (cmModuleIsInterpreted cmstate m)
651 if b then setContext ('*':m) else setContext m
653 modulesLoadedMsg ok mods dflags =
654 when (verbosity dflags > 0) $ do
656 | null mods = text "none."
658 punctuate comma (map text mods)) <> text "."
661 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
663 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
666 typeOfExpr :: String -> GHCi ()
668 = do cms <- getCmState
669 dflags <- io getDynFlags
670 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
671 setCmState new_cmstate
674 Just tystr -> io (putStrLn tystr)
676 quit :: String -> GHCi Bool
679 shellEscape :: String -> GHCi Bool
680 shellEscape str = io (system str >> return False)
682 -----------------------------------------------------------------------------
683 -- Browing a module's contents
685 browseCmd :: String -> GHCi ()
688 ['*':m] | looksLikeModuleName m -> browseModule m False
689 [m] | looksLikeModuleName m -> browseModule m True
690 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
692 browseModule m exports_only = do
694 dflags <- io getDynFlags
696 is_interpreted <- io (cmModuleIsInterpreted cms m)
697 when (not is_interpreted && not exports_only) $
698 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
700 -- temporarily set the context to the module we're interested in,
701 -- just so we can get an appropriate PrintUnqualified
702 (as,bs) <- io (cmGetContext cms)
703 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
704 else cmSetContext cms dflags [m] [])
705 cms2 <- io (cmSetContext cms1 dflags as bs)
707 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
711 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
713 things' = filter wantToSee things
715 wantToSee (AnId id) = not (isImplicitId id)
716 wantToSee (ADataCon _) = False -- They'll come via their TyCon
719 thing_names = map getName things
721 thingDecl thing@(AnId id) = ifaceTyThing thing
723 thingDecl thing@(AClass c) =
724 let rn_decl = ifaceTyThing thing in
726 ClassDecl { tcdSigs = cons } ->
727 rn_decl{ tcdSigs = filter methodIsVisible cons }
730 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
732 thingDecl thing@(ATyCon t) =
733 let rn_decl = ifaceTyThing thing in
735 TyData { tcdCons = DataCons cons } ->
736 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
739 conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
741 io (putStrLn (showSDocForUser unqual (
742 vcat (map (ppr . thingDecl) things')))
747 -----------------------------------------------------------------------------
748 -- Setting the module context
751 | all sensible mods = fn mods
752 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
754 (fn, mods) = case str of
755 '+':stuff -> (addToContext, words stuff)
756 '-':stuff -> (removeFromContext, words stuff)
757 stuff -> (newContext, words stuff)
759 sensible ('*':m) = looksLikeModuleName m
760 sensible m = looksLikeModuleName m
764 dflags <- io getDynFlags
765 (as,bs) <- separate cms mods [] []
766 let bs' = if null as && prel `notElem` bs then prel:bs else bs
767 cms' <- io (cmSetContext cms dflags as bs')
770 separate cmstate [] as bs = return (as,bs)
771 separate cmstate (('*':m):ms) as bs = do
772 b <- io (cmModuleIsInterpreted cmstate m)
773 if b then separate cmstate ms (m:as) bs
774 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
775 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
780 addToContext mods = do
782 dflags <- io getDynFlags
783 (as,bs) <- io (cmGetContext cms)
785 (as',bs') <- separate cms mods [] []
787 let as_to_add = as' \\ (as ++ bs)
788 bs_to_add = bs' \\ (as ++ bs)
790 cms' <- io (cmSetContext cms dflags
791 (as ++ as_to_add) (bs ++ bs_to_add))
795 removeFromContext mods = do
797 dflags <- io getDynFlags
798 (as,bs) <- io (cmGetContext cms)
800 (as_to_remove,bs_to_remove) <- separate cms mods [] []
802 let as' = as \\ (as_to_remove ++ bs_to_remove)
803 bs' = bs \\ (as_to_remove ++ bs_to_remove)
805 cms' <- io (cmSetContext cms dflags as' bs')
808 ----------------------------------------------------------------------------
811 -- set options in the interpreter. Syntax is exactly the same as the
812 -- ghc command line, except that certain options aren't available (-C,
815 -- This is pretty fragile: most options won't work as expected. ToDo:
816 -- figure out which ones & disallow them.
818 setCmd :: String -> GHCi ()
820 = do st <- getGHCiState
821 let opts = options st
822 io $ putStrLn (showSDoc (
823 text "options currently set: " <>
826 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
830 ("args":args) -> setArgs args
831 ("prog":prog) -> setProg prog
832 wds -> setOptions wds
836 setGHCiState st{ args = args }
840 setGHCiState st{ progname = prog }
842 io (hPutStrLn stderr "syntax: :set prog <progname>")
845 do -- first, deal with the GHCi opts (+s, +t, etc.)
846 let (plus_opts, minus_opts) = partition isPlus wds
847 mapM_ setOpt plus_opts
849 -- now, the GHC flags
850 pkgs_before <- io (readIORef v_ExplicitPackages)
851 leftovers <- io (processArgs static_flags minus_opts [])
852 pkgs_after <- io (readIORef v_ExplicitPackages)
854 -- update things if the users wants more packages
855 let new_packages = pkgs_after \\ pkgs_before
856 when (not (null new_packages)) $
857 newPackages new_packages
859 -- don't forget about the extra command-line flags from the
860 -- extra_ghc_opts fields in the new packages
861 new_package_details <- io (getPackageDetails new_packages)
862 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
863 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
865 -- then, dynamic flags
868 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
871 if (not (null leftovers))
872 then throwDyn (CmdLineError ("unrecognised flags: " ++
877 unsetOptions :: String -> GHCi ()
879 = do -- first, deal with the GHCi opts (+s, +t, etc.)
881 (minus_opts, rest1) = partition isMinus opts
882 (plus_opts, rest2) = partition isPlus rest1
884 if (not (null rest2))
885 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
888 mapM_ unsetOpt plus_opts
890 -- can't do GHC flags for now
891 if (not (null minus_opts))
892 then throwDyn (CmdLineError "can't unset GHC command-line flags")
895 isMinus ('-':s) = True
898 isPlus ('+':s) = True
902 = case strToGHCiOpt str of
903 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
904 Just o -> setOption o
907 = case strToGHCiOpt str of
908 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
909 Just o -> unsetOption o
911 strToGHCiOpt :: String -> (Maybe GHCiOption)
912 strToGHCiOpt "s" = Just ShowTiming
913 strToGHCiOpt "t" = Just ShowType
914 strToGHCiOpt "r" = Just RevertCAFs
915 strToGHCiOpt _ = Nothing
917 optToStr :: GHCiOption -> String
918 optToStr ShowTiming = "s"
919 optToStr ShowType = "t"
920 optToStr RevertCAFs = "r"
922 newPackages new_pkgs = do -- The new packages are already in v_Packages
923 state <- getGHCiState
924 dflags <- io getDynFlags
925 cmstate1 <- io (cmUnload (cmstate state) dflags)
926 setGHCiState state{ cmstate = cmstate1, targets = [] }
927 io (linkPackages dflags new_pkgs)
928 setContextAfterLoad []
930 -- ---------------------------------------------------------------------------
935 ["modules" ] -> showModules
936 ["bindings"] -> showBindings
937 ["linker"] -> io showLinkerState
938 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
942 let (mg, hpt) = cmGetModInfo cms
943 mapM_ (showModule hpt) mg
946 showModule :: HomePackageTable -> ModSummary -> GHCi ()
947 showModule hpt mod_summary
948 = case lookupModuleEnv hpt mod of
949 Nothing -> panic "missing linkable"
950 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
952 obj_linkable = isObjectLinkable (hm_linkable mod_info)
954 mod = ms_mod mod_summary
955 locn = ms_location mod_summary
960 unqual = cmGetPrintUnqual cms
961 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
963 io (mapM_ showBinding (cmGetBindings cms))
967 -----------------------------------------------------------------------------
970 data GHCiState = GHCiState
974 targets :: [FilePath],
976 options :: [GHCiOption]
980 = ShowTiming -- show time/allocs after evaluation
981 | ShowType -- show the type of expressions
982 | RevertCAFs -- revert CAFs after every evaluation
985 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
987 startGHCi :: GHCi a -> GHCiState -> IO a
988 startGHCi g state = do ref <- newIORef state; unGHCi g ref
990 instance Monad GHCi where
991 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
992 return a = GHCi $ \s -> return a
994 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
995 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
996 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
998 getGHCiState = GHCi $ \r -> readIORef r
999 setGHCiState s = GHCi $ \r -> writeIORef r s
1001 -- for convenience...
1002 getCmState = getGHCiState >>= return . cmstate
1003 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1005 isOptionSet :: GHCiOption -> GHCi Bool
1007 = do st <- getGHCiState
1008 return (opt `elem` options st)
1010 setOption :: GHCiOption -> GHCi ()
1012 = do st <- getGHCiState
1013 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1015 unsetOption :: GHCiOption -> GHCi ()
1017 = do st <- getGHCiState
1018 setGHCiState (st{ options = filter (/= opt) (options st) })
1020 io :: IO a -> GHCi a
1021 io m = GHCi { unGHCi = \s -> m >>= return }
1023 -----------------------------------------------------------------------------
1024 -- recursive exception handlers
1026 -- Don't forget to unblock async exceptions in the handler, or if we're
1027 -- in an exception loop (eg. let a = error a in a) the ^C exception
1028 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1030 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1031 ghciHandle h (GHCi m) = GHCi $ \s ->
1032 Exception.catch (m s)
1033 (\e -> unGHCi (ghciUnblock (h e)) s)
1035 ghciUnblock :: GHCi a -> GHCi a
1036 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1038 -----------------------------------------------------------------------------
1039 -- timing & statistics
1041 timeIt :: GHCi a -> GHCi a
1043 = do b <- isOptionSet ShowTiming
1046 else do allocs1 <- io $ getAllocations
1047 time1 <- io $ getCPUTime
1049 allocs2 <- io $ getAllocations
1050 time2 <- io $ getCPUTime
1051 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1054 foreign import ccall "getAllocations" getAllocations :: IO Int
1056 printTimes :: Int -> Integer -> IO ()
1057 printTimes allocs psecs
1058 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1059 secs_str = showFFloat (Just 2) secs
1060 putStrLn (showSDoc (
1061 parens (text (secs_str "") <+> text "secs" <> comma <+>
1062 int allocs <+> text "bytes")))
1064 -----------------------------------------------------------------------------
1071 -- Have to turn off buffering again, because we just
1072 -- reverted stdout, stderr & stdin to their defaults.
1074 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1075 -- Make it "safe", just in case
1077 -- -----------------------------------------------------------------------------
1080 expandPath :: String -> GHCi String
1082 case dropWhile isSpace path of
1084 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1085 return (tilde ++ '/':d)