1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.157 2003/07/21 14:33:19 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] -> IO ()
159 interactiveUI srcs = 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)
182 GHCiState{ progname = "<interactive>",
188 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
189 Readline.resetTerminal Nothing
194 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
195 runGHCi paths dflags = 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 -- enter the interactive loop
233 #if defined(mingw32_HOST_OS)
234 -- Always show prompt, since hIsTerminalDevice returns True for Consoles
235 -- only, which we may or may not be running under (cf. Emacs sub-shells.)
238 is_tty <- io (hIsTerminalDevice stdin)
239 interactiveLoop is_tty
243 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
246 interactiveLoop is_tty = do
247 -- Ignore ^C exceptions caught here
248 ghciHandleDyn (\e -> case e of
249 Interrupted -> ghciUnblock (interactiveLoop is_tty)
250 _other -> return ()) $ do
252 -- read commands from stdin
253 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
256 else fileLoop stdin False -- turn off prompt for non-TTY input
258 fileLoop stdin is_tty
262 -- NOTE: We only read .ghci files if they are owned by the current user,
263 -- and aren't world writable. Otherwise, we could be accidentally
264 -- running code planted by a malicious third party.
266 -- Furthermore, We only read ./.ghci if . is owned by the current user
267 -- and isn't writable by anyone else. I think this is sufficient: we
268 -- don't need to check .. and ../.. etc. because "." always refers to
269 -- the same directory while a process is running.
271 checkPerms :: String -> IO Bool
273 #ifdef mingw32_HOST_OS
276 DriverUtil.handle (\_ -> return False) $ do
277 st <- getFileStatus name
279 if fileOwner st /= me then do
280 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
283 let mode = fileMode st
284 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
285 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
287 putStrLn $ "*** WARNING: " ++ name ++
288 " is writable by someone else, IGNORING!"
293 fileLoop :: Handle -> Bool -> GHCi ()
294 fileLoop hdl prompt = do
295 cmstate <- getCmState
296 (mod,imports) <- io (cmGetContext cmstate)
297 when prompt (io (putStr (mkPrompt mod imports)))
298 l <- io (IO.try (hGetLine hdl))
300 Left e | isEOFError e -> return ()
301 | otherwise -> io (ioError e)
303 case remove_spaces l of
304 "" -> fileLoop hdl prompt
305 l -> do quit <- runCommand l
306 if quit then return () else fileLoop hdl prompt
308 stringLoop :: [String] -> GHCi ()
309 stringLoop [] = return ()
310 stringLoop (s:ss) = do
311 case remove_spaces s of
313 l -> do quit <- runCommand l
314 if quit then return () else stringLoop ss
316 mkPrompt toplevs exports
317 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
319 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
320 readlineLoop :: GHCi ()
322 cmstate <- getCmState
323 (mod,imports) <- io (cmGetContext cmstate)
325 l <- io (readline (mkPrompt mod imports)
326 `finally` setNonBlockingFD 0)
327 -- readline sometimes puts stdin into blocking mode,
328 -- so we need to put it back for the IO library
332 case remove_spaces l of
337 if quit then return () else readlineLoop
340 runCommand :: String -> GHCi Bool
341 runCommand c = ghciHandle handler (doCommand c)
343 -- This is the exception handler for exceptions generated by the
344 -- user's code; it normally just prints out the exception. The
345 -- handler must be recursive, in case showing the exception causes
346 -- more exceptions to be raised.
348 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
349 -- raising another exception. We therefore don't put the recursive
350 -- handler arond the flushing operation, so if stderr is closed
351 -- GHCi will just die gracefully rather than going into an infinite loop.
352 handler :: Exception -> GHCi Bool
353 handler exception = do
355 io installSignalHandlers
356 ghciHandle handler (showException exception >> return False)
358 showException (DynException dyn) =
359 case fromDynamic dyn of
360 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
361 Just Interrupted -> io (putStrLn "Interrupted.")
362 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
363 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
364 Just other_ghc_ex -> io (print other_ghc_ex)
366 showException other_exception
367 = io (putStrLn ("*** Exception: " ++ show other_exception))
369 doCommand (':' : command) = specialCommand command
371 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
374 runStmt :: String -> GHCi [Name]
376 | null (filter (not.isSpace) stmt) = return []
378 = do st <- getGHCiState
379 dflags <- io getDynFlags
380 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
381 (new_cmstate, result) <-
382 io $ withProgName (progname st) $ withArgs (args st) $
383 cmRunStmt (cmstate st) dflags' stmt
384 setGHCiState st{cmstate = new_cmstate}
386 CmRunFailed -> return []
387 CmRunException e -> showException e >> return []
388 CmRunOk names -> return names
390 -- possibly print the type and revert CAFs after evaluating an expression
392 = do b <- isOptionSet ShowType
393 cmstate <- getCmState
394 when b (mapM_ (showTypeOfName cmstate) names)
397 io installSignalHandlers
398 b <- isOptionSet RevertCAFs
399 io (when b revertCAFs)
402 showTypeOfName :: CmState -> Name -> GHCi ()
403 showTypeOfName cmstate n
404 = do maybe_str <- io (cmTypeOfName cmstate n)
407 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
409 specialCommand :: String -> GHCi Bool
410 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
411 specialCommand str = do
412 let (cmd,rest) = break isSpace str
413 cmds <- io (readIORef commands)
414 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
415 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
416 ++ shortHelpText) >> return False)
417 [(_,f)] -> f (dropWhile isSpace rest)
418 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
419 " matches multiple commands (" ++
420 foldr1 (\a b -> a ++ ',':b) (map fst cs)
421 ++ ")") >> return False)
423 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
426 -----------------------------------------------------------------------------
427 -- To flush buffers for the *interpreted* computation we need
428 -- to refer to *its* stdout/stderr handles
430 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
431 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
433 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
434 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
435 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
437 initInterpBuffering :: CmState -> DynFlags -> IO CmState
438 initInterpBuffering cmstate dflags
439 = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
442 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
443 other -> panic "interactiveUI:setBuffering"
445 (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
447 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
448 _ -> panic "interactiveUI:flush"
450 turnOffBuffering -- Turn it off right now
455 flushInterpBuffers :: GHCi ()
457 = io $ do Monad.join (readIORef flush_interp)
460 turnOffBuffering :: IO ()
462 = do Monad.join (readIORef turn_off_buffering)
465 -----------------------------------------------------------------------------
468 help :: String -> GHCi ()
469 help _ = io (putStr helpText)
471 info :: String -> GHCi ()
472 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
475 init_cms <- getCmState
476 dflags <- io getDynFlags
478 infoThings cms [] = return cms
479 infoThings cms (name:names) = do
480 (cms, stuff) <- io (cmInfoThing cms dflags name)
481 io (putStrLn (showSDocForUser unqual (
482 vcat (intersperse (text "") (map showThing stuff))))
486 unqual = cmGetPrintUnqual init_cms
488 showThing (ty_thing, fixity)
489 = vcat [ text "-- " <> showTyThing ty_thing,
490 showFixity fixity (getName ty_thing),
491 ppr (ifaceTyThing ty_thing) ]
494 | fix == defaultFixity = empty
495 | otherwise = ppr fix <+>
496 (if isSymOcc (nameOccName name)
498 else char '`' <> ppr name <> char '`')
500 showTyThing (AClass cl)
501 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
502 showTyThing (ADataCon dc)
503 = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
504 showTyThing (ATyCon ty)
506 = hcat [ppr ty, text " is a primitive type constructor"]
508 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
509 showTyThing (AnId id)
510 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
513 = case globalIdDetails id of
514 RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
515 ClassOpId cls -> text "method in class" <+> ppr cls
516 otherwise -> text "variable"
518 -- also print out the source location for home things
520 | isHomePackageName name && isGoodSrcLoc loc
521 = hsep [ text ", defined at", ppr loc ]
524 where loc = nameSrcLoc name
526 cms <- infoThings init_cms names
530 addModule :: [FilePath] -> GHCi ()
532 state <- getGHCiState
533 dflags <- io (getDynFlags)
534 io (revertCAFs) -- always revert CAFs on load/add.
535 files <- mapM expandPath files
536 let new_targets = files ++ targets state
537 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
538 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
539 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
540 setContextAfterLoad mods
541 modulesLoadedMsg ok mods dflags
543 changeDirectory :: String -> GHCi ()
544 changeDirectory dir = do
545 state <- getGHCiState
546 when (targets state /= []) $
547 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\
548 \because the search path has changed.\n"
549 dflags <- io getDynFlags
550 cmstate1 <- io (cmUnload (cmstate state) dflags)
551 setGHCiState state{ cmstate = cmstate1, targets = [] }
552 setContextAfterLoad []
553 dir <- expandPath dir
554 io (setCurrentDirectory dir)
556 defineMacro :: String -> GHCi ()
558 let (macro_name, definition) = break isSpace s
559 cmds <- io (readIORef commands)
561 then throwDyn (CmdLineError "invalid macro name")
563 if (macro_name `elem` map fst cmds)
564 then throwDyn (CmdLineError
565 ("command `" ++ macro_name ++ "' is already defined"))
568 -- give the expression a type signature, so we can be sure we're getting
569 -- something of the right type.
570 let new_expr = '(' : definition ++ ") :: String -> IO String"
572 -- compile the expression
574 dflags <- io getDynFlags
575 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
576 setCmState new_cmstate
579 Just hv -> io (writeIORef commands --
580 ((macro_name, keepGoing (runMacro hv)) : cmds))
582 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
584 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
585 stringLoop (lines str)
587 undefineMacro :: String -> GHCi ()
588 undefineMacro macro_name = do
589 cmds <- io (readIORef commands)
590 if (macro_name `elem` map fst builtin_commands)
591 then throwDyn (CmdLineError
592 ("command `" ++ macro_name ++ "' cannot be undefined"))
594 if (macro_name `notElem` map fst cmds)
595 then throwDyn (CmdLineError
596 ("command `" ++ macro_name ++ "' not defined"))
598 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
601 loadModule :: [FilePath] -> GHCi ()
602 loadModule fs = timeIt (loadModule' fs)
604 loadModule' :: [FilePath] -> GHCi ()
605 loadModule' files = do
606 state <- getGHCiState
607 dflags <- io getDynFlags
610 files <- mapM expandPath files
612 -- do the dependency anal first, so that if it fails we don't throw
613 -- away the current set of modules.
614 graph <- io (cmDepAnal (cmstate state) dflags files)
616 -- Dependency anal ok, now unload everything
617 cmstate1 <- io (cmUnload (cmstate state) dflags)
618 setGHCiState state{ cmstate = cmstate1, targets = [] }
620 io (revertCAFs) -- always revert CAFs on load.
621 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
622 setGHCiState state{ cmstate = cmstate2, targets = files }
624 setContextAfterLoad mods
625 modulesLoadedMsg ok mods dflags
628 reloadModule :: String -> GHCi ()
630 state <- getGHCiState
631 dflags <- io getDynFlags
632 case targets state of
633 [] -> io (putStr "no current target\n")
635 -- do the dependency anal first, so that if it fails we don't throw
636 -- away the current set of modules.
637 graph <- io (cmDepAnal (cmstate state) dflags paths)
639 io (revertCAFs) -- always revert CAFs on reload.
641 <- io (cmLoadModules (cmstate state) dflags graph)
642 setGHCiState state{ cmstate=cmstate1 }
643 setContextAfterLoad mods
644 modulesLoadedMsg ok mods dflags
646 reloadModule _ = noArgs ":reload"
648 setContextAfterLoad [] = setContext prel
649 setContextAfterLoad (m:_) = do
650 cmstate <- getCmState
651 b <- io (cmModuleIsInterpreted cmstate m)
652 if b then setContext ('*':m) else setContext m
654 modulesLoadedMsg ok mods dflags =
655 when (verbosity dflags > 0) $ do
657 | null mods = text "none."
659 punctuate comma (map text mods)) <> text "."
662 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
664 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
667 typeOfExpr :: String -> GHCi ()
669 = do cms <- getCmState
670 dflags <- io getDynFlags
671 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
672 setCmState new_cmstate
675 Just tystr -> io (putStrLn tystr)
677 quit :: String -> GHCi Bool
680 shellEscape :: String -> GHCi Bool
681 shellEscape str = io (system str >> return False)
683 -----------------------------------------------------------------------------
684 -- Browing a module's contents
686 browseCmd :: String -> GHCi ()
689 ['*':m] | looksLikeModuleName m -> browseModule m False
690 [m] | looksLikeModuleName m -> browseModule m True
691 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
693 browseModule m exports_only = do
695 dflags <- io getDynFlags
697 is_interpreted <- io (cmModuleIsInterpreted cms m)
698 when (not is_interpreted && not exports_only) $
699 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
701 -- temporarily set the context to the module we're interested in,
702 -- just so we can get an appropriate PrintUnqualified
703 (as,bs) <- io (cmGetContext cms)
704 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
705 else cmSetContext cms dflags [m] [])
706 cms2 <- io (cmSetContext cms1 dflags as bs)
708 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
712 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
714 things' = filter wantToSee things
716 wantToSee (AnId id) = not (isImplicitId id)
717 wantToSee (ADataCon _) = False -- They'll come via their TyCon
720 thing_names = map getName things
722 thingDecl thing@(AnId id) = ifaceTyThing thing
724 thingDecl thing@(AClass c) =
725 let rn_decl = ifaceTyThing thing in
727 ClassDecl { tcdSigs = cons } ->
728 rn_decl{ tcdSigs = filter methodIsVisible cons }
731 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
733 thingDecl thing@(ATyCon t) =
734 let rn_decl = ifaceTyThing thing in
736 TyData { tcdCons = DataCons cons } ->
737 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
740 conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
742 io (putStrLn (showSDocForUser unqual (
743 vcat (map (ppr . thingDecl) things')))
748 -----------------------------------------------------------------------------
749 -- Setting the module context
752 | all sensible mods = fn mods
753 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
755 (fn, mods) = case str of
756 '+':stuff -> (addToContext, words stuff)
757 '-':stuff -> (removeFromContext, words stuff)
758 stuff -> (newContext, words stuff)
760 sensible ('*':m) = looksLikeModuleName m
761 sensible m = looksLikeModuleName m
765 dflags <- io getDynFlags
766 (as,bs) <- separate cms mods [] []
767 let bs' = if null as && prel `notElem` bs then prel:bs else bs
768 cms' <- io (cmSetContext cms dflags as bs')
771 separate cmstate [] as bs = return (as,bs)
772 separate cmstate (('*':m):ms) as bs = do
773 b <- io (cmModuleIsInterpreted cmstate m)
774 if b then separate cmstate ms (m:as) bs
775 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
776 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
781 addToContext mods = do
783 dflags <- io getDynFlags
784 (as,bs) <- io (cmGetContext cms)
786 (as',bs') <- separate cms mods [] []
788 let as_to_add = as' \\ (as ++ bs)
789 bs_to_add = bs' \\ (as ++ bs)
791 cms' <- io (cmSetContext cms dflags
792 (as ++ as_to_add) (bs ++ bs_to_add))
796 removeFromContext mods = do
798 dflags <- io getDynFlags
799 (as,bs) <- io (cmGetContext cms)
801 (as_to_remove,bs_to_remove) <- separate cms mods [] []
803 let as' = as \\ (as_to_remove ++ bs_to_remove)
804 bs' = bs \\ (as_to_remove ++ bs_to_remove)
806 cms' <- io (cmSetContext cms dflags as' bs')
809 ----------------------------------------------------------------------------
812 -- set options in the interpreter. Syntax is exactly the same as the
813 -- ghc command line, except that certain options aren't available (-C,
816 -- This is pretty fragile: most options won't work as expected. ToDo:
817 -- figure out which ones & disallow them.
819 setCmd :: String -> GHCi ()
821 = do st <- getGHCiState
822 let opts = options st
823 io $ putStrLn (showSDoc (
824 text "options currently set: " <>
827 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
831 ("args":args) -> setArgs args
832 ("prog":prog) -> setProg prog
833 wds -> setOptions wds
837 setGHCiState st{ args = args }
841 setGHCiState st{ progname = prog }
843 io (hPutStrLn stderr "syntax: :set prog <progname>")
846 do -- first, deal with the GHCi opts (+s, +t, etc.)
847 let (plus_opts, minus_opts) = partition isPlus wds
848 mapM_ setOpt plus_opts
850 -- now, the GHC flags
851 pkgs_before <- io (readIORef v_ExplicitPackages)
852 leftovers <- io (processArgs static_flags minus_opts [])
853 pkgs_after <- io (readIORef v_ExplicitPackages)
855 -- update things if the users wants more packages
856 let new_packages = pkgs_after \\ pkgs_before
857 when (not (null new_packages)) $
858 newPackages new_packages
860 -- don't forget about the extra command-line flags from the
861 -- extra_ghc_opts fields in the new packages
862 new_package_details <- io (getPackageDetails new_packages)
863 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
864 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
866 -- then, dynamic flags
869 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
872 if (not (null leftovers))
873 then throwDyn (CmdLineError ("unrecognised flags: " ++
878 unsetOptions :: String -> GHCi ()
880 = do -- first, deal with the GHCi opts (+s, +t, etc.)
882 (minus_opts, rest1) = partition isMinus opts
883 (plus_opts, rest2) = partition isPlus rest1
885 if (not (null rest2))
886 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
889 mapM_ unsetOpt plus_opts
891 -- can't do GHC flags for now
892 if (not (null minus_opts))
893 then throwDyn (CmdLineError "can't unset GHC command-line flags")
896 isMinus ('-':s) = True
899 isPlus ('+':s) = True
903 = case strToGHCiOpt str of
904 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
905 Just o -> setOption o
908 = case strToGHCiOpt str of
909 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
910 Just o -> unsetOption o
912 strToGHCiOpt :: String -> (Maybe GHCiOption)
913 strToGHCiOpt "s" = Just ShowTiming
914 strToGHCiOpt "t" = Just ShowType
915 strToGHCiOpt "r" = Just RevertCAFs
916 strToGHCiOpt _ = Nothing
918 optToStr :: GHCiOption -> String
919 optToStr ShowTiming = "s"
920 optToStr ShowType = "t"
921 optToStr RevertCAFs = "r"
923 newPackages new_pkgs = do -- The new packages are already in v_Packages
924 state <- getGHCiState
925 dflags <- io getDynFlags
926 cmstate1 <- io (cmUnload (cmstate state) dflags)
927 setGHCiState state{ cmstate = cmstate1, targets = [] }
928 io (linkPackages dflags new_pkgs)
929 setContextAfterLoad []
931 -- ---------------------------------------------------------------------------
936 ["modules" ] -> showModules
937 ["bindings"] -> showBindings
938 ["linker"] -> io showLinkerState
939 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
943 let (mg, hpt) = cmGetModInfo cms
944 mapM_ (showModule hpt) mg
947 showModule :: HomePackageTable -> ModSummary -> GHCi ()
948 showModule hpt mod_summary
949 = case lookupModuleEnv hpt mod of
950 Nothing -> panic "missing linkable"
951 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
953 obj_linkable = isObjectLinkable (hm_linkable mod_info)
955 mod = ms_mod mod_summary
956 locn = ms_location mod_summary
961 unqual = cmGetPrintUnqual cms
962 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
964 io (mapM_ showBinding (cmGetBindings cms))
968 -----------------------------------------------------------------------------
971 data GHCiState = GHCiState
975 targets :: [FilePath],
977 options :: [GHCiOption]
981 = ShowTiming -- show time/allocs after evaluation
982 | ShowType -- show the type of expressions
983 | RevertCAFs -- revert CAFs after every evaluation
986 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
988 startGHCi :: GHCi a -> GHCiState -> IO a
989 startGHCi g state = do ref <- newIORef state; unGHCi g ref
991 instance Monad GHCi where
992 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
993 return a = GHCi $ \s -> return a
995 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
996 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
997 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
999 getGHCiState = GHCi $ \r -> readIORef r
1000 setGHCiState s = GHCi $ \r -> writeIORef r s
1002 -- for convenience...
1003 getCmState = getGHCiState >>= return . cmstate
1004 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1006 isOptionSet :: GHCiOption -> GHCi Bool
1008 = do st <- getGHCiState
1009 return (opt `elem` options st)
1011 setOption :: GHCiOption -> GHCi ()
1013 = do st <- getGHCiState
1014 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1016 unsetOption :: GHCiOption -> GHCi ()
1018 = do st <- getGHCiState
1019 setGHCiState (st{ options = filter (/= opt) (options st) })
1021 io :: IO a -> GHCi a
1022 io m = GHCi { unGHCi = \s -> m >>= return }
1024 -----------------------------------------------------------------------------
1025 -- recursive exception handlers
1027 -- Don't forget to unblock async exceptions in the handler, or if we're
1028 -- in an exception loop (eg. let a = error a in a) the ^C exception
1029 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1031 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1032 ghciHandle h (GHCi m) = GHCi $ \s ->
1033 Exception.catch (m s)
1034 (\e -> unGHCi (ghciUnblock (h e)) s)
1036 ghciUnblock :: GHCi a -> GHCi a
1037 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1039 -----------------------------------------------------------------------------
1040 -- timing & statistics
1042 timeIt :: GHCi a -> GHCi a
1044 = do b <- isOptionSet ShowTiming
1047 else do allocs1 <- io $ getAllocations
1048 time1 <- io $ getCPUTime
1050 allocs2 <- io $ getAllocations
1051 time2 <- io $ getCPUTime
1052 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1055 foreign import ccall "getAllocations" getAllocations :: IO Int
1057 printTimes :: Int -> Integer -> IO ()
1058 printTimes allocs psecs
1059 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1060 secs_str = showFFloat (Just 2) secs
1061 putStrLn (showSDoc (
1062 parens (text (secs_str "") <+> text "secs" <> comma <+>
1063 int allocs <+> text "bytes")))
1065 -----------------------------------------------------------------------------
1072 -- Have to turn off buffering again, because we just
1073 -- reverted stdout, stderr & stdin to their defaults.
1075 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1076 -- Make it "safe", just in case
1078 -- -----------------------------------------------------------------------------
1081 expandPath :: String -> GHCi String
1083 case dropWhile isSpace path of
1085 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1086 return (tilde ++ '/':d)