1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.160 2003/09/23 14:32:58 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 True{-omit prags-} 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 True{-omit prags-} thing
728 thingDecl thing@(AClass c) =
729 let rn_decl = ifaceTyThing True{-omit prags-} 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 True{-omit prags-} 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')))
750 -----------------------------------------------------------------------------
751 -- Setting the module context
754 | all sensible mods = fn mods
755 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
757 (fn, mods) = case str of
758 '+':stuff -> (addToContext, words stuff)
759 '-':stuff -> (removeFromContext, words stuff)
760 stuff -> (newContext, words stuff)
762 sensible ('*':m) = looksLikeModuleName m
763 sensible m = looksLikeModuleName m
767 dflags <- io getDynFlags
768 (as,bs) <- separate cms mods [] []
769 let bs' = if null as && prel `notElem` bs then prel:bs else bs
770 cms' <- io (cmSetContext cms dflags as bs')
773 separate cmstate [] as bs = return (as,bs)
774 separate cmstate (('*':m):ms) as bs = do
775 b <- io (cmModuleIsInterpreted cmstate m)
776 if b then separate cmstate ms (m:as) bs
777 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
778 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
783 addToContext mods = do
785 dflags <- io getDynFlags
786 (as,bs) <- io (cmGetContext cms)
788 (as',bs') <- separate cms mods [] []
790 let as_to_add = as' \\ (as ++ bs)
791 bs_to_add = bs' \\ (as ++ bs)
793 cms' <- io (cmSetContext cms dflags
794 (as ++ as_to_add) (bs ++ bs_to_add))
798 removeFromContext mods = do
800 dflags <- io getDynFlags
801 (as,bs) <- io (cmGetContext cms)
803 (as_to_remove,bs_to_remove) <- separate cms mods [] []
805 let as' = as \\ (as_to_remove ++ bs_to_remove)
806 bs' = bs \\ (as_to_remove ++ bs_to_remove)
808 cms' <- io (cmSetContext cms dflags as' bs')
811 ----------------------------------------------------------------------------
814 -- set options in the interpreter. Syntax is exactly the same as the
815 -- ghc command line, except that certain options aren't available (-C,
818 -- This is pretty fragile: most options won't work as expected. ToDo:
819 -- figure out which ones & disallow them.
821 setCmd :: String -> GHCi ()
823 = do st <- getGHCiState
824 let opts = options st
825 io $ putStrLn (showSDoc (
826 text "options currently set: " <>
829 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
833 ("args":args) -> setArgs args
834 ("prog":prog) -> setProg prog
835 wds -> setOptions wds
839 setGHCiState st{ args = args }
843 setGHCiState st{ progname = prog }
845 io (hPutStrLn stderr "syntax: :set prog <progname>")
848 do -- first, deal with the GHCi opts (+s, +t, etc.)
849 let (plus_opts, minus_opts) = partition isPlus wds
850 mapM_ setOpt plus_opts
852 -- now, the GHC flags
853 pkgs_before <- io (readIORef v_ExplicitPackages)
854 leftovers <- io (processArgs static_flags minus_opts [])
855 pkgs_after <- io (readIORef v_ExplicitPackages)
857 -- update things if the users wants more packages
858 let new_packages = pkgs_after \\ pkgs_before
859 when (not (null new_packages)) $
860 newPackages new_packages
862 -- don't forget about the extra command-line flags from the
863 -- extra_ghc_opts fields in the new packages
864 new_package_details <- io (getPackageDetails new_packages)
865 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
866 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
868 -- then, dynamic flags
871 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
874 if (not (null leftovers))
875 then throwDyn (CmdLineError ("unrecognised flags: " ++
880 unsetOptions :: String -> GHCi ()
882 = do -- first, deal with the GHCi opts (+s, +t, etc.)
884 (minus_opts, rest1) = partition isMinus opts
885 (plus_opts, rest2) = partition isPlus rest1
887 if (not (null rest2))
888 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
891 mapM_ unsetOpt plus_opts
893 -- can't do GHC flags for now
894 if (not (null minus_opts))
895 then throwDyn (CmdLineError "can't unset GHC command-line flags")
898 isMinus ('-':s) = True
901 isPlus ('+':s) = True
905 = case strToGHCiOpt str of
906 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
907 Just o -> setOption o
910 = case strToGHCiOpt str of
911 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
912 Just o -> unsetOption o
914 strToGHCiOpt :: String -> (Maybe GHCiOption)
915 strToGHCiOpt "s" = Just ShowTiming
916 strToGHCiOpt "t" = Just ShowType
917 strToGHCiOpt "r" = Just RevertCAFs
918 strToGHCiOpt _ = Nothing
920 optToStr :: GHCiOption -> String
921 optToStr ShowTiming = "s"
922 optToStr ShowType = "t"
923 optToStr RevertCAFs = "r"
925 newPackages new_pkgs = do -- The new packages are already in v_Packages
926 state <- getGHCiState
927 dflags <- io getDynFlags
928 cmstate1 <- io (cmUnload (cmstate state) dflags)
929 setGHCiState state{ cmstate = cmstate1, targets = [] }
930 io (linkPackages dflags new_pkgs)
931 setContextAfterLoad []
933 -- ---------------------------------------------------------------------------
938 ["modules" ] -> showModules
939 ["bindings"] -> showBindings
940 ["linker"] -> io showLinkerState
941 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
945 let (mg, hpt) = cmGetModInfo cms
946 mapM_ (showModule hpt) mg
949 showModule :: HomePackageTable -> ModSummary -> GHCi ()
950 showModule hpt mod_summary
951 = case lookupModuleEnv hpt mod of
952 Nothing -> panic "missing linkable"
953 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
955 obj_linkable = isObjectLinkable (hm_linkable mod_info)
957 mod = ms_mod mod_summary
958 locn = ms_location mod_summary
963 unqual = cmGetPrintUnqual cms
964 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing True{-omit prags-} b)))
966 io (mapM_ showBinding (cmGetBindings cms))
970 -----------------------------------------------------------------------------
973 data GHCiState = GHCiState
977 targets :: [FilePath],
979 options :: [GHCiOption]
983 = ShowTiming -- show time/allocs after evaluation
984 | ShowType -- show the type of expressions
985 | RevertCAFs -- revert CAFs after every evaluation
988 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
990 startGHCi :: GHCi a -> GHCiState -> IO a
991 startGHCi g state = do ref <- newIORef state; unGHCi g ref
993 instance Monad GHCi where
994 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
995 return a = GHCi $ \s -> return a
997 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
998 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
999 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1001 getGHCiState = GHCi $ \r -> readIORef r
1002 setGHCiState s = GHCi $ \r -> writeIORef r s
1004 -- for convenience...
1005 getCmState = getGHCiState >>= return . cmstate
1006 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1008 isOptionSet :: GHCiOption -> GHCi Bool
1010 = do st <- getGHCiState
1011 return (opt `elem` options st)
1013 setOption :: GHCiOption -> GHCi ()
1015 = do st <- getGHCiState
1016 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1018 unsetOption :: GHCiOption -> GHCi ()
1020 = do st <- getGHCiState
1021 setGHCiState (st{ options = filter (/= opt) (options st) })
1023 io :: IO a -> GHCi a
1024 io m = GHCi { unGHCi = \s -> m >>= return }
1026 -----------------------------------------------------------------------------
1027 -- recursive exception handlers
1029 -- Don't forget to unblock async exceptions in the handler, or if we're
1030 -- in an exception loop (eg. let a = error a in a) the ^C exception
1031 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1033 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1034 ghciHandle h (GHCi m) = GHCi $ \s ->
1035 Exception.catch (m s)
1036 (\e -> unGHCi (ghciUnblock (h e)) s)
1038 ghciUnblock :: GHCi a -> GHCi a
1039 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1041 -----------------------------------------------------------------------------
1042 -- timing & statistics
1044 timeIt :: GHCi a -> GHCi a
1046 = do b <- isOptionSet ShowTiming
1049 else do allocs1 <- io $ getAllocations
1050 time1 <- io $ getCPUTime
1052 allocs2 <- io $ getAllocations
1053 time2 <- io $ getCPUTime
1054 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1057 foreign import ccall "getAllocations" getAllocations :: IO Int
1059 printTimes :: Int -> Integer -> IO ()
1060 printTimes allocs psecs
1061 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1062 secs_str = showFFloat (Just 2) secs
1063 putStrLn (showSDoc (
1064 parens (text (secs_str "") <+> text "secs" <> comma <+>
1065 int allocs <+> text "bytes")))
1067 -----------------------------------------------------------------------------
1074 -- Have to turn off buffering again, because we just
1075 -- reverted stdout, stderr & stdin to their defaults.
1077 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1078 -- Make it "safe", just in case
1080 -- -----------------------------------------------------------------------------
1083 expandPath :: String -> GHCi String
1085 case dropWhile isSpace path of
1087 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1088 return (tilde ++ '/':d)