1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
16 #if defined(GHCI) && defined(BREAKPOINT)
17 import GHC.Exts ( Int(..), Ptr(..), int2Addr# )
18 import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
19 import System.IO.Unsafe ( unsafePerformIO )
20 import Var ( Id, globaliseId, idName, idType )
21 import HscTypes ( Session(..), InteractiveContext(..), HscEnv(..)
22 , extendTypeEnvWithIds )
23 import RdrName ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv )
24 import NameEnv ( delListFromNameEnv )
25 import TcType ( tidyTopType )
26 import qualified Id ( setIdType )
27 import IdInfo ( GlobalIdDetails(..) )
28 import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker )
29 import PrelNames ( breakpointJumpName )
34 import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..),
35 TargetId(..), DynFlags(..),
36 pprModule, Type, Module, SuccessFlag(..),
37 TyThing(..), Name, LoadHowMuch(..), Phase,
38 GhcException(..), showGhcException,
39 CheckedModule(..), SrcLoc )
40 import DynFlags ( allFlags )
41 import Packages ( PackageState(..) )
42 import PackageConfig ( InstalledPackageInfo(..) )
43 import UniqFM ( eltsUFM )
47 -- for createtags (should these come via GHC?)
48 import Module ( moduleString )
49 import Name ( nameSrcLoc, nameModule, nameOccName )
50 import OccName ( pprOccName )
51 import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
53 -- Other random utilities
54 import Digraph ( flattenSCCs )
55 import BasicTypes ( failed, successIf )
56 import Panic ( panic, installSignalHandlers )
58 import StaticFlags ( opt_IgnoreDotGhci )
59 import Linker ( showLinkerState )
60 import Util ( removeSpaces, handle, global, toArgs,
61 looksLikeModuleName, prefixMatch, sortLe )
63 #ifndef mingw32_HOST_OS
65 #if __GLASGOW_HASKELL__ > 504
69 import GHC.ConsoleHandler ( flushConsole )
73 import Control.Concurrent ( yield ) -- Used in readline loop
74 import System.Console.Readline as Readline
79 import Control.Exception as Exception
81 -- import Control.Concurrent
85 import Data.Int ( Int64 )
86 import Data.Maybe ( isJust, fromMaybe, catMaybes )
89 import System.Environment
90 import System.Exit ( exitWith, ExitCode(..) )
91 import System.Directory
93 import System.IO.Error as IO
95 import Control.Monad as Monad
96 import Foreign.StablePtr ( newStablePtr )
99 import GHC.Exts ( unsafeCoerce# )
100 import GHC.IOBase ( IOErrorType(InvalidArgument) )
102 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
104 import System.Posix.Internals ( setNonBlockingFD )
106 -----------------------------------------------------------------------------
110 " / _ \\ /\\ /\\/ __(_)\n"++
111 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
112 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
113 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
115 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
116 cmdName (n,_,_,_) = n
118 GLOBAL_VAR(commands, builtin_commands, [Command])
120 builtin_commands :: [Command]
122 ("add", keepGoingPaths addModule, False, completeFilename),
123 ("browse", keepGoing browseCmd, False, completeModule),
124 ("cd", keepGoing changeDirectory, False, completeFilename),
125 ("def", keepGoing defineMacro, False, completeIdentifier),
126 ("help", keepGoing help, False, completeNone),
127 ("?", keepGoing help, False, completeNone),
128 ("info", keepGoing info, False, completeIdentifier),
129 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
130 ("module", keepGoing setContext, False, completeModule),
131 ("main", keepGoing runMain, False, completeIdentifier),
132 ("reload", keepGoing reloadModule, False, completeNone),
133 ("check", keepGoing checkModule, False, completeHomeModule),
134 ("set", keepGoing setCmd, True, completeSetOptions),
135 ("show", keepGoing showCmd, False, completeNone),
136 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
137 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
138 ("type", keepGoing typeOfExpr, False, completeIdentifier),
139 ("kind", keepGoing kindOfType, False, completeIdentifier),
140 ("unset", keepGoing unsetOptions, True, completeSetOptions),
141 ("undef", keepGoing undefineMacro, False, completeMacro),
142 ("quit", quit, False, completeNone)
145 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
146 keepGoing a str = a str >> return False
148 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
149 keepGoingPaths a str = a (toArgs str) >> return False
151 shortHelpText = "use :? for help.\n"
153 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
155 " Commands available from the prompt:\n" ++
157 " <stmt> evaluate/run <stmt>\n" ++
158 " :add <filename> ... add module(s) to the current target set\n" ++
159 " :browse [*]<module> display the names defined by <module>\n" ++
160 " :cd <dir> change directory to <dir>\n" ++
161 " :def <cmd> <expr> define a command :<cmd>\n" ++
162 " :help, :? display this list of commands\n" ++
163 " :info [<name> ...] display information about the given names\n" ++
164 " :load <filename> ... load module(s) and their dependents\n" ++
165 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
166 " :main [<arguments> ...] run the main function with the given arguments\n" ++
167 " :reload reload the current module set\n" ++
169 " :set <option> ... set options\n" ++
170 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
171 " :set prog <progname> set the value returned by System.getProgName\n" ++
172 " :set prompt <prompt> set the prompt used in GHCi\n" ++
174 " :show modules show the currently loaded modules\n" ++
175 " :show bindings show the current bindings made at the prompt\n" ++
177 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
178 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
179 " :type <expr> show the type of <expr>\n" ++
180 " :kind <type> show the kind of <type>\n" ++
181 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
182 " :unset <option> ... unset options\n" ++
183 " :quit exit GHCi\n" ++
184 " :!<command> run the shell command <command>\n" ++
186 " Options for ':set' and ':unset':\n" ++
188 " +r revert top-level expressions after each evaluation\n" ++
189 " +s print timing/memory stats after each evaluation\n" ++
190 " +t print type after evaluation\n" ++
191 " -<flags> most GHC command line flags can also be set here\n" ++
192 " (eg. -v2, -fglasgow-exts, etc.)\n"
195 #if defined(GHCI) && defined(BREAKPOINT)
196 globaliseAndTidy :: Id -> Id
198 -- Give the Id a Global Name, and tidy its type
199 = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
201 tidy_type = tidyTopType (idType id)
204 printScopeMsg :: Session -> String -> [Id] -> IO ()
205 printScopeMsg session location ids
206 = GHC.getPrintUnqual session >>= \unqual ->
207 printForUser stdout unqual $
208 text "Local bindings in scope:" $$
209 nest 2 (pprWithCommas showId ids)
210 where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
212 jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
213 jumpFunction session@(Session ref) (I# idsPtr) hValues location b
215 do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
216 let names = map idName ids
217 ASSERT (length names == length hValues) return ()
218 printScopeMsg session location ids
219 hsc_env <- readIORef ref
221 let ictxt = hsc_IC hsc_env
222 global_ids = map globaliseAndTidy ids
223 rn_env = ic_rn_local_env ictxt
224 type_env = ic_type_env ictxt
225 bound_names = map idName global_ids
226 new_rn_env = extendLocalRdrEnv rn_env bound_names
227 -- Remove any shadowed bindings from the type_env;
228 -- they are inaccessible but might, I suppose, cause
229 -- a space leak if we leave them there
230 shadowed = [ n | name <- bound_names,
231 let rdr_name = mkRdrUnqual (nameOccName name),
232 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
233 filtered_type_env = delListFromNameEnv type_env shadowed
234 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
235 new_ic = ictxt { ic_rn_local_env = new_rn_env,
236 ic_type_env = new_type_env }
237 writeIORef ref (hsc_env { hsc_IC = new_ic })
238 withExtendedLinkEnv (zip names hValues) $
239 startGHCi (runGHCi [] Nothing)
240 GHCiState{ progname = "<interactive>",
242 prompt = location++"> ",
245 writeIORef ref hsc_env
246 putStrLn $ "Returning to normal execution..."
250 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
251 interactiveUI session srcs maybe_expr = do
252 #if defined(GHCI) && defined(BREAKPOINT)
253 initDynLinker =<< GHC.getSessionDynFlags session
254 extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))]
256 -- HACK! If we happen to get into an infinite loop (eg the user
257 -- types 'let x=x in x' at the prompt), then the thread will block
258 -- on a blackhole, and become unreachable during GC. The GC will
259 -- detect that it is unreachable and send it the NonTermination
260 -- exception. However, since the thread is unreachable, everything
261 -- it refers to might be finalized, including the standard Handles.
262 -- This sounds like a bug, but we don't have a good solution right
269 hSetBuffering stdout NoBuffering
271 -- Initialise buffering for the *interpreted* I/O system
272 initInterpBuffering session
274 -- We don't want the cmd line to buffer any input that might be
275 -- intended for the program, so unbuffer stdin.
276 hSetBuffering stdin NoBuffering
278 -- initial context is just the Prelude
279 GHC.setContext session [] [prelude_mod]
283 Readline.setAttemptedCompletionFunction (Just completeWord)
284 --Readline.parseAndBind "set show-all-if-ambiguous 1"
286 let symbols = "!#$%&*+/<=>?@\\^|-~"
287 specials = "(),;[]`{}"
289 word_break_chars = spaces ++ specials ++ symbols
291 Readline.setBasicWordBreakCharacters word_break_chars
292 Readline.setCompleterWordBreakCharacters word_break_chars
295 startGHCi (runGHCi srcs maybe_expr)
296 GHCiState{ progname = "<interactive>",
303 Readline.resetTerminal Nothing
308 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
309 runGHCi paths maybe_expr = do
310 let read_dot_files = not opt_IgnoreDotGhci
312 when (read_dot_files) $ do
315 exists <- io (doesFileExist file)
317 dir_ok <- io (checkPerms ".")
318 file_ok <- io (checkPerms file)
319 when (dir_ok && file_ok) $ do
320 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
323 Right hdl -> fileLoop hdl False
325 when (read_dot_files) $ do
326 -- Read in $HOME/.ghci
327 either_dir <- io (IO.try (getEnv "HOME"))
331 cwd <- io (getCurrentDirectory)
332 when (dir /= cwd) $ do
333 let file = dir ++ "/.ghci"
334 ok <- io (checkPerms file)
336 either_hdl <- io (IO.try (openFile file ReadMode))
339 Right hdl -> fileLoop hdl False
341 -- Perform a :load for files given on the GHCi command line
342 -- When in -e mode, if the load fails then we want to stop
343 -- immediately rather than going on to evaluate the expression.
344 when (not (null paths)) $ do
345 ok <- ghciHandle (\e -> do showException e; return Failed) $
347 when (isJust maybe_expr && failed ok) $
348 io (exitWith (ExitFailure 1))
350 -- if verbosity is greater than 0, or we are connected to a
351 -- terminal, display the prompt in the interactive loop.
352 is_tty <- io (hIsTerminalDevice stdin)
353 dflags <- getDynFlags
354 let show_prompt = verbosity dflags > 0 || is_tty
358 #if defined(mingw32_HOST_OS)
360 -- The win32 Console API mutates the first character of
361 -- type-ahead when reading from it in a non-buffered manner. Work
362 -- around this by flushing the input buffer of type-ahead characters,
363 -- but only if stdin is available.
364 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
366 Left err | isDoesNotExistError err -> return ()
367 | otherwise -> io (ioError err)
368 Right () -> return ()
370 -- enter the interactive loop
371 interactiveLoop is_tty show_prompt
373 -- just evaluate the expression we were given
378 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
381 interactiveLoop is_tty show_prompt =
382 -- Ignore ^C exceptions caught here
383 ghciHandleDyn (\e -> case e of
385 #if defined(mingw32_HOST_OS)
388 interactiveLoop is_tty show_prompt
389 _other -> return ()) $
391 ghciUnblock $ do -- unblock necessary if we recursed from the
392 -- exception handler above.
394 -- read commands from stdin
398 else fileLoop stdin show_prompt
400 fileLoop stdin show_prompt
404 -- NOTE: We only read .ghci files if they are owned by the current user,
405 -- and aren't world writable. Otherwise, we could be accidentally
406 -- running code planted by a malicious third party.
408 -- Furthermore, We only read ./.ghci if . is owned by the current user
409 -- and isn't writable by anyone else. I think this is sufficient: we
410 -- don't need to check .. and ../.. etc. because "." always refers to
411 -- the same directory while a process is running.
413 checkPerms :: String -> IO Bool
415 #ifdef mingw32_HOST_OS
418 Util.handle (\_ -> return False) $ do
419 st <- getFileStatus name
421 if fileOwner st /= me then do
422 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
425 let mode = fileMode st
426 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
427 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
429 putStrLn $ "*** WARNING: " ++ name ++
430 " is writable by someone else, IGNORING!"
435 fileLoop :: Handle -> Bool -> GHCi ()
436 fileLoop hdl show_prompt = do
437 session <- getSession
438 (mod,imports) <- io (GHC.getContext session)
440 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
441 l <- io (IO.try (hGetLine hdl))
443 Left e | isEOFError e -> return ()
444 | InvalidArgument <- etype -> return ()
445 | otherwise -> io (ioError e)
446 where etype = ioeGetErrorType e
447 -- treat InvalidArgument in the same way as EOF:
448 -- this can happen if the user closed stdin, or
449 -- perhaps did getContents which closes stdin at
452 case removeSpaces l of
453 "" -> fileLoop hdl show_prompt
454 l -> do quit <- runCommand l
455 if quit then return () else fileLoop hdl show_prompt
457 stringLoop :: [String] -> GHCi ()
458 stringLoop [] = return ()
459 stringLoop (s:ss) = do
460 case removeSpaces s of
462 l -> do quit <- runCommand l
463 if quit then return () else stringLoop ss
465 mkPrompt toplevs exports prompt
466 = showSDoc $ f prompt
468 f ('%':'s':xs) = perc_s <> f xs
469 f ('%':'%':xs) = char '%' <> f xs
470 f (x:xs) = char x <> f xs
473 perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+>
474 hsep (map pprModule exports)
478 readlineLoop :: GHCi ()
480 session <- getSession
481 (mod,imports) <- io (GHC.getContext session)
483 saveSession -- for use by completion
485 l <- io (readline (mkPrompt mod imports (prompt st))
486 `finally` setNonBlockingFD 0)
487 -- readline sometimes puts stdin into blocking mode,
488 -- so we need to put it back for the IO library
493 case removeSpaces l of
498 if quit then return () else readlineLoop
501 runCommand :: String -> GHCi Bool
502 runCommand c = ghciHandle handler (doCommand c)
504 doCommand (':' : command) = specialCommand command
506 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
509 -- This version is for the GHC command-line option -e. The only difference
510 -- from runCommand is that it catches the ExitException exception and
511 -- exits, rather than printing out the exception.
512 runCommandEval c = ghciHandle handleEval (doCommand c)
514 handleEval (ExitException code) = io (exitWith code)
515 handleEval e = do showException e
516 io (exitWith (ExitFailure 1))
518 doCommand (':' : command) = specialCommand command
520 = do nms <- runStmt stmt
522 Nothing -> io (exitWith (ExitFailure 1))
523 -- failure to run the command causes exit(1) for ghc -e.
524 _ -> finishEvalExpr nms
526 -- This is the exception handler for exceptions generated by the
527 -- user's code; it normally just prints out the exception. The
528 -- handler must be recursive, in case showing the exception causes
529 -- more exceptions to be raised.
531 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
532 -- raising another exception. We therefore don't put the recursive
533 -- handler arond the flushing operation, so if stderr is closed
534 -- GHCi will just die gracefully rather than going into an infinite loop.
535 handler :: Exception -> GHCi Bool
536 handler exception = do
538 io installSignalHandlers
539 ghciHandle handler (showException exception >> return False)
541 showException (DynException dyn) =
542 case fromDynamic dyn of
543 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
544 Just Interrupted -> io (putStrLn "Interrupted.")
545 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
546 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
547 Just other_ghc_ex -> io (print other_ghc_ex)
549 showException other_exception
550 = io (putStrLn ("*** Exception: " ++ show other_exception))
552 runStmt :: String -> GHCi (Maybe [Name])
554 | null (filter (not.isSpace) stmt) = return (Just [])
556 = do st <- getGHCiState
557 session <- getSession
558 result <- io $ withProgName (progname st) $ withArgs (args st) $
559 GHC.runStmt session stmt
561 GHC.RunFailed -> return Nothing
562 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
563 GHC.RunOk names -> return (Just names)
565 -- possibly print the type and revert CAFs after evaluating an expression
566 finishEvalExpr mb_names
567 = do b <- isOptionSet ShowType
568 session <- getSession
571 Just names -> when b (mapM_ (showTypeOfName session) names)
574 io installSignalHandlers
575 b <- isOptionSet RevertCAFs
576 io (when b revertCAFs)
579 showTypeOfName :: Session -> Name -> GHCi ()
580 showTypeOfName session n
581 = do maybe_tything <- io (GHC.lookupName session n)
582 case maybe_tything of
584 Just thing -> showTyThing thing
586 showForUser :: SDoc -> GHCi String
588 session <- getSession
589 unqual <- io (GHC.getPrintUnqual session)
590 return $! showSDocForUser unqual doc
592 specialCommand :: String -> GHCi Bool
593 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
594 specialCommand str = do
595 let (cmd,rest) = break isSpace str
596 maybe_cmd <- io (lookupCommand cmd)
598 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
599 ++ shortHelpText) >> return False)
600 Just (_,f,_,_) -> f (dropWhile isSpace rest)
602 lookupCommand :: String -> IO (Maybe Command)
603 lookupCommand str = do
604 cmds <- readIORef commands
605 -- look for exact match first, then the first prefix match
606 case [ c | c <- cmds, str == cmdName c ] of
607 c:_ -> return (Just c)
608 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
610 c:_ -> return (Just c)
612 -----------------------------------------------------------------------------
613 -- To flush buffers for the *interpreted* computation we need
614 -- to refer to *its* stdout/stderr handles
616 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
617 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
619 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
620 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
621 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
623 initInterpBuffering :: Session -> IO ()
624 initInterpBuffering session
625 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
628 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
629 other -> panic "interactiveUI:setBuffering"
631 maybe_hval <- GHC.compileExpr session flush_cmd
633 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
634 _ -> panic "interactiveUI:flush"
636 turnOffBuffering -- Turn it off right now
641 flushInterpBuffers :: GHCi ()
643 = io $ do Monad.join (readIORef flush_interp)
646 turnOffBuffering :: IO ()
648 = do Monad.join (readIORef turn_off_buffering)
651 -----------------------------------------------------------------------------
654 help :: String -> GHCi ()
655 help _ = io (putStr helpText)
657 info :: String -> GHCi ()
658 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
659 info s = do { let names = words s
660 ; session <- getSession
661 ; dflags <- getDynFlags
662 ; let exts = dopt Opt_GlasgowExts dflags
663 ; mapM_ (infoThing exts session) names }
665 infoThing exts session str = io $ do
666 names <- GHC.parseName session str
667 let filtered = filterOutChildren names
668 mb_stuffs <- mapM (GHC.getInfo session) filtered
669 unqual <- GHC.getPrintUnqual session
670 putStrLn (showSDocForUser unqual $
671 vcat (intersperse (text "") $
672 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
674 -- Filter out names whose parent is also there Good
675 -- example is '[]', which is both a type and data
676 -- constructor in the same type
677 filterOutChildren :: [Name] -> [Name]
678 filterOutChildren names = filter (not . parent_is_there) names
679 where parent_is_there n
680 | Just p <- GHC.nameParent_maybe n = p `elem` names
683 pprInfo exts (thing, fixity, insts)
684 = pprTyThingInContextLoc exts thing
685 $$ show_fixity fixity
686 $$ vcat (map GHC.pprInstance insts)
689 | fix == GHC.defaultFixity = empty
690 | otherwise = ppr fix <+> ppr (GHC.getName thing)
692 -----------------------------------------------------------------------------
695 runMain :: String -> GHCi ()
697 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
698 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
701 addModule :: [FilePath] -> GHCi ()
703 io (revertCAFs) -- always revert CAFs on load/add.
704 files <- mapM expandPath files
705 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
706 session <- getSession
707 io (mapM_ (GHC.addTarget session) targets)
708 ok <- io (GHC.load session LoadAllTargets)
711 changeDirectory :: String -> GHCi ()
712 changeDirectory dir = do
713 session <- getSession
714 graph <- io (GHC.getModuleGraph session)
715 when (not (null graph)) $
716 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
717 io (GHC.setTargets session [])
718 io (GHC.load session LoadAllTargets)
719 setContextAfterLoad session []
720 io (GHC.workingDirectoryChanged session)
721 dir <- expandPath dir
722 io (setCurrentDirectory dir)
724 defineMacro :: String -> GHCi ()
726 let (macro_name, definition) = break isSpace s
727 cmds <- io (readIORef commands)
729 then throwDyn (CmdLineError "invalid macro name")
731 if (macro_name `elem` map cmdName cmds)
732 then throwDyn (CmdLineError
733 ("command '" ++ macro_name ++ "' is already defined"))
736 -- give the expression a type signature, so we can be sure we're getting
737 -- something of the right type.
738 let new_expr = '(' : definition ++ ") :: String -> IO String"
740 -- compile the expression
742 maybe_hv <- io (GHC.compileExpr cms new_expr)
745 Just hv -> io (writeIORef commands --
746 (cmds ++ [(macro_name, keepGoing (runMacro hv), False, completeNone)]))
748 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
750 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
751 stringLoop (lines str)
753 undefineMacro :: String -> GHCi ()
754 undefineMacro macro_name = do
755 cmds <- io (readIORef commands)
756 if (macro_name `elem` map cmdName builtin_commands)
757 then throwDyn (CmdLineError
758 ("command '" ++ macro_name ++ "' cannot be undefined"))
760 if (macro_name `notElem` map cmdName cmds)
761 then throwDyn (CmdLineError
762 ("command '" ++ macro_name ++ "' not defined"))
764 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
767 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
768 loadModule fs = timeIt (loadModule' fs)
770 loadModule_ :: [FilePath] -> GHCi ()
771 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
773 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
774 loadModule' files = do
775 session <- getSession
778 io (GHC.setTargets session [])
779 io (GHC.load session LoadAllTargets)
782 let (filenames, phases) = unzip files
783 exp_filenames <- mapM expandPath filenames
784 let files' = zip exp_filenames phases
785 targets <- io (mapM (uncurry GHC.guessTarget) files')
787 -- NOTE: we used to do the dependency anal first, so that if it
788 -- fails we didn't throw away the current set of modules. This would
789 -- require some re-working of the GHC interface, so we'll leave it
790 -- as a ToDo for now.
792 io (GHC.setTargets session targets)
793 ok <- io (GHC.load session LoadAllTargets)
797 checkModule :: String -> GHCi ()
799 let modl = GHC.mkModule m
800 session <- getSession
801 result <- io (GHC.checkModule session modl)
803 Nothing -> io $ putStrLn "Nothing"
804 Just r -> io $ putStrLn (showSDoc (
805 case checkedModuleInfo r of
806 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
808 (local,global) = partition ((== modl) . GHC.nameModule) scope
810 (text "global names: " <+> ppr global) $$
811 (text "local names: " <+> ppr local)
813 afterLoad (successIf (isJust result)) session
815 reloadModule :: String -> GHCi ()
817 io (revertCAFs) -- always revert CAFs on reload.
818 session <- getSession
819 ok <- io (GHC.load session LoadAllTargets)
822 io (revertCAFs) -- always revert CAFs on reload.
823 session <- getSession
824 ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m)))
827 afterLoad ok session = do
828 io (revertCAFs) -- always revert CAFs on load.
829 graph <- io (GHC.getModuleGraph session)
830 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
831 setContextAfterLoad session graph'
832 modulesLoadedMsg ok (map GHC.ms_mod graph')
833 #if defined(GHCI) && defined(BREAKPOINT)
834 io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))])
837 setContextAfterLoad session [] = do
838 io (GHC.setContext session [] [prelude_mod])
839 setContextAfterLoad session ms = do
840 -- load a target if one is available, otherwise load the topmost module.
841 targets <- io (GHC.getTargets session)
842 case [ m | Just m <- map (findTarget ms) targets ] of
844 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
845 load_this (last graph')
850 = case filter (`matches` t) ms of
854 summary `matches` Target (TargetModule m) _
855 = GHC.ms_mod summary == m
856 summary `matches` Target (TargetFile f _) _
857 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
858 summary `matches` target
861 load_this summary | m <- GHC.ms_mod summary = do
862 b <- io (GHC.moduleIsInterpreted session m)
863 if b then io (GHC.setContext session [m] [])
864 else io (GHC.setContext session [] [prelude_mod,m])
867 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
868 modulesLoadedMsg ok mods = do
869 dflags <- getDynFlags
870 when (verbosity dflags > 0) $ do
872 | null mods = text "none."
874 punctuate comma (map pprModule mods)) <> text "."
877 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
879 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
882 typeOfExpr :: String -> GHCi ()
884 = do cms <- getSession
885 maybe_ty <- io (GHC.exprType cms str)
888 Just ty -> do ty' <- cleanType ty
889 tystr <- showForUser (ppr ty')
890 io (putStrLn (str ++ " :: " ++ tystr))
892 kindOfType :: String -> GHCi ()
894 = do cms <- getSession
895 maybe_ty <- io (GHC.typeKind cms str)
898 Just ty -> do tystr <- showForUser (ppr ty)
899 io (putStrLn (str ++ " :: " ++ tystr))
901 quit :: String -> GHCi Bool
904 shellEscape :: String -> GHCi Bool
905 shellEscape str = io (system str >> return False)
907 -----------------------------------------------------------------------------
908 -- create tags file for currently loaded modules.
910 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
912 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
913 createCTagsFileCmd file = ghciCreateTagsFile CTags file
915 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
916 createETagsFileCmd file = ghciCreateTagsFile ETags file
918 data TagsKind = ETags | CTags
920 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
921 ghciCreateTagsFile kind file = do
922 session <- getSession
923 io $ createTagsFile session kind file
926 -- - remove restriction that all modules must be interpreted
927 -- (problem: we don't know source locations for entities unless
928 -- we compiled the module.
930 -- - extract createTagsFile so it can be used from the command-line
931 -- (probably need to fix first problem before this is useful).
933 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
934 createTagsFile session tagskind tagFile = do
935 graph <- GHC.getModuleGraph session
936 let ms = map GHC.ms_mod graph
938 is_interpreted <- GHC.moduleIsInterpreted session m
939 -- should we just skip these?
940 when (not is_interpreted) $
941 throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
943 mbModInfo <- GHC.getModuleInfo session m
945 | Just modinfo <- mbModInfo,
946 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
947 | otherwise = GHC.alwaysQualify
950 Just modInfo -> return $! listTags unqual modInfo
953 mtags <- mapM tagModule ms
954 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
956 Left e -> hPutStrLn stderr $ ioeGetErrorString e
959 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
960 listTags unqual modInfo =
961 [ tagInfo unqual name loc
962 | name <- GHC.modInfoExports modInfo
963 , let loc = nameSrcLoc name
967 type TagInfo = (String -- tag name
970 ,Int -- column number
973 -- get tag info, for later translation into Vim or Emacs style
974 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
975 tagInfo unqual name loc
976 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
977 , showSDocForUser unqual $ ftext (srcLocFile loc)
982 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
983 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
984 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
985 IO.try (writeFile file tags)
986 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
987 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
988 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
989 tagGroups <- mapM tagFileGroup groups
990 IO.try (writeFile file $ concat tagGroups)
992 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
993 tagFileGroup group@((_,fileName,_,_):_) = do
994 file <- readFile fileName -- need to get additional info from sources..
995 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
996 sortedGroup = sortLe byLine group
997 tags = unlines $ perFile sortedGroup 1 0 $ lines file
998 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
999 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
1000 perFile (tagInfo:tags) (count+1) (pos+length line) lines
1001 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
1002 showETag tagInfo line pos : perFile tags count pos lines
1003 perFile tags count pos lines = []
1005 -- simple ctags format, for Vim et al
1006 showTag :: TagInfo -> String
1007 showTag (tag,file,lineNo,colNo)
1008 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
1010 -- etags format, for Emacs/XEmacs
1011 showETag :: TagInfo -> String -> Int -> String
1012 showETag (tag,file,lineNo,colNo) line charPos
1013 = take colNo line ++ tag
1015 ++ "\x01" ++ show lineNo
1016 ++ "," ++ show charPos
1018 -----------------------------------------------------------------------------
1019 -- Browsing a module's contents
1021 browseCmd :: String -> GHCi ()
1024 ['*':m] | looksLikeModuleName m -> browseModule m False
1025 [m] | looksLikeModuleName m -> browseModule m True
1026 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1028 browseModule m exports_only = do
1031 let modl = GHC.mkModule m
1032 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1033 when (not is_interpreted && not exports_only) $
1034 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1036 -- Temporarily set the context to the module we're interested in,
1037 -- just so we can get an appropriate PrintUnqualified
1038 (as,bs) <- io (GHC.getContext s)
1039 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
1040 else GHC.setContext s [modl] [])
1041 unqual <- io (GHC.getPrintUnqual s)
1042 io (GHC.setContext s as bs)
1044 mb_mod_info <- io $ GHC.getModuleInfo s modl
1046 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1049 | exports_only = GHC.modInfoExports mod_info
1050 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1052 filtered = filterOutChildren names
1054 things <- io $ mapM (GHC.lookupName s) filtered
1056 dflags <- getDynFlags
1057 let exts = dopt Opt_GlasgowExts dflags
1058 io (putStrLn (showSDocForUser unqual (
1059 vcat (map (pprTyThingInContext exts) (catMaybes things))
1061 -- ToDo: modInfoInstances currently throws an exception for
1062 -- package modules. When it works, we can do this:
1063 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1065 -----------------------------------------------------------------------------
1066 -- Setting the module context
1069 | all sensible mods = fn mods
1070 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1072 (fn, mods) = case str of
1073 '+':stuff -> (addToContext, words stuff)
1074 '-':stuff -> (removeFromContext, words stuff)
1075 stuff -> (newContext, words stuff)
1077 sensible ('*':m) = looksLikeModuleName m
1078 sensible m = looksLikeModuleName m
1080 newContext mods = do
1081 session <- getSession
1082 (as,bs) <- separate session mods [] []
1083 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
1084 io (GHC.setContext session as bs')
1086 separate :: Session -> [String] -> [Module] -> [Module]
1087 -> GHCi ([Module],[Module])
1088 separate session [] as bs = return (as,bs)
1089 separate session (('*':m):ms) as bs = do
1090 let modl = GHC.mkModule m
1091 b <- io (GHC.moduleIsInterpreted session modl)
1092 if b then separate session ms (modl:as) bs
1093 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1094 separate session (m:ms) as bs = separate session ms as (GHC.mkModule m:bs)
1096 prelude_mod = GHC.mkModule "Prelude"
1099 addToContext mods = do
1101 (as,bs) <- io (GHC.getContext cms)
1103 (as',bs') <- separate cms mods [] []
1105 let as_to_add = as' \\ (as ++ bs)
1106 bs_to_add = bs' \\ (as ++ bs)
1108 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
1111 removeFromContext mods = do
1113 (as,bs) <- io (GHC.getContext cms)
1115 (as_to_remove,bs_to_remove) <- separate cms mods [] []
1117 let as' = as \\ (as_to_remove ++ bs_to_remove)
1118 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1120 io (GHC.setContext cms as' bs')
1122 ----------------------------------------------------------------------------
1125 -- set options in the interpreter. Syntax is exactly the same as the
1126 -- ghc command line, except that certain options aren't available (-C,
1129 -- This is pretty fragile: most options won't work as expected. ToDo:
1130 -- figure out which ones & disallow them.
1132 setCmd :: String -> GHCi ()
1134 = do st <- getGHCiState
1135 let opts = options st
1136 io $ putStrLn (showSDoc (
1137 text "options currently set: " <>
1140 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1144 ("args":args) -> setArgs args
1145 ("prog":prog) -> setProg prog
1146 ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
1147 wds -> setOptions wds
1151 setGHCiState st{ args = args }
1155 setGHCiState st{ progname = prog }
1157 io (hPutStrLn stderr "syntax: :set prog <progname>")
1159 setPrompt value = do
1162 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1163 else setGHCiState st{ prompt = remQuotes value }
1165 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1169 do -- first, deal with the GHCi opts (+s, +t, etc.)
1170 let (plus_opts, minus_opts) = partition isPlus wds
1171 mapM_ setOpt plus_opts
1173 -- then, dynamic flags
1174 dflags <- getDynFlags
1175 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1178 -- update things if the users wants more packages
1180 let new_packages = pkgs_after \\ pkgs_before
1181 when (not (null new_packages)) $
1182 newPackages new_packages
1185 if (not (null leftovers))
1186 then throwDyn (CmdLineError ("unrecognised flags: " ++
1191 unsetOptions :: String -> GHCi ()
1193 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1194 let opts = words str
1195 (minus_opts, rest1) = partition isMinus opts
1196 (plus_opts, rest2) = partition isPlus rest1
1198 if (not (null rest2))
1199 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1202 mapM_ unsetOpt plus_opts
1204 -- can't do GHC flags for now
1205 if (not (null minus_opts))
1206 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1209 isMinus ('-':s) = True
1212 isPlus ('+':s) = True
1216 = case strToGHCiOpt str of
1217 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1218 Just o -> setOption o
1221 = case strToGHCiOpt str of
1222 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1223 Just o -> unsetOption o
1225 strToGHCiOpt :: String -> (Maybe GHCiOption)
1226 strToGHCiOpt "s" = Just ShowTiming
1227 strToGHCiOpt "t" = Just ShowType
1228 strToGHCiOpt "r" = Just RevertCAFs
1229 strToGHCiOpt _ = Nothing
1231 optToStr :: GHCiOption -> String
1232 optToStr ShowTiming = "s"
1233 optToStr ShowType = "t"
1234 optToStr RevertCAFs = "r"
1237 newPackages new_pkgs = do -- The new packages are already in v_Packages
1238 session <- getSession
1239 io (GHC.setTargets session [])
1240 io (GHC.load session Nothing)
1241 dflags <- getDynFlags
1242 io (linkPackages dflags new_pkgs)
1243 setContextAfterLoad []
1246 -- ---------------------------------------------------------------------------
1251 ["modules" ] -> showModules
1252 ["bindings"] -> showBindings
1253 ["linker"] -> io showLinkerState
1254 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1257 session <- getSession
1258 let show_one ms = do m <- io (GHC.showModule session ms)
1260 graph <- io (GHC.getModuleGraph session)
1261 mapM_ show_one graph
1265 unqual <- io (GHC.getPrintUnqual s)
1266 bindings <- io (GHC.getBindings s)
1267 mapM_ showTyThing bindings
1270 showTyThing (AnId id) = do
1271 ty' <- cleanType (GHC.idType id)
1272 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1274 showTyThing _ = return ()
1276 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1277 cleanType :: Type -> GHCi Type
1279 dflags <- getDynFlags
1280 if dopt Opt_GlasgowExts dflags
1282 else return $! GHC.dropForAlls ty
1284 -- -----------------------------------------------------------------------------
1287 completeNone :: String -> IO [String]
1288 completeNone w = return []
1291 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1292 completeWord w start end = do
1293 line <- Readline.getLineBuffer
1295 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1297 | Just c <- is_cmd line -> do
1298 maybe_cmd <- lookupCommand c
1299 let (n,w') = selectWord (words' 0 line)
1301 Nothing -> return Nothing
1302 Just (_,_,False,complete) -> wrapCompleter complete w
1303 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1304 return (map (drop n) rets)
1305 in wrapCompleter complete' w'
1307 --printf "complete %s, start = %d, end = %d\n" w start end
1308 wrapCompleter completeIdentifier w
1309 where words' _ [] = []
1310 words' n str = let (w,r) = break isSpace str
1311 (s,r') = span isSpace r
1312 in (n,w):words' (n+length w+length s) r'
1313 -- In a Haskell expression we want to parse 'a-b' as three words
1314 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1315 -- only be a single word.
1316 selectWord [] = (0,w)
1317 selectWord ((offset,x):xs)
1318 | offset+length x >= start = (start-offset,take (end-offset) x)
1319 | otherwise = selectWord xs
1322 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1323 | otherwise = Nothing
1326 cmds <- readIORef commands
1327 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1329 completeMacro w = do
1330 cmds <- readIORef commands
1331 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1332 return (filter (w `isPrefixOf`) cmds')
1334 completeIdentifier w = do
1336 rdrs <- GHC.getRdrNamesInScope s
1337 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1339 completeModule w = do
1341 dflags <- GHC.getSessionDynFlags s
1342 let pkg_mods = allExposedModules dflags
1343 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1345 completeHomeModule w = do
1347 g <- GHC.getModuleGraph s
1348 let home_mods = map GHC.ms_mod g
1349 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1351 completeSetOptions w = do
1352 return (filter (w `isPrefixOf`) options)
1353 where options = "args":"prog":allFlags
1355 completeFilename = Readline.filenameCompletionFunction
1357 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1359 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1360 unionComplete f1 f2 w = do
1365 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1366 wrapCompleter fun w = do
1369 [] -> return Nothing
1370 [x] -> return (Just (x,[]))
1371 xs -> case getCommonPrefix xs of
1372 "" -> return (Just ("",xs))
1373 pref -> return (Just (pref,xs))
1375 getCommonPrefix :: [String] -> String
1376 getCommonPrefix [] = ""
1377 getCommonPrefix (s:ss) = foldl common s ss
1378 where common s "" = s
1380 common (c:cs) (d:ds)
1381 | c == d = c : common cs ds
1384 allExposedModules :: DynFlags -> [Module]
1385 allExposedModules dflags
1386 = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1388 pkg_db = pkgIdMap (pkgState dflags)
1390 completeCmd = completeNone
1391 completeMacro = completeNone
1392 completeIdentifier = completeNone
1393 completeModule = completeNone
1394 completeHomeModule = completeNone
1395 completeSetOptions = completeNone
1396 completeFilename = completeNone
1397 completeHomeModuleOrFile=completeNone
1400 -----------------------------------------------------------------------------
1403 data GHCiState = GHCiState
1408 session :: GHC.Session,
1409 options :: [GHCiOption]
1413 = ShowTiming -- show time/allocs after evaluation
1414 | ShowType -- show the type of expressions
1415 | RevertCAFs -- revert CAFs after every evaluation
1418 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1420 startGHCi :: GHCi a -> GHCiState -> IO a
1421 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1423 instance Monad GHCi where
1424 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1425 return a = GHCi $ \s -> return a
1427 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1428 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1429 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1431 getGHCiState = GHCi $ \r -> readIORef r
1432 setGHCiState s = GHCi $ \r -> writeIORef r s
1434 -- for convenience...
1435 getSession = getGHCiState >>= return . session
1437 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
1438 no_saved_sess = error "no saved_ses"
1439 saveSession = getSession >>= io . writeIORef saved_sess
1440 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
1441 restoreSession = readIORef saved_sess
1445 io (GHC.getSessionDynFlags s)
1446 setDynFlags dflags = do
1448 io (GHC.setSessionDynFlags s dflags)
1450 isOptionSet :: GHCiOption -> GHCi Bool
1452 = do st <- getGHCiState
1453 return (opt `elem` options st)
1455 setOption :: GHCiOption -> GHCi ()
1457 = do st <- getGHCiState
1458 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1460 unsetOption :: GHCiOption -> GHCi ()
1462 = do st <- getGHCiState
1463 setGHCiState (st{ options = filter (/= opt) (options st) })
1465 io :: IO a -> GHCi a
1466 io m = GHCi { unGHCi = \s -> m >>= return }
1468 -----------------------------------------------------------------------------
1469 -- recursive exception handlers
1471 -- Don't forget to unblock async exceptions in the handler, or if we're
1472 -- in an exception loop (eg. let a = error a in a) the ^C exception
1473 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1475 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1476 ghciHandle h (GHCi m) = GHCi $ \s ->
1477 Exception.catch (m s)
1478 (\e -> unGHCi (ghciUnblock (h e)) s)
1480 ghciUnblock :: GHCi a -> GHCi a
1481 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1483 -----------------------------------------------------------------------------
1484 -- timing & statistics
1486 timeIt :: GHCi a -> GHCi a
1488 = do b <- isOptionSet ShowTiming
1491 else do allocs1 <- io $ getAllocations
1492 time1 <- io $ getCPUTime
1494 allocs2 <- io $ getAllocations
1495 time2 <- io $ getCPUTime
1496 io $ printTimes (fromIntegral (allocs2 - allocs1))
1500 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1501 -- defined in ghc/rts/Stats.c
1503 printTimes :: Integer -> Integer -> IO ()
1504 printTimes allocs psecs
1505 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1506 secs_str = showFFloat (Just 2) secs
1507 putStrLn (showSDoc (
1508 parens (text (secs_str "") <+> text "secs" <> comma <+>
1509 text (show allocs) <+> text "bytes")))
1511 -----------------------------------------------------------------------------
1518 -- Have to turn off buffering again, because we just
1519 -- reverted stdout, stderr & stdin to their defaults.
1521 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1522 -- Make it "safe", just in case
1524 -- -----------------------------------------------------------------------------
1527 expandPath :: String -> GHCi String
1529 case dropWhile isSpace path of
1531 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1532 return (tilde ++ '/':d)