1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.149 2003/03/03 12:30:11 simonmar Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2000
9 -----------------------------------------------------------------------------
10 module InteractiveUI (
11 interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
15 #include "../includes/config.h"
16 #include "HsVersions.h"
19 import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
21 import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
22 import MkIface ( ifaceTyThing )
25 import DriverUtil ( remove_spaces, handle )
26 import Linker ( initLinker, showLinkerState, linkLibraries,
29 import IdInfo ( GlobalIdDetails(..) )
30 import Id ( isImplicitId, idName, globalIdDetails )
31 import Class ( className )
32 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
33 import DataCon ( dataConName )
34 import FieldLabel ( fieldLabelTyCon )
35 import SrcLoc ( isGoodSrcLoc )
36 import Module ( showModMsg, lookupModuleEnv )
37 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
39 import OccName ( isSymOcc )
40 import BasicTypes ( defaultFixity, SuccessFlag(..) )
43 import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
44 restoreDynFlags, dopt_unset )
45 import Panic hiding ( showException )
48 #ifndef mingw32_HOST_OS
50 #if __GLASGOW_HASKELL__ > 504
55 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
56 import Control.Concurrent ( yield ) -- Used in readline loop
57 import System.Console.Readline as Readline
62 import Control.Exception as Exception
64 import Control.Concurrent
70 import System.Environment
71 import System.Directory
72 import System.IO as IO
74 import Control.Monad as Monad
76 import GHC.Exts ( unsafeCoerce# )
78 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
80 import GHC.Posix ( setNonBlockingFD )
82 -----------------------------------------------------------------------------
86 \ / _ \\ /\\ /\\/ __(_)\n\
87 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
88 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
89 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
91 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
93 builtin_commands :: [(String, String -> GHCi Bool)]
95 ("add", keepGoingPaths addModule),
96 ("browse", keepGoing browseCmd),
97 ("cd", keepGoing changeDirectory),
98 ("def", keepGoing defineMacro),
99 ("help", keepGoing help),
100 ("?", keepGoing help),
101 ("info", keepGoing info),
102 ("load", keepGoingPaths loadModule),
103 ("module", keepGoing setContext),
104 ("reload", keepGoing reloadModule),
105 ("set", keepGoing setCmd),
106 ("show", keepGoing showCmd),
107 ("type", keepGoing typeOfExpr),
108 ("unset", keepGoing unsetOptions),
109 ("undef", keepGoing undefineMacro),
113 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
114 keepGoing a str = a str >> return False
116 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
117 keepGoingPaths a str = a (toArgs str) >> return False
119 shortHelpText = "use :? for help.\n"
121 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
123 \ Commands available from the prompt:\n\
125 \ <stmt> evaluate/run <stmt>\n\
126 \ :add <filename> ... add module(s) to the current target set\n\
127 \ :browse [*]<module> display the names defined by <module>\n\
128 \ :cd <dir> change directory to <dir>\n\
129 \ :def <cmd> <expr> define a command :<cmd>\n\
130 \ :help, :? display this list of commands\n\
131 \ :info [<name> ...] display information about the given names\n\
132 \ :load <filename> ... load module(s) and their dependents\n\
133 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
134 \ :reload reload the current module set\n\
136 \ :set <option> ... set options\n\
137 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
138 \ :set prog <progname> set the value returned by System.getProgName\n\
140 \ :show modules show the currently loaded modules\n\
141 \ :show bindings show the current bindings made at the prompt\n\
143 \ :type <expr> show the type of <expr>\n\
144 \ :undef <cmd> undefine user-defined command :<cmd>\n\
145 \ :unset <option> ... unset options\n\
147 \ :!<command> run the shell command <command>\n\
149 \ Options for `:set' and `:unset':\n\
151 \ +r revert top-level expressions after each evaluation\n\
152 \ +s print timing/memory stats after each evaluation\n\
153 \ +t print type after evaluation\n\
154 \ -<flags> most GHC command line flags can also be set here\n\
155 \ (eg. -v2, -fglasgow-exts, etc.)\n\
158 interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO ()
159 interactiveUI cmstate paths cmdline_objs = do
161 hSetBuffering stdout NoBuffering
163 dflags <- getDynFlags
167 -- link packages requested explicitly on the command-line
168 expl <- readIORef v_ExplicitPackages
169 linkPackages dflags expl
171 -- link libraries from the command-line
172 linkLibraries dflags cmdline_objs
174 -- Initialise buffering for the *interpreted* I/O system
175 cmstate <- initInterpBuffering cmstate dflags
177 -- We don't want the cmd line to buffer any input that might be
178 -- intended for the program, so unbuffer stdin.
179 hSetBuffering stdin NoBuffering
181 -- initial context is just the Prelude
182 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
184 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
188 startGHCi (runGHCi paths dflags)
189 GHCiState{ progname = "<interactive>",
195 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
196 Readline.resetTerminal Nothing
201 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
202 runGHCi paths dflags = do
203 read_dot_files <- io (readIORef v_Read_DotGHCi)
205 when (read_dot_files) $ do
208 exists <- io (doesFileExist file)
210 dir_ok <- io (checkPerms ".")
211 file_ok <- io (checkPerms file)
212 when (dir_ok && file_ok) $ do
213 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
216 Right hdl -> fileLoop hdl False
218 when (read_dot_files) $ do
219 -- Read in $HOME/.ghci
220 either_dir <- io (IO.try (getEnv "HOME"))
224 cwd <- io (getCurrentDirectory)
225 when (dir /= cwd) $ do
226 let file = dir ++ "/.ghci"
227 ok <- io (checkPerms file)
229 either_hdl <- io (IO.try (openFile file ReadMode))
232 Right hdl -> fileLoop hdl False
234 -- perform a :load for files given on the GHCi command line
235 when (not (null paths)) $
236 ghciHandle showException $
239 -- enter the interactive loop
240 #if defined(mingw32_HOST_OS)
241 -- always show prompt, since hIsTerminalDevice returns True for Consoles
242 -- only, which we may or may not be running under (cf. Emacs sub-shells.)
245 is_tty <- io (hIsTerminalDevice stdin)
246 interactiveLoop is_tty
250 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
253 interactiveLoop is_tty = do
254 -- ignore ^C exceptions caught here
255 ghciHandleDyn (\e -> case e of
256 Interrupted -> ghciUnblock (interactiveLoop is_tty)
257 _other -> return ()) $ do
259 -- read commands from stdin
260 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
263 else fileLoop stdin False -- turn off prompt for non-TTY input
265 fileLoop stdin is_tty
269 -- NOTE: We only read .ghci files if they are owned by the current user,
270 -- and aren't world writable. Otherwise, we could be accidentally
271 -- running code planted by a malicious third party.
273 -- Furthermore, We only read ./.ghci if . is owned by the current user
274 -- and isn't writable by anyone else. I think this is sufficient: we
275 -- don't need to check .. and ../.. etc. because "." always refers to
276 -- the same directory while a process is running.
278 checkPerms :: String -> IO Bool
280 #ifdef mingw32_HOST_OS
283 DriverUtil.handle (\_ -> return False) $ do
284 st <- getFileStatus name
286 if fileOwner st /= me then do
287 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
290 let mode = fileMode st
291 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
292 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
294 putStrLn $ "*** WARNING: " ++ name ++
295 " is writable by someone else, IGNORING!"
300 fileLoop :: Handle -> Bool -> GHCi ()
301 fileLoop hdl prompt = do
302 cmstate <- getCmState
303 (mod,imports) <- io (cmGetContext cmstate)
304 when prompt (io (putStr (mkPrompt mod imports)))
305 l <- io (IO.try (hGetLine hdl))
307 Left e | isEOFError e -> return ()
308 | otherwise -> io (ioError e)
310 case remove_spaces l of
311 "" -> fileLoop hdl prompt
312 l -> do quit <- runCommand l
313 if quit then return () else fileLoop hdl prompt
315 stringLoop :: [String] -> GHCi ()
316 stringLoop [] = return ()
317 stringLoop (s:ss) = do
318 case remove_spaces s of
320 l -> do quit <- runCommand l
321 if quit then return () else stringLoop ss
323 mkPrompt toplevs exports
324 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
326 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
327 readlineLoop :: GHCi ()
329 cmstate <- getCmState
330 (mod,imports) <- io (cmGetContext cmstate)
332 l <- io (readline (mkPrompt mod imports)
333 `finally` setNonBlockingFD 0)
334 -- readline sometimes puts stdin into blocking mode,
335 -- so we need to put it back for the IO library
339 case remove_spaces l of
344 if quit then return () else readlineLoop
347 runCommand :: String -> GHCi Bool
348 runCommand c = ghciHandle handler (doCommand c)
350 -- This is the exception handler for exceptions generated by the
351 -- user's code; it normally just prints out the exception. The
352 -- handler must be recursive, in case showing the exception causes
353 -- more exceptions to be raised.
355 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
356 -- raising another exception. We therefore don't put the recursive
357 -- handler arond the flushing operation, so if stderr is closed
358 -- GHCi will just die gracefully rather than going into an infinite loop.
359 handler :: Exception -> GHCi Bool
360 handler exception = do
362 io installSignalHandlers
363 ghciHandle handler (showException exception >> return False)
365 showException (DynException dyn) =
366 case fromDynamic dyn of
367 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
368 Just Interrupted -> io (putStrLn "Interrupted.")
369 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
370 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
371 Just other_ghc_ex -> io (print other_ghc_ex)
373 showException other_exception
374 = io (putStrLn ("*** Exception: " ++ show other_exception))
376 doCommand (':' : command) = specialCommand command
378 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
381 runStmt :: String -> GHCi [Name]
383 | null (filter (not.isSpace) stmt) = return []
385 = do st <- getGHCiState
386 dflags <- io getDynFlags
387 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
388 (new_cmstate, result) <-
389 io $ withProgName (progname st) $ withArgs (args st) $
390 cmRunStmt (cmstate st) dflags' stmt
391 setGHCiState st{cmstate = new_cmstate}
393 CmRunFailed -> return []
394 CmRunException e -> showException e >> return []
395 CmRunOk names -> return names
397 -- possibly print the type and revert CAFs after evaluating an expression
399 = do b <- isOptionSet ShowType
400 cmstate <- getCmState
401 when b (mapM_ (showTypeOfName cmstate) names)
404 io installSignalHandlers
405 b <- isOptionSet RevertCAFs
406 io (when b revertCAFs)
409 showTypeOfName :: CmState -> Name -> GHCi ()
410 showTypeOfName cmstate n
411 = do maybe_str <- io (cmTypeOfName cmstate n)
414 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
416 specialCommand :: String -> GHCi Bool
417 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
418 specialCommand str = do
419 let (cmd,rest) = break isSpace str
420 cmds <- io (readIORef commands)
421 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
422 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
423 ++ shortHelpText) >> return False)
424 [(_,f)] -> f (dropWhile isSpace rest)
425 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
426 " matches multiple commands (" ++
427 foldr1 (\a b -> a ++ ',':b) (map fst cs)
428 ++ ")") >> return False)
430 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
433 -----------------------------------------------------------------------------
434 -- To flush buffers for the *interpreted* computation we need
435 -- to refer to *its* stdout/stderr handles
437 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
438 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
440 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
441 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
442 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
444 initInterpBuffering :: CmState -> DynFlags -> IO CmState
445 initInterpBuffering cmstate dflags
446 = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
449 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
450 other -> panic "interactiveUI:setBuffering"
452 (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
454 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
455 _ -> panic "interactiveUI:flush"
457 turnOffBuffering -- Turn it off right now
462 flushInterpBuffers :: GHCi ()
464 = io $ do Monad.join (readIORef flush_interp)
467 turnOffBuffering :: IO ()
469 = do Monad.join (readIORef turn_off_buffering)
472 -----------------------------------------------------------------------------
475 help :: String -> GHCi ()
476 help _ = io (putStr helpText)
478 info :: String -> GHCi ()
479 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
482 init_cms <- getCmState
483 dflags <- io getDynFlags
485 infoThings cms [] = return cms
486 infoThings cms (name:names) = do
487 (cms, stuff) <- io (cmInfoThing cms dflags name)
488 io (putStrLn (showSDocForUser unqual (
489 vcat (intersperse (text "") (map showThing stuff))))
493 unqual = cmGetPrintUnqual init_cms
495 showThing (ty_thing, fixity)
496 = vcat [ text "-- " <> showTyThing ty_thing,
497 showFixity fixity (getName ty_thing),
498 ppr (ifaceTyThing ty_thing) ]
501 | fix == defaultFixity = empty
502 | otherwise = ppr fix <+>
503 (if isSymOcc (nameOccName name)
505 else char '`' <> ppr name <> char '`')
507 showTyThing (AClass cl)
508 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
509 showTyThing (ADataCon dc)
510 = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
511 showTyThing (ATyCon ty)
513 = hcat [ppr ty, text " is a primitive type constructor"]
515 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
516 showTyThing (AnId id)
517 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
520 = case globalIdDetails id of
521 RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
522 ClassOpId cls -> text "method in class" <+> ppr cls
523 otherwise -> text "variable"
525 -- also print out the source location for home things
527 | isHomePackageName name && isGoodSrcLoc loc
528 = hsep [ text ", defined at", ppr loc ]
531 where loc = nameSrcLoc name
533 cms <- infoThings init_cms names
537 addModule :: [FilePath] -> GHCi ()
539 state <- getGHCiState
540 dflags <- io (getDynFlags)
541 io (revertCAFs) -- always revert CAFs on load/add.
542 let new_targets = files ++ targets state
543 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
544 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
545 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
546 setContextAfterLoad mods
547 modulesLoadedMsg ok mods dflags
549 changeDirectory :: String -> GHCi ()
550 changeDirectory ('~':d) = do
551 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
552 io (setCurrentDirectory (tilde ++ '/':d))
553 changeDirectory d = io (setCurrentDirectory d)
555 defineMacro :: String -> GHCi ()
557 let (macro_name, definition) = break isSpace s
558 cmds <- io (readIORef commands)
560 then throwDyn (CmdLineError "invalid macro name")
562 if (macro_name `elem` map fst cmds)
563 then throwDyn (CmdLineError
564 ("command `" ++ macro_name ++ "' is already defined"))
567 -- give the expression a type signature, so we can be sure we're getting
568 -- something of the right type.
569 let new_expr = '(' : definition ++ ") :: String -> IO String"
571 -- compile the expression
573 dflags <- io getDynFlags
574 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
575 setCmState new_cmstate
578 Just hv -> io (writeIORef commands --
579 ((macro_name, keepGoing (runMacro hv)) : cmds))
581 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
583 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
584 stringLoop (lines str)
586 undefineMacro :: String -> GHCi ()
587 undefineMacro macro_name = do
588 cmds <- io (readIORef commands)
589 if (macro_name `elem` map fst builtin_commands)
590 then throwDyn (CmdLineError
591 ("command `" ++ macro_name ++ "' cannot be undefined"))
593 if (macro_name `notElem` map fst cmds)
594 then throwDyn (CmdLineError
595 ("command `" ++ macro_name ++ "' not defined"))
597 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
600 loadModule :: [FilePath] -> GHCi ()
601 loadModule fs = timeIt (loadModule' fs)
603 loadModule' :: [FilePath] -> GHCi ()
604 loadModule' files = do
605 state <- getGHCiState
606 dflags <- io getDynFlags
608 -- do the dependency anal first, so that if it fails we don't throw
609 -- away the current set of modules.
610 graph <- io (cmDepAnal (cmstate state) dflags files)
612 -- Dependency anal ok, now unload everything
613 cmstate1 <- io (cmUnload (cmstate state) dflags)
614 setGHCiState state{ cmstate = cmstate1, targets = [] }
616 io (revertCAFs) -- always revert CAFs on load.
617 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
618 setGHCiState state{ cmstate = cmstate2, targets = files }
620 setContextAfterLoad mods
621 modulesLoadedMsg ok mods dflags
624 reloadModule :: String -> GHCi ()
626 state <- getGHCiState
627 dflags <- io getDynFlags
628 case targets state of
629 [] -> io (putStr "no current target\n")
631 -- do the dependency anal first, so that if it fails we don't throw
632 -- away the current set of modules.
633 graph <- io (cmDepAnal (cmstate state) dflags paths)
635 io (revertCAFs) -- always revert CAFs on reload.
637 <- io (cmLoadModules (cmstate state) dflags graph)
638 setGHCiState state{ cmstate=cmstate1 }
639 setContextAfterLoad mods
640 modulesLoadedMsg ok mods dflags
642 reloadModule _ = noArgs ":reload"
644 setContextAfterLoad [] = setContext prel
645 setContextAfterLoad (m:_) = do
646 cmstate <- getCmState
647 b <- io (cmModuleIsInterpreted cmstate m)
648 if b then setContext ('*':m) else setContext m
650 modulesLoadedMsg ok mods dflags =
651 when (verbosity dflags > 0) $ do
653 | null mods = text "none."
655 punctuate comma (map text mods)) <> text "."
658 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
660 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
663 typeOfExpr :: String -> GHCi ()
665 = do cms <- getCmState
666 dflags <- io getDynFlags
667 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
668 setCmState new_cmstate
671 Just tystr -> io (putStrLn tystr)
673 quit :: String -> GHCi Bool
676 shellEscape :: String -> GHCi Bool
677 shellEscape str = io (system str >> return False)
679 -----------------------------------------------------------------------------
680 -- Browing a module's contents
682 browseCmd :: String -> GHCi ()
685 ['*':m] | looksLikeModuleName m -> browseModule m False
686 [m] | looksLikeModuleName m -> browseModule m True
687 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
689 browseModule m exports_only = do
691 dflags <- io getDynFlags
693 is_interpreted <- io (cmModuleIsInterpreted cms m)
694 when (not is_interpreted && not exports_only) $
695 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
697 -- temporarily set the context to the module we're interested in,
698 -- just so we can get an appropriate PrintUnqualified
699 (as,bs) <- io (cmGetContext cms)
700 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
701 else cmSetContext cms dflags [m] [])
702 cms2 <- io (cmSetContext cms1 dflags as bs)
704 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
708 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
710 things' = filter wantToSee things
712 wantToSee (AnId id) = not (isImplicitId id)
713 wantToSee (ADataCon _) = False -- They'll come via their TyCon
716 thing_names = map getName things
718 thingDecl thing@(AnId id) = ifaceTyThing thing
720 thingDecl thing@(AClass c) =
721 let rn_decl = ifaceTyThing thing in
723 ClassDecl { tcdSigs = cons } ->
724 rn_decl{ tcdSigs = filter methodIsVisible cons }
727 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
729 thingDecl thing@(ATyCon t) =
730 let rn_decl = ifaceTyThing thing in
732 TyData { tcdCons = DataCons cons } ->
733 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
736 conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
738 io (putStrLn (showSDocForUser unqual (
739 vcat (map (ppr . thingDecl) things')))
744 -----------------------------------------------------------------------------
745 -- Setting the module context
748 | all sensible mods = fn mods
749 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
751 (fn, mods) = case str of
752 '+':stuff -> (addToContext, words stuff)
753 '-':stuff -> (removeFromContext, words stuff)
754 stuff -> (newContext, words stuff)
756 sensible ('*':m) = looksLikeModuleName m
757 sensible m = looksLikeModuleName m
761 dflags <- io getDynFlags
762 (as,bs) <- separate cms mods [] []
763 let bs' = if null as && prel `notElem` bs then prel:bs else bs
764 cms' <- io (cmSetContext cms dflags as bs')
767 separate cmstate [] as bs = return (as,bs)
768 separate cmstate (('*':m):ms) as bs = do
769 b <- io (cmModuleIsInterpreted cmstate m)
770 if b then separate cmstate ms (m:as) bs
771 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
772 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
777 addToContext mods = do
779 dflags <- io getDynFlags
780 (as,bs) <- io (cmGetContext cms)
782 (as',bs') <- separate cms mods [] []
784 let as_to_add = as' \\ (as ++ bs)
785 bs_to_add = bs' \\ (as ++ bs)
787 cms' <- io (cmSetContext cms dflags
788 (as ++ as_to_add) (bs ++ bs_to_add))
792 removeFromContext mods = do
794 dflags <- io getDynFlags
795 (as,bs) <- io (cmGetContext cms)
797 (as_to_remove,bs_to_remove) <- separate cms mods [] []
799 let as' = as \\ (as_to_remove ++ bs_to_remove)
800 bs' = bs \\ (as_to_remove ++ bs_to_remove)
802 cms' <- io (cmSetContext cms dflags as' bs')
805 ----------------------------------------------------------------------------
808 -- set options in the interpreter. Syntax is exactly the same as the
809 -- ghc command line, except that certain options aren't available (-C,
812 -- This is pretty fragile: most options won't work as expected. ToDo:
813 -- figure out which ones & disallow them.
815 setCmd :: String -> GHCi ()
817 = do st <- getGHCiState
818 let opts = options st
819 io $ putStrLn (showSDoc (
820 text "options currently set: " <>
823 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
827 ("args":args) -> setArgs args
828 ("prog":prog) -> setProg prog
829 wds -> setOptions wds
833 setGHCiState st{ args = args }
837 setGHCiState st{ progname = prog }
839 io (hPutStrLn stderr "syntax: :set prog <progname>")
842 do -- first, deal with the GHCi opts (+s, +t, etc.)
843 let (plus_opts, minus_opts) = partition isPlus wds
844 mapM_ setOpt plus_opts
846 -- now, the GHC flags
847 pkgs_before <- io (readIORef v_ExplicitPackages)
848 leftovers <- io (processArgs static_flags minus_opts [])
849 pkgs_after <- io (readIORef v_ExplicitPackages)
851 -- update things if the users wants more packages
852 let new_packages = pkgs_after \\ pkgs_before
853 when (not (null new_packages)) $
854 newPackages new_packages
856 -- don't forget about the extra command-line flags from the
857 -- extra_ghc_opts fields in the new packages
858 new_package_details <- io (getPackageDetails new_packages)
859 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
860 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
862 -- then, dynamic flags
865 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
868 if (not (null leftovers))
869 then throwDyn (CmdLineError ("unrecognised flags: " ++
874 unsetOptions :: String -> GHCi ()
876 = do -- first, deal with the GHCi opts (+s, +t, etc.)
878 (minus_opts, rest1) = partition isMinus opts
879 (plus_opts, rest2) = partition isPlus rest1
881 if (not (null rest2))
882 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
885 mapM_ unsetOpt plus_opts
887 -- can't do GHC flags for now
888 if (not (null minus_opts))
889 then throwDyn (CmdLineError "can't unset GHC command-line flags")
892 isMinus ('-':s) = True
895 isPlus ('+':s) = True
899 = case strToGHCiOpt str of
900 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
901 Just o -> setOption o
904 = case strToGHCiOpt str of
905 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
906 Just o -> unsetOption o
908 strToGHCiOpt :: String -> (Maybe GHCiOption)
909 strToGHCiOpt "s" = Just ShowTiming
910 strToGHCiOpt "t" = Just ShowType
911 strToGHCiOpt "r" = Just RevertCAFs
912 strToGHCiOpt _ = Nothing
914 optToStr :: GHCiOption -> String
915 optToStr ShowTiming = "s"
916 optToStr ShowType = "t"
917 optToStr RevertCAFs = "r"
919 newPackages new_pkgs = do -- The new packages are already in v_Packages
920 state <- getGHCiState
921 dflags <- io getDynFlags
922 cmstate1 <- io (cmUnload (cmstate state) dflags)
923 setGHCiState state{ cmstate = cmstate1, targets = [] }
924 io (linkPackages dflags new_pkgs)
925 setContextAfterLoad []
927 -- ---------------------------------------------------------------------------
932 ["modules" ] -> showModules
933 ["bindings"] -> showBindings
934 ["linker"] -> io showLinkerState
935 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
939 let (mg, hpt) = cmGetModInfo cms
940 mapM_ (showModule hpt) mg
943 showModule :: HomePackageTable -> ModSummary -> GHCi ()
944 showModule hpt mod_summary
945 = case lookupModuleEnv hpt mod of
946 Nothing -> panic "missing linkable"
947 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
949 obj_linkable = isObjectLinkable (hm_linkable mod_info)
951 mod = ms_mod mod_summary
952 locn = ms_location mod_summary
957 unqual = cmGetPrintUnqual cms
958 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
960 io (mapM_ showBinding (cmGetBindings cms))
964 -----------------------------------------------------------------------------
967 data GHCiState = GHCiState
971 targets :: [FilePath],
973 options :: [GHCiOption]
977 = ShowTiming -- show time/allocs after evaluation
978 | ShowType -- show the type of expressions
979 | RevertCAFs -- revert CAFs after every evaluation
982 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
984 startGHCi :: GHCi a -> GHCiState -> IO a
985 startGHCi g state = do ref <- newIORef state; unGHCi g ref
987 instance Monad GHCi where
988 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
989 return a = GHCi $ \s -> return a
991 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
992 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
993 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
995 getGHCiState = GHCi $ \r -> readIORef r
996 setGHCiState s = GHCi $ \r -> writeIORef r s
998 -- for convenience...
999 getCmState = getGHCiState >>= return . cmstate
1000 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1002 isOptionSet :: GHCiOption -> GHCi Bool
1004 = do st <- getGHCiState
1005 return (opt `elem` options st)
1007 setOption :: GHCiOption -> GHCi ()
1009 = do st <- getGHCiState
1010 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1012 unsetOption :: GHCiOption -> GHCi ()
1014 = do st <- getGHCiState
1015 setGHCiState (st{ options = filter (/= opt) (options st) })
1017 io :: IO a -> GHCi a
1018 io m = GHCi { unGHCi = \s -> m >>= return }
1020 -----------------------------------------------------------------------------
1021 -- recursive exception handlers
1023 -- Don't forget to unblock async exceptions in the handler, or if we're
1024 -- in an exception loop (eg. let a = error a in a) the ^C exception
1025 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1027 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1028 ghciHandle h (GHCi m) = GHCi $ \s ->
1029 Exception.catch (m s)
1030 (\e -> unGHCi (ghciUnblock (h e)) s)
1032 ghciUnblock :: GHCi a -> GHCi a
1033 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1035 -----------------------------------------------------------------------------
1036 -- timing & statistics
1038 timeIt :: GHCi a -> GHCi a
1040 = do b <- isOptionSet ShowTiming
1043 else do allocs1 <- io $ getAllocations
1044 time1 <- io $ getCPUTime
1046 allocs2 <- io $ getAllocations
1047 time2 <- io $ getCPUTime
1048 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1051 foreign import ccall "getAllocations" getAllocations :: IO Int
1053 printTimes :: Int -> Integer -> IO ()
1054 printTimes allocs psecs
1055 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1056 secs_str = showFFloat (Just 2) secs
1057 putStrLn (showSDoc (
1058 parens (text (secs_str "") <+> text "secs" <> comma <+>
1059 int allocs <+> text "bytes")))
1061 -----------------------------------------------------------------------------
1068 -- Have to turn off buffering again, because we just
1069 -- reverted stdout, stderr & stdin to their defaults.
1071 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1072 -- Make it "safe", just in case