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, breakpointCondJumpName )
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 jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
213 jumpCondFunction session ptr hValues location True b = b
214 jumpCondFunction session ptr hValues location False b
215 = jumpFunction session ptr hValues location b
217 jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
218 jumpFunction session@(Session ref) (I# idsPtr) hValues location b
220 do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
221 let names = map idName ids
222 ASSERT (length names == length hValues) return ()
223 printScopeMsg session location ids
224 hsc_env <- readIORef ref
226 let ictxt = hsc_IC hsc_env
227 global_ids = map globaliseAndTidy ids
228 rn_env = ic_rn_local_env ictxt
229 type_env = ic_type_env ictxt
230 bound_names = map idName global_ids
231 new_rn_env = extendLocalRdrEnv rn_env bound_names
232 -- Remove any shadowed bindings from the type_env;
233 -- they are inaccessible but might, I suppose, cause
234 -- a space leak if we leave them there
235 shadowed = [ n | name <- bound_names,
236 let rdr_name = mkRdrUnqual (nameOccName name),
237 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
238 filtered_type_env = delListFromNameEnv type_env shadowed
239 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
240 new_ic = ictxt { ic_rn_local_env = new_rn_env,
241 ic_type_env = new_type_env }
242 writeIORef ref (hsc_env { hsc_IC = new_ic })
243 withExtendedLinkEnv (zip names hValues) $
244 startGHCi (runGHCi [] Nothing)
245 GHCiState{ progname = "<interactive>",
247 prompt = location++"> ",
250 writeIORef ref hsc_env
251 putStrLn $ "Returning to normal execution..."
255 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
256 interactiveUI session srcs maybe_expr = do
257 #if defined(GHCI) && defined(BREAKPOINT)
258 initDynLinker =<< GHC.getSessionDynFlags session
259 extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
260 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
262 -- HACK! If we happen to get into an infinite loop (eg the user
263 -- types 'let x=x in x' at the prompt), then the thread will block
264 -- on a blackhole, and become unreachable during GC. The GC will
265 -- detect that it is unreachable and send it the NonTermination
266 -- exception. However, since the thread is unreachable, everything
267 -- it refers to might be finalized, including the standard Handles.
268 -- This sounds like a bug, but we don't have a good solution right
275 hSetBuffering stdout NoBuffering
277 -- Initialise buffering for the *interpreted* I/O system
278 initInterpBuffering session
280 -- We don't want the cmd line to buffer any input that might be
281 -- intended for the program, so unbuffer stdin.
282 hSetBuffering stdin NoBuffering
284 -- initial context is just the Prelude
285 GHC.setContext session [] [prelude_mod]
289 Readline.setAttemptedCompletionFunction (Just completeWord)
290 --Readline.parseAndBind "set show-all-if-ambiguous 1"
292 let symbols = "!#$%&*+/<=>?@\\^|-~"
293 specials = "(),;[]`{}"
295 word_break_chars = spaces ++ specials ++ symbols
297 Readline.setBasicWordBreakCharacters word_break_chars
298 Readline.setCompleterWordBreakCharacters word_break_chars
301 startGHCi (runGHCi srcs maybe_expr)
302 GHCiState{ progname = "<interactive>",
309 Readline.resetTerminal Nothing
314 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
315 runGHCi paths maybe_expr = do
316 let read_dot_files = not opt_IgnoreDotGhci
318 when (read_dot_files) $ do
321 exists <- io (doesFileExist file)
323 dir_ok <- io (checkPerms ".")
324 file_ok <- io (checkPerms file)
325 when (dir_ok && file_ok) $ do
326 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
329 Right hdl -> fileLoop hdl False
331 when (read_dot_files) $ do
332 -- Read in $HOME/.ghci
333 either_dir <- io (IO.try (getEnv "HOME"))
337 cwd <- io (getCurrentDirectory)
338 when (dir /= cwd) $ do
339 let file = dir ++ "/.ghci"
340 ok <- io (checkPerms file)
342 either_hdl <- io (IO.try (openFile file ReadMode))
345 Right hdl -> fileLoop hdl False
347 -- Perform a :load for files given on the GHCi command line
348 -- When in -e mode, if the load fails then we want to stop
349 -- immediately rather than going on to evaluate the expression.
350 when (not (null paths)) $ do
351 ok <- ghciHandle (\e -> do showException e; return Failed) $
353 when (isJust maybe_expr && failed ok) $
354 io (exitWith (ExitFailure 1))
356 -- if verbosity is greater than 0, or we are connected to a
357 -- terminal, display the prompt in the interactive loop.
358 is_tty <- io (hIsTerminalDevice stdin)
359 dflags <- getDynFlags
360 let show_prompt = verbosity dflags > 0 || is_tty
364 #if defined(mingw32_HOST_OS)
366 -- The win32 Console API mutates the first character of
367 -- type-ahead when reading from it in a non-buffered manner. Work
368 -- around this by flushing the input buffer of type-ahead characters,
369 -- but only if stdin is available.
370 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
372 Left err | isDoesNotExistError err -> return ()
373 | otherwise -> io (ioError err)
374 Right () -> return ()
376 -- enter the interactive loop
377 interactiveLoop is_tty show_prompt
379 -- just evaluate the expression we were given
384 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
387 interactiveLoop is_tty show_prompt =
388 -- Ignore ^C exceptions caught here
389 ghciHandleDyn (\e -> case e of
391 #if defined(mingw32_HOST_OS)
394 interactiveLoop is_tty show_prompt
395 _other -> return ()) $
397 ghciUnblock $ do -- unblock necessary if we recursed from the
398 -- exception handler above.
400 -- read commands from stdin
404 else fileLoop stdin show_prompt
406 fileLoop stdin show_prompt
410 -- NOTE: We only read .ghci files if they are owned by the current user,
411 -- and aren't world writable. Otherwise, we could be accidentally
412 -- running code planted by a malicious third party.
414 -- Furthermore, We only read ./.ghci if . is owned by the current user
415 -- and isn't writable by anyone else. I think this is sufficient: we
416 -- don't need to check .. and ../.. etc. because "." always refers to
417 -- the same directory while a process is running.
419 checkPerms :: String -> IO Bool
421 #ifdef mingw32_HOST_OS
424 Util.handle (\_ -> return False) $ do
425 st <- getFileStatus name
427 if fileOwner st /= me then do
428 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
431 let mode = fileMode st
432 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
433 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
435 putStrLn $ "*** WARNING: " ++ name ++
436 " is writable by someone else, IGNORING!"
441 fileLoop :: Handle -> Bool -> GHCi ()
442 fileLoop hdl show_prompt = do
443 session <- getSession
444 (mod,imports) <- io (GHC.getContext session)
446 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
447 l <- io (IO.try (hGetLine hdl))
449 Left e | isEOFError e -> return ()
450 | InvalidArgument <- etype -> return ()
451 | otherwise -> io (ioError e)
452 where etype = ioeGetErrorType e
453 -- treat InvalidArgument in the same way as EOF:
454 -- this can happen if the user closed stdin, or
455 -- perhaps did getContents which closes stdin at
458 case removeSpaces l of
459 "" -> fileLoop hdl show_prompt
460 l -> do quit <- runCommand l
461 if quit then return () else fileLoop hdl show_prompt
463 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
464 stringLoop [] = return False
465 stringLoop (s:ss) = do
466 case removeSpaces s of
468 l -> do quit <- runCommand l
469 if quit then return True else stringLoop ss
471 mkPrompt toplevs exports prompt
472 = showSDoc $ f prompt
474 f ('%':'s':xs) = perc_s <> f xs
475 f ('%':'%':xs) = char '%' <> f xs
476 f (x:xs) = char x <> f xs
479 perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+>
480 hsep (map pprModule exports)
484 readlineLoop :: GHCi ()
486 session <- getSession
487 (mod,imports) <- io (GHC.getContext session)
489 saveSession -- for use by completion
491 l <- io (readline (mkPrompt mod imports (prompt st))
492 `finally` setNonBlockingFD 0)
493 -- readline sometimes puts stdin into blocking mode,
494 -- so we need to put it back for the IO library
499 case removeSpaces l of
504 if quit then return () else readlineLoop
507 runCommand :: String -> GHCi Bool
508 runCommand c = ghciHandle handler (doCommand c)
510 doCommand (':' : command) = specialCommand command
512 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
515 -- This version is for the GHC command-line option -e. The only difference
516 -- from runCommand is that it catches the ExitException exception and
517 -- exits, rather than printing out the exception.
518 runCommandEval c = ghciHandle handleEval (doCommand c)
520 handleEval (ExitException code) = io (exitWith code)
521 handleEval e = do showException e
522 io (exitWith (ExitFailure 1))
524 doCommand (':' : command) = specialCommand command
526 = do nms <- runStmt stmt
528 Nothing -> io (exitWith (ExitFailure 1))
529 -- failure to run the command causes exit(1) for ghc -e.
530 _ -> finishEvalExpr nms
532 -- This is the exception handler for exceptions generated by the
533 -- user's code; it normally just prints out the exception. The
534 -- handler must be recursive, in case showing the exception causes
535 -- more exceptions to be raised.
537 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
538 -- raising another exception. We therefore don't put the recursive
539 -- handler arond the flushing operation, so if stderr is closed
540 -- GHCi will just die gracefully rather than going into an infinite loop.
541 handler :: Exception -> GHCi Bool
542 handler exception = do
544 io installSignalHandlers
545 ghciHandle handler (showException exception >> return False)
547 showException (DynException dyn) =
548 case fromDynamic dyn of
549 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
550 Just Interrupted -> io (putStrLn "Interrupted.")
551 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
552 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
553 Just other_ghc_ex -> io (print other_ghc_ex)
555 showException other_exception
556 = io (putStrLn ("*** Exception: " ++ show other_exception))
558 runStmt :: String -> GHCi (Maybe [Name])
560 | null (filter (not.isSpace) stmt) = return (Just [])
562 = do st <- getGHCiState
563 session <- getSession
564 result <- io $ withProgName (progname st) $ withArgs (args st) $
565 GHC.runStmt session stmt
567 GHC.RunFailed -> return Nothing
568 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
569 GHC.RunOk names -> return (Just names)
571 -- possibly print the type and revert CAFs after evaluating an expression
572 finishEvalExpr mb_names
573 = do b <- isOptionSet ShowType
574 session <- getSession
577 Just names -> when b (mapM_ (showTypeOfName session) names)
580 io installSignalHandlers
581 b <- isOptionSet RevertCAFs
582 io (when b revertCAFs)
585 showTypeOfName :: Session -> Name -> GHCi ()
586 showTypeOfName session n
587 = do maybe_tything <- io (GHC.lookupName session n)
588 case maybe_tything of
590 Just thing -> showTyThing thing
592 showForUser :: SDoc -> GHCi String
594 session <- getSession
595 unqual <- io (GHC.getPrintUnqual session)
596 return $! showSDocForUser unqual doc
598 specialCommand :: String -> GHCi Bool
599 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
600 specialCommand str = do
601 let (cmd,rest) = break isSpace str
602 maybe_cmd <- io (lookupCommand cmd)
604 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
605 ++ shortHelpText) >> return False)
606 Just (_,f,_,_) -> f (dropWhile isSpace rest)
608 lookupCommand :: String -> IO (Maybe Command)
609 lookupCommand str = do
610 cmds <- readIORef commands
611 -- look for exact match first, then the first prefix match
612 case [ c | c <- cmds, str == cmdName c ] of
613 c:_ -> return (Just c)
614 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
616 c:_ -> return (Just c)
618 -----------------------------------------------------------------------------
619 -- To flush buffers for the *interpreted* computation we need
620 -- to refer to *its* stdout/stderr handles
622 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
623 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
625 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
626 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
627 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
629 initInterpBuffering :: Session -> IO ()
630 initInterpBuffering session
631 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
634 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
635 other -> panic "interactiveUI:setBuffering"
637 maybe_hval <- GHC.compileExpr session flush_cmd
639 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
640 _ -> panic "interactiveUI:flush"
642 turnOffBuffering -- Turn it off right now
647 flushInterpBuffers :: GHCi ()
649 = io $ do Monad.join (readIORef flush_interp)
652 turnOffBuffering :: IO ()
654 = do Monad.join (readIORef turn_off_buffering)
657 -----------------------------------------------------------------------------
660 help :: String -> GHCi ()
661 help _ = io (putStr helpText)
663 info :: String -> GHCi ()
664 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
665 info s = do { let names = words s
666 ; session <- getSession
667 ; dflags <- getDynFlags
668 ; let exts = dopt Opt_GlasgowExts dflags
669 ; mapM_ (infoThing exts session) names }
671 infoThing exts session str = io $ do
672 names <- GHC.parseName session str
673 let filtered = filterOutChildren names
674 mb_stuffs <- mapM (GHC.getInfo session) filtered
675 unqual <- GHC.getPrintUnqual session
676 putStrLn (showSDocForUser unqual $
677 vcat (intersperse (text "") $
678 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
680 -- Filter out names whose parent is also there Good
681 -- example is '[]', which is both a type and data
682 -- constructor in the same type
683 filterOutChildren :: [Name] -> [Name]
684 filterOutChildren names = filter (not . parent_is_there) names
685 where parent_is_there n
686 | Just p <- GHC.nameParent_maybe n = p `elem` names
689 pprInfo exts (thing, fixity, insts)
690 = pprTyThingInContextLoc exts thing
691 $$ show_fixity fixity
692 $$ vcat (map GHC.pprInstance insts)
695 | fix == GHC.defaultFixity = empty
696 | otherwise = ppr fix <+> ppr (GHC.getName thing)
698 -----------------------------------------------------------------------------
701 runMain :: String -> GHCi ()
703 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
704 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
707 addModule :: [FilePath] -> GHCi ()
709 io (revertCAFs) -- always revert CAFs on load/add.
710 files <- mapM expandPath files
711 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
712 session <- getSession
713 io (mapM_ (GHC.addTarget session) targets)
714 ok <- io (GHC.load session LoadAllTargets)
717 changeDirectory :: String -> GHCi ()
718 changeDirectory dir = do
719 session <- getSession
720 graph <- io (GHC.getModuleGraph session)
721 when (not (null graph)) $
722 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
723 io (GHC.setTargets session [])
724 io (GHC.load session LoadAllTargets)
725 setContextAfterLoad session []
726 io (GHC.workingDirectoryChanged session)
727 dir <- expandPath dir
728 io (setCurrentDirectory dir)
730 defineMacro :: String -> GHCi ()
732 let (macro_name, definition) = break isSpace s
733 cmds <- io (readIORef commands)
735 then throwDyn (CmdLineError "invalid macro name")
737 if (macro_name `elem` map cmdName cmds)
738 then throwDyn (CmdLineError
739 ("command '" ++ macro_name ++ "' is already defined"))
742 -- give the expression a type signature, so we can be sure we're getting
743 -- something of the right type.
744 let new_expr = '(' : definition ++ ") :: String -> IO String"
746 -- compile the expression
748 maybe_hv <- io (GHC.compileExpr cms new_expr)
751 Just hv -> io (writeIORef commands --
752 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
754 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
756 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
757 stringLoop (lines str)
759 undefineMacro :: String -> GHCi ()
760 undefineMacro macro_name = do
761 cmds <- io (readIORef commands)
762 if (macro_name `elem` map cmdName builtin_commands)
763 then throwDyn (CmdLineError
764 ("command '" ++ macro_name ++ "' cannot be undefined"))
766 if (macro_name `notElem` map cmdName cmds)
767 then throwDyn (CmdLineError
768 ("command '" ++ macro_name ++ "' not defined"))
770 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
773 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
774 loadModule fs = timeIt (loadModule' fs)
776 loadModule_ :: [FilePath] -> GHCi ()
777 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
779 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
780 loadModule' files = do
781 session <- getSession
784 io (GHC.setTargets session [])
785 io (GHC.load session LoadAllTargets)
788 let (filenames, phases) = unzip files
789 exp_filenames <- mapM expandPath filenames
790 let files' = zip exp_filenames phases
791 targets <- io (mapM (uncurry GHC.guessTarget) files')
793 -- NOTE: we used to do the dependency anal first, so that if it
794 -- fails we didn't throw away the current set of modules. This would
795 -- require some re-working of the GHC interface, so we'll leave it
796 -- as a ToDo for now.
798 io (GHC.setTargets session targets)
799 ok <- io (GHC.load session LoadAllTargets)
803 checkModule :: String -> GHCi ()
805 let modl = GHC.mkModule m
806 session <- getSession
807 result <- io (GHC.checkModule session modl)
809 Nothing -> io $ putStrLn "Nothing"
810 Just r -> io $ putStrLn (showSDoc (
811 case checkedModuleInfo r of
812 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
814 (local,global) = partition ((== modl) . GHC.nameModule) scope
816 (text "global names: " <+> ppr global) $$
817 (text "local names: " <+> ppr local)
819 afterLoad (successIf (isJust result)) session
821 reloadModule :: String -> GHCi ()
823 io (revertCAFs) -- always revert CAFs on reload.
824 session <- getSession
825 ok <- io (GHC.load session LoadAllTargets)
828 io (revertCAFs) -- always revert CAFs on reload.
829 session <- getSession
830 ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m)))
833 afterLoad ok session = do
834 io (revertCAFs) -- always revert CAFs on load.
835 graph <- io (GHC.getModuleGraph session)
836 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
837 setContextAfterLoad session graph'
838 modulesLoadedMsg ok (map GHC.ms_mod graph')
839 #if defined(GHCI) && defined(BREAKPOINT)
840 io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
841 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
844 setContextAfterLoad session [] = do
845 io (GHC.setContext session [] [prelude_mod])
846 setContextAfterLoad session ms = do
847 -- load a target if one is available, otherwise load the topmost module.
848 targets <- io (GHC.getTargets session)
849 case [ m | Just m <- map (findTarget ms) targets ] of
851 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
852 load_this (last graph')
857 = case filter (`matches` t) ms of
861 summary `matches` Target (TargetModule m) _
862 = GHC.ms_mod summary == m
863 summary `matches` Target (TargetFile f _) _
864 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
865 summary `matches` target
868 load_this summary | m <- GHC.ms_mod summary = do
869 b <- io (GHC.moduleIsInterpreted session m)
870 if b then io (GHC.setContext session [m] [])
871 else io (GHC.setContext session [] [prelude_mod,m])
874 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
875 modulesLoadedMsg ok mods = do
876 dflags <- getDynFlags
877 when (verbosity dflags > 0) $ do
879 | null mods = text "none."
881 punctuate comma (map pprModule mods)) <> text "."
884 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
886 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
889 typeOfExpr :: String -> GHCi ()
891 = do cms <- getSession
892 maybe_ty <- io (GHC.exprType cms str)
895 Just ty -> do ty' <- cleanType ty
896 tystr <- showForUser (ppr ty')
897 io (putStrLn (str ++ " :: " ++ tystr))
899 kindOfType :: String -> GHCi ()
901 = do cms <- getSession
902 maybe_ty <- io (GHC.typeKind cms str)
905 Just ty -> do tystr <- showForUser (ppr ty)
906 io (putStrLn (str ++ " :: " ++ tystr))
908 quit :: String -> GHCi Bool
911 shellEscape :: String -> GHCi Bool
912 shellEscape str = io (system str >> return False)
914 -----------------------------------------------------------------------------
915 -- create tags file for currently loaded modules.
917 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
919 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
920 createCTagsFileCmd file = ghciCreateTagsFile CTags file
922 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
923 createETagsFileCmd file = ghciCreateTagsFile ETags file
925 data TagsKind = ETags | CTags
927 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
928 ghciCreateTagsFile kind file = do
929 session <- getSession
930 io $ createTagsFile session kind file
933 -- - remove restriction that all modules must be interpreted
934 -- (problem: we don't know source locations for entities unless
935 -- we compiled the module.
937 -- - extract createTagsFile so it can be used from the command-line
938 -- (probably need to fix first problem before this is useful).
940 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
941 createTagsFile session tagskind tagFile = do
942 graph <- GHC.getModuleGraph session
943 let ms = map GHC.ms_mod graph
945 is_interpreted <- GHC.moduleIsInterpreted session m
946 -- should we just skip these?
947 when (not is_interpreted) $
948 throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
950 mbModInfo <- GHC.getModuleInfo session m
952 | Just modinfo <- mbModInfo,
953 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
954 | otherwise = GHC.alwaysQualify
957 Just modInfo -> return $! listTags unqual modInfo
960 mtags <- mapM tagModule ms
961 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
963 Left e -> hPutStrLn stderr $ ioeGetErrorString e
966 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
967 listTags unqual modInfo =
968 [ tagInfo unqual name loc
969 | name <- GHC.modInfoExports modInfo
970 , let loc = nameSrcLoc name
974 type TagInfo = (String -- tag name
977 ,Int -- column number
980 -- get tag info, for later translation into Vim or Emacs style
981 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
982 tagInfo unqual name loc
983 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
984 , showSDocForUser unqual $ ftext (srcLocFile loc)
989 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
990 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
991 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
992 IO.try (writeFile file tags)
993 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
994 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
995 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
996 tagGroups <- mapM tagFileGroup groups
997 IO.try (writeFile file $ concat tagGroups)
999 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
1000 tagFileGroup group@((_,fileName,_,_):_) = do
1001 file <- readFile fileName -- need to get additional info from sources..
1002 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
1003 sortedGroup = sortLe byLine group
1004 tags = unlines $ perFile sortedGroup 1 0 $ lines file
1005 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
1006 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
1007 perFile (tagInfo:tags) (count+1) (pos+length line) lines
1008 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
1009 showETag tagInfo line pos : perFile tags count pos lines
1010 perFile tags count pos lines = []
1012 -- simple ctags format, for Vim et al
1013 showTag :: TagInfo -> String
1014 showTag (tag,file,lineNo,colNo)
1015 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
1017 -- etags format, for Emacs/XEmacs
1018 showETag :: TagInfo -> String -> Int -> String
1019 showETag (tag,file,lineNo,colNo) line charPos
1020 = take colNo line ++ tag
1022 ++ "\x01" ++ show lineNo
1023 ++ "," ++ show charPos
1025 -----------------------------------------------------------------------------
1026 -- Browsing a module's contents
1028 browseCmd :: String -> GHCi ()
1031 ['*':m] | looksLikeModuleName m -> browseModule m False
1032 [m] | looksLikeModuleName m -> browseModule m True
1033 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1035 browseModule m exports_only = do
1038 let modl = GHC.mkModule m
1039 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1040 when (not is_interpreted && not exports_only) $
1041 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1043 -- Temporarily set the context to the module we're interested in,
1044 -- just so we can get an appropriate PrintUnqualified
1045 (as,bs) <- io (GHC.getContext s)
1046 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
1047 else GHC.setContext s [modl] [])
1048 unqual <- io (GHC.getPrintUnqual s)
1049 io (GHC.setContext s as bs)
1051 mb_mod_info <- io $ GHC.getModuleInfo s modl
1053 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1056 | exports_only = GHC.modInfoExports mod_info
1057 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1059 filtered = filterOutChildren names
1061 things <- io $ mapM (GHC.lookupName s) filtered
1063 dflags <- getDynFlags
1064 let exts = dopt Opt_GlasgowExts dflags
1065 io (putStrLn (showSDocForUser unqual (
1066 vcat (map (pprTyThingInContext exts) (catMaybes things))
1068 -- ToDo: modInfoInstances currently throws an exception for
1069 -- package modules. When it works, we can do this:
1070 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1072 -----------------------------------------------------------------------------
1073 -- Setting the module context
1076 | all sensible mods = fn mods
1077 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1079 (fn, mods) = case str of
1080 '+':stuff -> (addToContext, words stuff)
1081 '-':stuff -> (removeFromContext, words stuff)
1082 stuff -> (newContext, words stuff)
1084 sensible ('*':m) = looksLikeModuleName m
1085 sensible m = looksLikeModuleName m
1087 newContext mods = do
1088 session <- getSession
1089 (as,bs) <- separate session mods [] []
1090 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
1091 io (GHC.setContext session as bs')
1093 separate :: Session -> [String] -> [Module] -> [Module]
1094 -> GHCi ([Module],[Module])
1095 separate session [] as bs = return (as,bs)
1096 separate session (('*':m):ms) as bs = do
1097 let modl = GHC.mkModule m
1098 b <- io (GHC.moduleIsInterpreted session modl)
1099 if b then separate session ms (modl:as) bs
1100 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1101 separate session (m:ms) as bs = separate session ms as (GHC.mkModule m:bs)
1103 prelude_mod = GHC.mkModule "Prelude"
1106 addToContext mods = do
1108 (as,bs) <- io (GHC.getContext cms)
1110 (as',bs') <- separate cms mods [] []
1112 let as_to_add = as' \\ (as ++ bs)
1113 bs_to_add = bs' \\ (as ++ bs)
1115 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
1118 removeFromContext mods = do
1120 (as,bs) <- io (GHC.getContext cms)
1122 (as_to_remove,bs_to_remove) <- separate cms mods [] []
1124 let as' = as \\ (as_to_remove ++ bs_to_remove)
1125 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1127 io (GHC.setContext cms as' bs')
1129 ----------------------------------------------------------------------------
1132 -- set options in the interpreter. Syntax is exactly the same as the
1133 -- ghc command line, except that certain options aren't available (-C,
1136 -- This is pretty fragile: most options won't work as expected. ToDo:
1137 -- figure out which ones & disallow them.
1139 setCmd :: String -> GHCi ()
1141 = do st <- getGHCiState
1142 let opts = options st
1143 io $ putStrLn (showSDoc (
1144 text "options currently set: " <>
1147 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1151 ("args":args) -> setArgs args
1152 ("prog":prog) -> setProg prog
1153 ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
1154 wds -> setOptions wds
1158 setGHCiState st{ args = args }
1162 setGHCiState st{ progname = prog }
1164 io (hPutStrLn stderr "syntax: :set prog <progname>")
1166 setPrompt value = do
1169 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1170 else setGHCiState st{ prompt = remQuotes value }
1172 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1176 do -- first, deal with the GHCi opts (+s, +t, etc.)
1177 let (plus_opts, minus_opts) = partition isPlus wds
1178 mapM_ setOpt plus_opts
1180 -- then, dynamic flags
1181 dflags <- getDynFlags
1182 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1185 -- update things if the users wants more packages
1187 let new_packages = pkgs_after \\ pkgs_before
1188 when (not (null new_packages)) $
1189 newPackages new_packages
1192 if (not (null leftovers))
1193 then throwDyn (CmdLineError ("unrecognised flags: " ++
1198 unsetOptions :: String -> GHCi ()
1200 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1201 let opts = words str
1202 (minus_opts, rest1) = partition isMinus opts
1203 (plus_opts, rest2) = partition isPlus rest1
1205 if (not (null rest2))
1206 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1209 mapM_ unsetOpt plus_opts
1211 -- can't do GHC flags for now
1212 if (not (null minus_opts))
1213 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1216 isMinus ('-':s) = True
1219 isPlus ('+':s) = True
1223 = case strToGHCiOpt str of
1224 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1225 Just o -> setOption o
1228 = case strToGHCiOpt str of
1229 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1230 Just o -> unsetOption o
1232 strToGHCiOpt :: String -> (Maybe GHCiOption)
1233 strToGHCiOpt "s" = Just ShowTiming
1234 strToGHCiOpt "t" = Just ShowType
1235 strToGHCiOpt "r" = Just RevertCAFs
1236 strToGHCiOpt _ = Nothing
1238 optToStr :: GHCiOption -> String
1239 optToStr ShowTiming = "s"
1240 optToStr ShowType = "t"
1241 optToStr RevertCAFs = "r"
1244 newPackages new_pkgs = do -- The new packages are already in v_Packages
1245 session <- getSession
1246 io (GHC.setTargets session [])
1247 io (GHC.load session Nothing)
1248 dflags <- getDynFlags
1249 io (linkPackages dflags new_pkgs)
1250 setContextAfterLoad []
1253 -- ---------------------------------------------------------------------------
1258 ["modules" ] -> showModules
1259 ["bindings"] -> showBindings
1260 ["linker"] -> io showLinkerState
1261 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1264 session <- getSession
1265 let show_one ms = do m <- io (GHC.showModule session ms)
1267 graph <- io (GHC.getModuleGraph session)
1268 mapM_ show_one graph
1272 unqual <- io (GHC.getPrintUnqual s)
1273 bindings <- io (GHC.getBindings s)
1274 mapM_ showTyThing bindings
1277 showTyThing (AnId id) = do
1278 ty' <- cleanType (GHC.idType id)
1279 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1281 showTyThing _ = return ()
1283 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1284 cleanType :: Type -> GHCi Type
1286 dflags <- getDynFlags
1287 if dopt Opt_GlasgowExts dflags
1289 else return $! GHC.dropForAlls ty
1291 -- -----------------------------------------------------------------------------
1294 completeNone :: String -> IO [String]
1295 completeNone w = return []
1298 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1299 completeWord w start end = do
1300 line <- Readline.getLineBuffer
1302 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1304 | Just c <- is_cmd line -> do
1305 maybe_cmd <- lookupCommand c
1306 let (n,w') = selectWord (words' 0 line)
1308 Nothing -> return Nothing
1309 Just (_,_,False,complete) -> wrapCompleter complete w
1310 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1311 return (map (drop n) rets)
1312 in wrapCompleter complete' w'
1314 --printf "complete %s, start = %d, end = %d\n" w start end
1315 wrapCompleter completeIdentifier w
1316 where words' _ [] = []
1317 words' n str = let (w,r) = break isSpace str
1318 (s,r') = span isSpace r
1319 in (n,w):words' (n+length w+length s) r'
1320 -- In a Haskell expression we want to parse 'a-b' as three words
1321 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1322 -- only be a single word.
1323 selectWord [] = (0,w)
1324 selectWord ((offset,x):xs)
1325 | offset+length x >= start = (start-offset,take (end-offset) x)
1326 | otherwise = selectWord xs
1329 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1330 | otherwise = Nothing
1333 cmds <- readIORef commands
1334 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1336 completeMacro w = do
1337 cmds <- readIORef commands
1338 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1339 return (filter (w `isPrefixOf`) cmds')
1341 completeIdentifier w = do
1343 rdrs <- GHC.getRdrNamesInScope s
1344 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1346 completeModule w = do
1348 dflags <- GHC.getSessionDynFlags s
1349 let pkg_mods = allExposedModules dflags
1350 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1352 completeHomeModule w = do
1354 g <- GHC.getModuleGraph s
1355 let home_mods = map GHC.ms_mod g
1356 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1358 completeSetOptions w = do
1359 return (filter (w `isPrefixOf`) options)
1360 where options = "args":"prog":allFlags
1362 completeFilename = Readline.filenameCompletionFunction
1364 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1366 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1367 unionComplete f1 f2 w = do
1372 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1373 wrapCompleter fun w = do
1376 [] -> return Nothing
1377 [x] -> return (Just (x,[]))
1378 xs -> case getCommonPrefix xs of
1379 "" -> return (Just ("",xs))
1380 pref -> return (Just (pref,xs))
1382 getCommonPrefix :: [String] -> String
1383 getCommonPrefix [] = ""
1384 getCommonPrefix (s:ss) = foldl common s ss
1385 where common s "" = s
1387 common (c:cs) (d:ds)
1388 | c == d = c : common cs ds
1391 allExposedModules :: DynFlags -> [Module]
1392 allExposedModules dflags
1393 = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1395 pkg_db = pkgIdMap (pkgState dflags)
1397 completeCmd = completeNone
1398 completeMacro = completeNone
1399 completeIdentifier = completeNone
1400 completeModule = completeNone
1401 completeHomeModule = completeNone
1402 completeSetOptions = completeNone
1403 completeFilename = completeNone
1404 completeHomeModuleOrFile=completeNone
1407 -----------------------------------------------------------------------------
1410 data GHCiState = GHCiState
1415 session :: GHC.Session,
1416 options :: [GHCiOption]
1420 = ShowTiming -- show time/allocs after evaluation
1421 | ShowType -- show the type of expressions
1422 | RevertCAFs -- revert CAFs after every evaluation
1425 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1427 startGHCi :: GHCi a -> GHCiState -> IO a
1428 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1430 instance Monad GHCi where
1431 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1432 return a = GHCi $ \s -> return a
1434 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1435 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1436 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1438 getGHCiState = GHCi $ \r -> readIORef r
1439 setGHCiState s = GHCi $ \r -> writeIORef r s
1441 -- for convenience...
1442 getSession = getGHCiState >>= return . session
1444 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
1445 no_saved_sess = error "no saved_ses"
1446 saveSession = getSession >>= io . writeIORef saved_sess
1447 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
1448 restoreSession = readIORef saved_sess
1452 io (GHC.getSessionDynFlags s)
1453 setDynFlags dflags = do
1455 io (GHC.setSessionDynFlags s dflags)
1457 isOptionSet :: GHCiOption -> GHCi Bool
1459 = do st <- getGHCiState
1460 return (opt `elem` options st)
1462 setOption :: GHCiOption -> GHCi ()
1464 = do st <- getGHCiState
1465 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1467 unsetOption :: GHCiOption -> GHCi ()
1469 = do st <- getGHCiState
1470 setGHCiState (st{ options = filter (/= opt) (options st) })
1472 io :: IO a -> GHCi a
1473 io m = GHCi { unGHCi = \s -> m >>= return }
1475 -----------------------------------------------------------------------------
1476 -- recursive exception handlers
1478 -- Don't forget to unblock async exceptions in the handler, or if we're
1479 -- in an exception loop (eg. let a = error a in a) the ^C exception
1480 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1482 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1483 ghciHandle h (GHCi m) = GHCi $ \s ->
1484 Exception.catch (m s)
1485 (\e -> unGHCi (ghciUnblock (h e)) s)
1487 ghciUnblock :: GHCi a -> GHCi a
1488 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1490 -----------------------------------------------------------------------------
1491 -- timing & statistics
1493 timeIt :: GHCi a -> GHCi a
1495 = do b <- isOptionSet ShowTiming
1498 else do allocs1 <- io $ getAllocations
1499 time1 <- io $ getCPUTime
1501 allocs2 <- io $ getAllocations
1502 time2 <- io $ getCPUTime
1503 io $ printTimes (fromIntegral (allocs2 - allocs1))
1507 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1508 -- defined in ghc/rts/Stats.c
1510 printTimes :: Integer -> Integer -> IO ()
1511 printTimes allocs psecs
1512 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1513 secs_str = showFFloat (Just 2) secs
1514 putStrLn (showSDoc (
1515 parens (text (secs_str "") <+> text "secs" <> comma <+>
1516 text (show allocs) <+> text "bytes")))
1518 -----------------------------------------------------------------------------
1525 -- Have to turn off buffering again, because we just
1526 -- reverted stdout, stderr & stdin to their defaults.
1528 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1529 -- Make it "safe", just in case
1531 -- -----------------------------------------------------------------------------
1534 expandPath :: String -> GHCi String
1536 case dropWhile isSpace path of
1538 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1539 return (tilde ++ '/':d)