1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.159 2003/09/04 11:08:46 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 HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
22 import MkIface ( ifaceTyThing )
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;
165 hSetBuffering stdout NoBuffering
167 -- Initialise buffering for the *interpreted* I/O system
168 cmstate <- initInterpBuffering cmstate dflags
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 dflags [] ["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 dflags' = dopt_unset dflags Opt_WarnUnusedBinds
385 (new_cmstate, result) <-
386 io $ withProgName (progname st) $ withArgs (args st) $
387 cmRunStmt (cmstate st) dflags' stmt
388 setGHCiState st{cmstate = new_cmstate}
390 CmRunFailed -> return []
391 CmRunException e -> showException e >> return []
392 CmRunOk names -> return names
394 -- possibly print the type and revert CAFs after evaluating an expression
396 = do b <- isOptionSet ShowType
397 cmstate <- getCmState
398 when b (mapM_ (showTypeOfName cmstate) names)
401 io installSignalHandlers
402 b <- isOptionSet RevertCAFs
403 io (when b revertCAFs)
406 showTypeOfName :: CmState -> Name -> GHCi ()
407 showTypeOfName cmstate n
408 = do maybe_str <- io (cmTypeOfName cmstate n)
411 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
413 specialCommand :: String -> GHCi Bool
414 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
415 specialCommand str = do
416 let (cmd,rest) = break isSpace str
417 cmds <- io (readIORef commands)
418 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
419 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
420 ++ shortHelpText) >> return False)
421 [(_,f)] -> f (dropWhile isSpace rest)
422 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
423 " matches multiple commands (" ++
424 foldr1 (\a b -> a ++ ',':b) (map fst cs)
425 ++ ")") >> return False)
427 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
430 -----------------------------------------------------------------------------
431 -- To flush buffers for the *interpreted* computation we need
432 -- to refer to *its* stdout/stderr handles
434 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
435 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
437 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
438 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
439 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
441 initInterpBuffering :: CmState -> DynFlags -> IO CmState
442 initInterpBuffering cmstate dflags
443 = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
446 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
447 other -> panic "interactiveUI:setBuffering"
449 (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
451 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
452 _ -> panic "interactiveUI:flush"
454 turnOffBuffering -- Turn it off right now
459 flushInterpBuffers :: GHCi ()
461 = io $ do Monad.join (readIORef flush_interp)
464 turnOffBuffering :: IO ()
466 = do Monad.join (readIORef turn_off_buffering)
469 -----------------------------------------------------------------------------
472 help :: String -> GHCi ()
473 help _ = io (putStr helpText)
475 info :: String -> GHCi ()
476 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
479 init_cms <- getCmState
480 dflags <- io getDynFlags
482 infoThings cms [] = return cms
483 infoThings cms (name:names) = do
484 (cms, stuff) <- io (cmInfoThing cms dflags name)
485 io (putStrLn (showSDocForUser unqual (
486 vcat (intersperse (text "") (map showThing stuff))))
490 unqual = cmGetPrintUnqual init_cms
492 showThing (ty_thing, fixity)
493 = vcat [ text "-- " <> showTyThing ty_thing,
494 showFixity fixity (getName ty_thing),
495 ppr (ifaceTyThing ty_thing) ]
498 | fix == defaultFixity = empty
499 | otherwise = ppr fix <+>
500 (if isSymOcc (nameOccName name)
502 else char '`' <> ppr name <> char '`')
504 showTyThing (AClass cl)
505 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
506 showTyThing (ADataCon dc)
507 = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
508 showTyThing (ATyCon ty)
510 = hcat [ppr ty, text " is a primitive type constructor"]
512 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
513 showTyThing (AnId id)
514 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
517 = case globalIdDetails id of
518 RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
519 ClassOpId cls -> text "method in class" <+> ppr cls
520 otherwise -> text "variable"
522 -- also print out the source location for home things
524 | isHomePackageName name && isGoodSrcLoc loc
525 = hsep [ text ", defined at", ppr loc ]
528 where loc = nameSrcLoc name
530 cms <- infoThings init_cms names
534 addModule :: [FilePath] -> GHCi ()
536 state <- getGHCiState
537 dflags <- io (getDynFlags)
538 io (revertCAFs) -- always revert CAFs on load/add.
539 files <- mapM expandPath files
540 let new_targets = files ++ targets state
541 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
542 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
543 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
544 setContextAfterLoad mods
545 modulesLoadedMsg ok mods dflags
547 changeDirectory :: String -> GHCi ()
548 changeDirectory dir = do
549 state <- getGHCiState
550 when (targets state /= []) $
551 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\
552 \because the search path has changed.\n"
553 dflags <- io getDynFlags
554 cmstate1 <- io (cmUnload (cmstate state) dflags)
555 setGHCiState state{ cmstate = cmstate1, targets = [] }
556 setContextAfterLoad []
557 dir <- expandPath dir
558 io (setCurrentDirectory dir)
560 defineMacro :: String -> GHCi ()
562 let (macro_name, definition) = break isSpace s
563 cmds <- io (readIORef commands)
565 then throwDyn (CmdLineError "invalid macro name")
567 if (macro_name `elem` map fst cmds)
568 then throwDyn (CmdLineError
569 ("command `" ++ macro_name ++ "' is already defined"))
572 -- give the expression a type signature, so we can be sure we're getting
573 -- something of the right type.
574 let new_expr = '(' : definition ++ ") :: String -> IO String"
576 -- compile the expression
578 dflags <- io getDynFlags
579 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
580 setCmState new_cmstate
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
611 dflags <- io getDynFlags
614 files <- mapM expandPath files
616 -- do the dependency anal first, so that if it fails we don't throw
617 -- away the current set of modules.
618 graph <- io (cmDepAnal (cmstate state) dflags files)
620 -- Dependency anal ok, now unload everything
621 cmstate1 <- io (cmUnload (cmstate state) dflags)
622 setGHCiState state{ cmstate = cmstate1, targets = [] }
624 io (revertCAFs) -- always revert CAFs on load.
625 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
626 setGHCiState state{ cmstate = cmstate2, targets = files }
628 setContextAfterLoad mods
629 modulesLoadedMsg ok mods dflags
632 reloadModule :: String -> GHCi ()
634 state <- getGHCiState
635 dflags <- io getDynFlags
636 case targets state of
637 [] -> io (putStr "no current target\n")
639 -- do the dependency anal first, so that if it fails we don't throw
640 -- away the current set of modules.
641 graph <- io (cmDepAnal (cmstate state) dflags paths)
643 io (revertCAFs) -- always revert CAFs on reload.
645 <- io (cmLoadModules (cmstate state) dflags graph)
646 setGHCiState state{ cmstate=cmstate1 }
647 setContextAfterLoad mods
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 dflags <- io getDynFlags
675 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
676 setCmState new_cmstate
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 -- Browing 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
699 dflags <- io getDynFlags
701 is_interpreted <- io (cmModuleIsInterpreted cms m)
702 when (not is_interpreted && not exports_only) $
703 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
705 -- temporarily set the context to the module we're interested in,
706 -- just so we can get an appropriate PrintUnqualified
707 (as,bs) <- io (cmGetContext cms)
708 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
709 else cmSetContext cms dflags [m] [])
710 cms2 <- io (cmSetContext cms1 dflags as bs)
712 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
716 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
718 things' = filter wantToSee things
720 wantToSee (AnId id) = not (isImplicitId id)
721 wantToSee (ADataCon _) = False -- They'll come via their TyCon
724 thing_names = map getName things
726 thingDecl thing@(AnId id) = ifaceTyThing thing
728 thingDecl thing@(AClass c) =
729 let rn_decl = ifaceTyThing thing in
731 ClassDecl { tcdSigs = cons } ->
732 rn_decl{ tcdSigs = filter methodIsVisible cons }
735 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
737 thingDecl thing@(ATyCon t) =
738 let rn_decl = ifaceTyThing thing in
740 TyData { tcdCons = DataCons cons } ->
741 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
744 conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
746 io (putStrLn (showSDocForUser unqual (
747 vcat (map (ppr . thingDecl) things')))
752 -----------------------------------------------------------------------------
753 -- Setting the module context
756 | all sensible mods = fn mods
757 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
759 (fn, mods) = case str of
760 '+':stuff -> (addToContext, words stuff)
761 '-':stuff -> (removeFromContext, words stuff)
762 stuff -> (newContext, words stuff)
764 sensible ('*':m) = looksLikeModuleName m
765 sensible m = looksLikeModuleName m
769 dflags <- io getDynFlags
770 (as,bs) <- separate cms mods [] []
771 let bs' = if null as && prel `notElem` bs then prel:bs else bs
772 cms' <- io (cmSetContext cms dflags as bs')
775 separate cmstate [] as bs = return (as,bs)
776 separate cmstate (('*':m):ms) as bs = do
777 b <- io (cmModuleIsInterpreted cmstate m)
778 if b then separate cmstate ms (m:as) bs
779 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
780 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
785 addToContext mods = do
787 dflags <- io getDynFlags
788 (as,bs) <- io (cmGetContext cms)
790 (as',bs') <- separate cms mods [] []
792 let as_to_add = as' \\ (as ++ bs)
793 bs_to_add = bs' \\ (as ++ bs)
795 cms' <- io (cmSetContext cms dflags
796 (as ++ as_to_add) (bs ++ bs_to_add))
800 removeFromContext mods = do
802 dflags <- io getDynFlags
803 (as,bs) <- io (cmGetContext cms)
805 (as_to_remove,bs_to_remove) <- separate cms mods [] []
807 let as' = as \\ (as_to_remove ++ bs_to_remove)
808 bs' = bs \\ (as_to_remove ++ bs_to_remove)
810 cms' <- io (cmSetContext cms dflags as' bs')
813 ----------------------------------------------------------------------------
816 -- set options in the interpreter. Syntax is exactly the same as the
817 -- ghc command line, except that certain options aren't available (-C,
820 -- This is pretty fragile: most options won't work as expected. ToDo:
821 -- figure out which ones & disallow them.
823 setCmd :: String -> GHCi ()
825 = do st <- getGHCiState
826 let opts = options st
827 io $ putStrLn (showSDoc (
828 text "options currently set: " <>
831 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
835 ("args":args) -> setArgs args
836 ("prog":prog) -> setProg prog
837 wds -> setOptions wds
841 setGHCiState st{ args = args }
845 setGHCiState st{ progname = prog }
847 io (hPutStrLn stderr "syntax: :set prog <progname>")
850 do -- first, deal with the GHCi opts (+s, +t, etc.)
851 let (plus_opts, minus_opts) = partition isPlus wds
852 mapM_ setOpt plus_opts
854 -- now, the GHC flags
855 pkgs_before <- io (readIORef v_ExplicitPackages)
856 leftovers <- io (processArgs static_flags minus_opts [])
857 pkgs_after <- io (readIORef v_ExplicitPackages)
859 -- update things if the users wants more packages
860 let new_packages = pkgs_after \\ pkgs_before
861 when (not (null new_packages)) $
862 newPackages new_packages
864 -- don't forget about the extra command-line flags from the
865 -- extra_ghc_opts fields in the new packages
866 new_package_details <- io (getPackageDetails new_packages)
867 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
868 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
870 -- then, dynamic flags
873 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
876 if (not (null leftovers))
877 then throwDyn (CmdLineError ("unrecognised flags: " ++
882 unsetOptions :: String -> GHCi ()
884 = do -- first, deal with the GHCi opts (+s, +t, etc.)
886 (minus_opts, rest1) = partition isMinus opts
887 (plus_opts, rest2) = partition isPlus rest1
889 if (not (null rest2))
890 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
893 mapM_ unsetOpt plus_opts
895 -- can't do GHC flags for now
896 if (not (null minus_opts))
897 then throwDyn (CmdLineError "can't unset GHC command-line flags")
900 isMinus ('-':s) = True
903 isPlus ('+':s) = True
907 = case strToGHCiOpt str of
908 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
909 Just o -> setOption o
912 = case strToGHCiOpt str of
913 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
914 Just o -> unsetOption o
916 strToGHCiOpt :: String -> (Maybe GHCiOption)
917 strToGHCiOpt "s" = Just ShowTiming
918 strToGHCiOpt "t" = Just ShowType
919 strToGHCiOpt "r" = Just RevertCAFs
920 strToGHCiOpt _ = Nothing
922 optToStr :: GHCiOption -> String
923 optToStr ShowTiming = "s"
924 optToStr ShowType = "t"
925 optToStr RevertCAFs = "r"
927 newPackages new_pkgs = do -- The new packages are already in v_Packages
928 state <- getGHCiState
929 dflags <- io getDynFlags
930 cmstate1 <- io (cmUnload (cmstate state) dflags)
931 setGHCiState state{ cmstate = cmstate1, targets = [] }
932 io (linkPackages dflags new_pkgs)
933 setContextAfterLoad []
935 -- ---------------------------------------------------------------------------
940 ["modules" ] -> showModules
941 ["bindings"] -> showBindings
942 ["linker"] -> io showLinkerState
943 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
947 let (mg, hpt) = cmGetModInfo cms
948 mapM_ (showModule hpt) mg
951 showModule :: HomePackageTable -> ModSummary -> GHCi ()
952 showModule hpt mod_summary
953 = case lookupModuleEnv hpt mod of
954 Nothing -> panic "missing linkable"
955 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
957 obj_linkable = isObjectLinkable (hm_linkable mod_info)
959 mod = ms_mod mod_summary
960 locn = ms_location mod_summary
965 unqual = cmGetPrintUnqual cms
966 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
968 io (mapM_ showBinding (cmGetBindings cms))
972 -----------------------------------------------------------------------------
975 data GHCiState = GHCiState
979 targets :: [FilePath],
981 options :: [GHCiOption]
985 = ShowTiming -- show time/allocs after evaluation
986 | ShowType -- show the type of expressions
987 | RevertCAFs -- revert CAFs after every evaluation
990 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
992 startGHCi :: GHCi a -> GHCiState -> IO a
993 startGHCi g state = do ref <- newIORef state; unGHCi g ref
995 instance Monad GHCi where
996 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
997 return a = GHCi $ \s -> return a
999 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1000 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1001 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1003 getGHCiState = GHCi $ \r -> readIORef r
1004 setGHCiState s = GHCi $ \r -> writeIORef r s
1006 -- for convenience...
1007 getCmState = getGHCiState >>= return . cmstate
1008 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1010 isOptionSet :: GHCiOption -> GHCi Bool
1012 = do st <- getGHCiState
1013 return (opt `elem` options st)
1015 setOption :: GHCiOption -> GHCi ()
1017 = do st <- getGHCiState
1018 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1020 unsetOption :: GHCiOption -> GHCi ()
1022 = do st <- getGHCiState
1023 setGHCiState (st{ options = filter (/= opt) (options st) })
1025 io :: IO a -> GHCi a
1026 io m = GHCi { unGHCi = \s -> m >>= return }
1028 -----------------------------------------------------------------------------
1029 -- recursive exception handlers
1031 -- Don't forget to unblock async exceptions in the handler, or if we're
1032 -- in an exception loop (eg. let a = error a in a) the ^C exception
1033 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1035 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1036 ghciHandle h (GHCi m) = GHCi $ \s ->
1037 Exception.catch (m s)
1038 (\e -> unGHCi (ghciUnblock (h e)) s)
1040 ghciUnblock :: GHCi a -> GHCi a
1041 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1043 -----------------------------------------------------------------------------
1044 -- timing & statistics
1046 timeIt :: GHCi a -> GHCi a
1048 = do b <- isOptionSet ShowTiming
1051 else do allocs1 <- io $ getAllocations
1052 time1 <- io $ getCPUTime
1054 allocs2 <- io $ getAllocations
1055 time2 <- io $ getCPUTime
1056 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1059 foreign import ccall "getAllocations" getAllocations :: IO Int
1061 printTimes :: Int -> Integer -> IO ()
1062 printTimes allocs psecs
1063 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1064 secs_str = showFFloat (Just 2) secs
1065 putStrLn (showSDoc (
1066 parens (text (secs_str "") <+> text "secs" <> comma <+>
1067 int allocs <+> text "bytes")))
1069 -----------------------------------------------------------------------------
1076 -- Have to turn off buffering again, because we just
1077 -- reverted stdout, stderr & stdin to their defaults.
1079 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1080 -- Make it "safe", just in case
1082 -- -----------------------------------------------------------------------------
1085 expandPath :: String -> GHCi String
1087 case dropWhile isSpace path of
1089 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1090 return (tilde ++ '/':d)