1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.153 2003/05/19 15:39:17 simonpj 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, handle )
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
49 #if __GLASGOW_HASKELL__ > 504
54 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
55 import Control.Concurrent ( yield ) -- Used in readline loop
56 import System.Console.Readline as Readline
61 import Control.Exception as Exception
63 import Control.Concurrent
69 import System.Environment
70 import System.Directory
71 import System.IO as IO
73 import Control.Monad as Monad
75 import GHC.Exts ( unsafeCoerce# )
77 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
79 import System.Posix.Internals ( setNonBlockingFD )
81 -----------------------------------------------------------------------------
85 \ / _ \\ /\\ /\\/ __(_)\n\
86 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
87 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
88 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
90 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
92 builtin_commands :: [(String, String -> GHCi Bool)]
94 ("add", keepGoingPaths addModule),
95 ("browse", keepGoing browseCmd),
96 ("cd", keepGoing changeDirectory),
97 ("def", keepGoing defineMacro),
98 ("help", keepGoing help),
99 ("?", keepGoing help),
100 ("info", keepGoing info),
101 ("load", keepGoingPaths loadModule),
102 ("module", keepGoing setContext),
103 ("reload", keepGoing reloadModule),
104 ("set", keepGoing setCmd),
105 ("show", keepGoing showCmd),
106 ("type", keepGoing typeOfExpr),
107 ("unset", keepGoing unsetOptions),
108 ("undef", keepGoing undefineMacro),
112 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
113 keepGoing a str = a str >> return False
115 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
116 keepGoingPaths a str = a (toArgs str) >> return False
118 shortHelpText = "use :? for help.\n"
120 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
122 \ Commands available from the prompt:\n\
124 \ <stmt> evaluate/run <stmt>\n\
125 \ :add <filename> ... add module(s) to the current target set\n\
126 \ :browse [*]<module> display the names defined by <module>\n\
127 \ :cd <dir> change directory to <dir>\n\
128 \ :def <cmd> <expr> define a command :<cmd>\n\
129 \ :help, :? display this list of commands\n\
130 \ :info [<name> ...] display information about the given names\n\
131 \ :load <filename> ... load module(s) and their dependents\n\
132 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
133 \ :reload reload the current module set\n\
135 \ :set <option> ... set options\n\
136 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
137 \ :set prog <progname> set the value returned by System.getProgName\n\
139 \ :show modules show the currently loaded modules\n\
140 \ :show bindings show the current bindings made at the prompt\n\
142 \ :type <expr> show the type of <expr>\n\
143 \ :undef <cmd> undefine user-defined command :<cmd>\n\
144 \ :unset <option> ... unset options\n\
146 \ :!<command> run the shell command <command>\n\
148 \ Options for `:set' and `:unset':\n\
150 \ +r revert top-level expressions after each evaluation\n\
151 \ +s print timing/memory stats after each evaluation\n\
152 \ +t print type after evaluation\n\
153 \ -<flags> most GHC command line flags can also be set here\n\
154 \ (eg. -v2, -fglasgow-exts, etc.)\n\
157 interactiveUI :: [FilePath] -> IO ()
158 interactiveUI srcs = do
159 dflags <- getDynFlags
160 saveDynFlags -- Save the dynamic flags, so that
161 -- the later restore will find them
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 dir <- expandPath dir
546 io (setCurrentDirectory dir)
548 defineMacro :: String -> GHCi ()
550 let (macro_name, definition) = break isSpace s
551 cmds <- io (readIORef commands)
553 then throwDyn (CmdLineError "invalid macro name")
555 if (macro_name `elem` map fst cmds)
556 then throwDyn (CmdLineError
557 ("command `" ++ macro_name ++ "' is already defined"))
560 -- give the expression a type signature, so we can be sure we're getting
561 -- something of the right type.
562 let new_expr = '(' : definition ++ ") :: String -> IO String"
564 -- compile the expression
566 dflags <- io getDynFlags
567 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
568 setCmState new_cmstate
571 Just hv -> io (writeIORef commands --
572 ((macro_name, keepGoing (runMacro hv)) : cmds))
574 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
576 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
577 stringLoop (lines str)
579 undefineMacro :: String -> GHCi ()
580 undefineMacro macro_name = do
581 cmds <- io (readIORef commands)
582 if (macro_name `elem` map fst builtin_commands)
583 then throwDyn (CmdLineError
584 ("command `" ++ macro_name ++ "' cannot be undefined"))
586 if (macro_name `notElem` map fst cmds)
587 then throwDyn (CmdLineError
588 ("command `" ++ macro_name ++ "' not defined"))
590 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
593 loadModule :: [FilePath] -> GHCi ()
594 loadModule fs = timeIt (loadModule' fs)
596 loadModule' :: [FilePath] -> GHCi ()
597 loadModule' files = do
598 state <- getGHCiState
599 dflags <- io getDynFlags
602 files <- mapM expandPath files
604 -- do the dependency anal first, so that if it fails we don't throw
605 -- away the current set of modules.
606 graph <- io (cmDepAnal (cmstate state) dflags files)
608 -- Dependency anal ok, now unload everything
609 cmstate1 <- io (cmUnload (cmstate state) dflags)
610 setGHCiState state{ cmstate = cmstate1, targets = [] }
612 io (revertCAFs) -- always revert CAFs on load.
613 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
614 setGHCiState state{ cmstate = cmstate2, targets = files }
616 setContextAfterLoad mods
617 modulesLoadedMsg ok mods dflags
620 reloadModule :: String -> GHCi ()
622 state <- getGHCiState
623 dflags <- io getDynFlags
624 case targets state of
625 [] -> io (putStr "no current target\n")
627 -- do the dependency anal first, so that if it fails we don't throw
628 -- away the current set of modules.
629 graph <- io (cmDepAnal (cmstate state) dflags paths)
631 io (revertCAFs) -- always revert CAFs on reload.
633 <- io (cmLoadModules (cmstate state) dflags graph)
634 setGHCiState state{ cmstate=cmstate1 }
635 setContextAfterLoad mods
636 modulesLoadedMsg ok mods dflags
638 reloadModule _ = noArgs ":reload"
640 setContextAfterLoad [] = setContext prel
641 setContextAfterLoad (m:_) = do
642 cmstate <- getCmState
643 b <- io (cmModuleIsInterpreted cmstate m)
644 if b then setContext ('*':m) else setContext m
646 modulesLoadedMsg ok mods dflags =
647 when (verbosity dflags > 0) $ do
649 | null mods = text "none."
651 punctuate comma (map text mods)) <> text "."
654 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
656 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
659 typeOfExpr :: String -> GHCi ()
661 = do cms <- getCmState
662 dflags <- io getDynFlags
663 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
664 setCmState new_cmstate
667 Just tystr -> io (putStrLn tystr)
669 quit :: String -> GHCi Bool
672 shellEscape :: String -> GHCi Bool
673 shellEscape str = io (system str >> return False)
675 -----------------------------------------------------------------------------
676 -- Browing a module's contents
678 browseCmd :: String -> GHCi ()
681 ['*':m] | looksLikeModuleName m -> browseModule m False
682 [m] | looksLikeModuleName m -> browseModule m True
683 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
685 browseModule m exports_only = do
687 dflags <- io getDynFlags
689 is_interpreted <- io (cmModuleIsInterpreted cms m)
690 when (not is_interpreted && not exports_only) $
691 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
693 -- temporarily set the context to the module we're interested in,
694 -- just so we can get an appropriate PrintUnqualified
695 (as,bs) <- io (cmGetContext cms)
696 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
697 else cmSetContext cms dflags [m] [])
698 cms2 <- io (cmSetContext cms1 dflags as bs)
700 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
704 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
706 things' = filter wantToSee things
708 wantToSee (AnId id) = not (isImplicitId id)
709 wantToSee (ADataCon _) = False -- They'll come via their TyCon
712 thing_names = map getName things
714 thingDecl thing@(AnId id) = ifaceTyThing thing
716 thingDecl thing@(AClass c) =
717 let rn_decl = ifaceTyThing thing in
719 ClassDecl { tcdSigs = cons } ->
720 rn_decl{ tcdSigs = filter methodIsVisible cons }
723 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
725 thingDecl thing@(ATyCon t) =
726 let rn_decl = ifaceTyThing thing in
728 TyData { tcdCons = DataCons cons } ->
729 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
732 conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
734 io (putStrLn (showSDocForUser unqual (
735 vcat (map (ppr . thingDecl) things')))
740 -----------------------------------------------------------------------------
741 -- Setting the module context
744 | all sensible mods = fn mods
745 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
747 (fn, mods) = case str of
748 '+':stuff -> (addToContext, words stuff)
749 '-':stuff -> (removeFromContext, words stuff)
750 stuff -> (newContext, words stuff)
752 sensible ('*':m) = looksLikeModuleName m
753 sensible m = looksLikeModuleName m
757 dflags <- io getDynFlags
758 (as,bs) <- separate cms mods [] []
759 let bs' = if null as && prel `notElem` bs then prel:bs else bs
760 cms' <- io (cmSetContext cms dflags as bs')
763 separate cmstate [] as bs = return (as,bs)
764 separate cmstate (('*':m):ms) as bs = do
765 b <- io (cmModuleIsInterpreted cmstate m)
766 if b then separate cmstate ms (m:as) bs
767 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
768 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
773 addToContext mods = do
775 dflags <- io getDynFlags
776 (as,bs) <- io (cmGetContext cms)
778 (as',bs') <- separate cms mods [] []
780 let as_to_add = as' \\ (as ++ bs)
781 bs_to_add = bs' \\ (as ++ bs)
783 cms' <- io (cmSetContext cms dflags
784 (as ++ as_to_add) (bs ++ bs_to_add))
788 removeFromContext mods = do
790 dflags <- io getDynFlags
791 (as,bs) <- io (cmGetContext cms)
793 (as_to_remove,bs_to_remove) <- separate cms mods [] []
795 let as' = as \\ (as_to_remove ++ bs_to_remove)
796 bs' = bs \\ (as_to_remove ++ bs_to_remove)
798 cms' <- io (cmSetContext cms dflags as' bs')
801 ----------------------------------------------------------------------------
804 -- set options in the interpreter. Syntax is exactly the same as the
805 -- ghc command line, except that certain options aren't available (-C,
808 -- This is pretty fragile: most options won't work as expected. ToDo:
809 -- figure out which ones & disallow them.
811 setCmd :: String -> GHCi ()
813 = do st <- getGHCiState
814 let opts = options st
815 io $ putStrLn (showSDoc (
816 text "options currently set: " <>
819 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
823 ("args":args) -> setArgs args
824 ("prog":prog) -> setProg prog
825 wds -> setOptions wds
829 setGHCiState st{ args = args }
833 setGHCiState st{ progname = prog }
835 io (hPutStrLn stderr "syntax: :set prog <progname>")
838 do -- first, deal with the GHCi opts (+s, +t, etc.)
839 let (plus_opts, minus_opts) = partition isPlus wds
840 mapM_ setOpt plus_opts
842 -- now, the GHC flags
843 pkgs_before <- io (readIORef v_ExplicitPackages)
844 leftovers <- io (processArgs static_flags minus_opts [])
845 pkgs_after <- io (readIORef v_ExplicitPackages)
847 -- update things if the users wants more packages
848 let new_packages = pkgs_after \\ pkgs_before
849 when (not (null new_packages)) $
850 newPackages new_packages
852 -- don't forget about the extra command-line flags from the
853 -- extra_ghc_opts fields in the new packages
854 new_package_details <- io (getPackageDetails new_packages)
855 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
856 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
858 -- then, dynamic flags
861 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
864 if (not (null leftovers))
865 then throwDyn (CmdLineError ("unrecognised flags: " ++
870 unsetOptions :: String -> GHCi ()
872 = do -- first, deal with the GHCi opts (+s, +t, etc.)
874 (minus_opts, rest1) = partition isMinus opts
875 (plus_opts, rest2) = partition isPlus rest1
877 if (not (null rest2))
878 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
881 mapM_ unsetOpt plus_opts
883 -- can't do GHC flags for now
884 if (not (null minus_opts))
885 then throwDyn (CmdLineError "can't unset GHC command-line flags")
888 isMinus ('-':s) = True
891 isPlus ('+':s) = True
895 = case strToGHCiOpt str of
896 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
897 Just o -> setOption o
900 = case strToGHCiOpt str of
901 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
902 Just o -> unsetOption o
904 strToGHCiOpt :: String -> (Maybe GHCiOption)
905 strToGHCiOpt "s" = Just ShowTiming
906 strToGHCiOpt "t" = Just ShowType
907 strToGHCiOpt "r" = Just RevertCAFs
908 strToGHCiOpt _ = Nothing
910 optToStr :: GHCiOption -> String
911 optToStr ShowTiming = "s"
912 optToStr ShowType = "t"
913 optToStr RevertCAFs = "r"
915 newPackages new_pkgs = do -- The new packages are already in v_Packages
916 state <- getGHCiState
917 dflags <- io getDynFlags
918 cmstate1 <- io (cmUnload (cmstate state) dflags)
919 setGHCiState state{ cmstate = cmstate1, targets = [] }
920 io (linkPackages dflags new_pkgs)
921 setContextAfterLoad []
923 -- ---------------------------------------------------------------------------
928 ["modules" ] -> showModules
929 ["bindings"] -> showBindings
930 ["linker"] -> io showLinkerState
931 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
935 let (mg, hpt) = cmGetModInfo cms
936 mapM_ (showModule hpt) mg
939 showModule :: HomePackageTable -> ModSummary -> GHCi ()
940 showModule hpt mod_summary
941 = case lookupModuleEnv hpt mod of
942 Nothing -> panic "missing linkable"
943 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
945 obj_linkable = isObjectLinkable (hm_linkable mod_info)
947 mod = ms_mod mod_summary
948 locn = ms_location mod_summary
953 unqual = cmGetPrintUnqual cms
954 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
956 io (mapM_ showBinding (cmGetBindings cms))
960 -----------------------------------------------------------------------------
963 data GHCiState = GHCiState
967 targets :: [FilePath],
969 options :: [GHCiOption]
973 = ShowTiming -- show time/allocs after evaluation
974 | ShowType -- show the type of expressions
975 | RevertCAFs -- revert CAFs after every evaluation
978 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
980 startGHCi :: GHCi a -> GHCiState -> IO a
981 startGHCi g state = do ref <- newIORef state; unGHCi g ref
983 instance Monad GHCi where
984 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
985 return a = GHCi $ \s -> return a
987 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
988 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
989 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
991 getGHCiState = GHCi $ \r -> readIORef r
992 setGHCiState s = GHCi $ \r -> writeIORef r s
994 -- for convenience...
995 getCmState = getGHCiState >>= return . cmstate
996 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
998 isOptionSet :: GHCiOption -> GHCi Bool
1000 = do st <- getGHCiState
1001 return (opt `elem` options st)
1003 setOption :: GHCiOption -> GHCi ()
1005 = do st <- getGHCiState
1006 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1008 unsetOption :: GHCiOption -> GHCi ()
1010 = do st <- getGHCiState
1011 setGHCiState (st{ options = filter (/= opt) (options st) })
1013 io :: IO a -> GHCi a
1014 io m = GHCi { unGHCi = \s -> m >>= return }
1016 -----------------------------------------------------------------------------
1017 -- recursive exception handlers
1019 -- Don't forget to unblock async exceptions in the handler, or if we're
1020 -- in an exception loop (eg. let a = error a in a) the ^C exception
1021 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1023 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1024 ghciHandle h (GHCi m) = GHCi $ \s ->
1025 Exception.catch (m s)
1026 (\e -> unGHCi (ghciUnblock (h e)) s)
1028 ghciUnblock :: GHCi a -> GHCi a
1029 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1031 -----------------------------------------------------------------------------
1032 -- timing & statistics
1034 timeIt :: GHCi a -> GHCi a
1036 = do b <- isOptionSet ShowTiming
1039 else do allocs1 <- io $ getAllocations
1040 time1 <- io $ getCPUTime
1042 allocs2 <- io $ getAllocations
1043 time2 <- io $ getCPUTime
1044 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1047 foreign import ccall "getAllocations" getAllocations :: IO Int
1049 printTimes :: Int -> Integer -> IO ()
1050 printTimes allocs psecs
1051 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1052 secs_str = showFFloat (Just 2) secs
1053 putStrLn (showSDoc (
1054 parens (text (secs_str "") <+> text "secs" <> comma <+>
1055 int allocs <+> text "bytes")))
1057 -----------------------------------------------------------------------------
1064 -- Have to turn off buffering again, because we just
1065 -- reverted stdout, stderr & stdin to their defaults.
1067 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1068 -- Make it "safe", just in case
1070 -- -----------------------------------------------------------------------------
1073 expandPath :: String -> GHCi String
1075 case dropWhile isSpace path of
1077 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1078 return (tilde ++ '/':d)