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 is_tty <- hIsTerminalDevice stdin
244 withExtendedLinkEnv (zip names hValues) $
245 startGHCi (interactiveLoop is_tty True)
246 GHCiState{ progname = "<interactive>",
248 prompt = location++"> ",
251 writeIORef ref hsc_env
252 putStrLn $ "Returning to normal execution..."
256 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
257 interactiveUI session srcs maybe_expr = do
258 #if defined(GHCI) && defined(BREAKPOINT)
259 initDynLinker =<< GHC.getSessionDynFlags session
260 extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
261 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
263 -- HACK! If we happen to get into an infinite loop (eg the user
264 -- types 'let x=x in x' at the prompt), then the thread will block
265 -- on a blackhole, and become unreachable during GC. The GC will
266 -- detect that it is unreachable and send it the NonTermination
267 -- exception. However, since the thread is unreachable, everything
268 -- it refers to might be finalized, including the standard Handles.
269 -- This sounds like a bug, but we don't have a good solution right
276 hSetBuffering stdout NoBuffering
278 -- Initialise buffering for the *interpreted* I/O system
279 initInterpBuffering session
281 -- We don't want the cmd line to buffer any input that might be
282 -- intended for the program, so unbuffer stdin.
283 hSetBuffering stdin NoBuffering
285 -- initial context is just the Prelude
286 GHC.setContext session [] [prelude_mod]
290 Readline.setAttemptedCompletionFunction (Just completeWord)
291 --Readline.parseAndBind "set show-all-if-ambiguous 1"
293 let symbols = "!#$%&*+/<=>?@\\^|-~"
294 specials = "(),;[]`{}"
296 word_break_chars = spaces ++ specials ++ symbols
298 Readline.setBasicWordBreakCharacters word_break_chars
299 Readline.setCompleterWordBreakCharacters word_break_chars
302 startGHCi (runGHCi srcs maybe_expr)
303 GHCiState{ progname = "<interactive>",
310 Readline.resetTerminal Nothing
315 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
316 runGHCi paths maybe_expr = do
317 let read_dot_files = not opt_IgnoreDotGhci
319 when (read_dot_files) $ do
322 exists <- io (doesFileExist file)
324 dir_ok <- io (checkPerms ".")
325 file_ok <- io (checkPerms file)
326 when (dir_ok && file_ok) $ do
327 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
330 Right hdl -> fileLoop hdl False
332 when (read_dot_files) $ do
333 -- Read in $HOME/.ghci
334 either_dir <- io (IO.try (getEnv "HOME"))
338 cwd <- io (getCurrentDirectory)
339 when (dir /= cwd) $ do
340 let file = dir ++ "/.ghci"
341 ok <- io (checkPerms file)
343 either_hdl <- io (IO.try (openFile file ReadMode))
346 Right hdl -> fileLoop hdl False
348 -- Perform a :load for files given on the GHCi command line
349 -- When in -e mode, if the load fails then we want to stop
350 -- immediately rather than going on to evaluate the expression.
351 when (not (null paths)) $ do
352 ok <- ghciHandle (\e -> do showException e; return Failed) $
354 when (isJust maybe_expr && failed ok) $
355 io (exitWith (ExitFailure 1))
357 -- if verbosity is greater than 0, or we are connected to a
358 -- terminal, display the prompt in the interactive loop.
359 is_tty <- io (hIsTerminalDevice stdin)
360 dflags <- getDynFlags
361 let show_prompt = verbosity dflags > 0 || is_tty
365 #if defined(mingw32_HOST_OS)
367 -- The win32 Console API mutates the first character of
368 -- type-ahead when reading from it in a non-buffered manner. Work
369 -- around this by flushing the input buffer of type-ahead characters,
370 -- but only if stdin is available.
371 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
373 Left err | isDoesNotExistError err -> return ()
374 | otherwise -> io (ioError err)
375 Right () -> return ()
377 -- enter the interactive loop
378 interactiveLoop is_tty show_prompt
380 -- just evaluate the expression we were given
385 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
388 interactiveLoop is_tty show_prompt =
389 -- Ignore ^C exceptions caught here
390 ghciHandleDyn (\e -> case e of
392 #if defined(mingw32_HOST_OS)
395 interactiveLoop is_tty show_prompt
396 _other -> return ()) $
398 ghciUnblock $ do -- unblock necessary if we recursed from the
399 -- exception handler above.
401 -- read commands from stdin
405 else fileLoop stdin show_prompt
407 fileLoop stdin show_prompt
411 -- NOTE: We only read .ghci files if they are owned by the current user,
412 -- and aren't world writable. Otherwise, we could be accidentally
413 -- running code planted by a malicious third party.
415 -- Furthermore, We only read ./.ghci if . is owned by the current user
416 -- and isn't writable by anyone else. I think this is sufficient: we
417 -- don't need to check .. and ../.. etc. because "." always refers to
418 -- the same directory while a process is running.
420 checkPerms :: String -> IO Bool
422 #ifdef mingw32_HOST_OS
425 Util.handle (\_ -> return False) $ do
426 st <- getFileStatus name
428 if fileOwner st /= me then do
429 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
432 let mode = fileMode st
433 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
434 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
436 putStrLn $ "*** WARNING: " ++ name ++
437 " is writable by someone else, IGNORING!"
442 fileLoop :: Handle -> Bool -> GHCi ()
443 fileLoop hdl show_prompt = do
444 session <- getSession
445 (mod,imports) <- io (GHC.getContext session)
447 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
448 l <- io (IO.try (hGetLine hdl))
450 Left e | isEOFError e -> return ()
451 | InvalidArgument <- etype -> return ()
452 | otherwise -> io (ioError e)
453 where etype = ioeGetErrorType e
454 -- treat InvalidArgument in the same way as EOF:
455 -- this can happen if the user closed stdin, or
456 -- perhaps did getContents which closes stdin at
459 case removeSpaces l of
460 "" -> fileLoop hdl show_prompt
461 l -> do quit <- runCommand l
462 if quit then return () else fileLoop hdl show_prompt
464 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
465 stringLoop [] = return False
466 stringLoop (s:ss) = do
467 case removeSpaces s of
469 l -> do quit <- runCommand l
470 if quit then return True else stringLoop ss
472 mkPrompt toplevs exports prompt
473 = showSDoc $ f prompt
475 f ('%':'s':xs) = perc_s <> f xs
476 f ('%':'%':xs) = char '%' <> f xs
477 f (x:xs) = char x <> f xs
480 perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+>
481 hsep (map pprModule exports)
485 readlineLoop :: GHCi ()
487 session <- getSession
488 (mod,imports) <- io (GHC.getContext session)
490 saveSession -- for use by completion
492 l <- io (readline (mkPrompt mod imports (prompt st))
493 `finally` setNonBlockingFD 0)
494 -- readline sometimes puts stdin into blocking mode,
495 -- so we need to put it back for the IO library
500 case removeSpaces l of
505 if quit then return () else readlineLoop
508 runCommand :: String -> GHCi Bool
509 runCommand c = ghciHandle handler (doCommand c)
511 doCommand (':' : command) = specialCommand command
513 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
516 -- This version is for the GHC command-line option -e. The only difference
517 -- from runCommand is that it catches the ExitException exception and
518 -- exits, rather than printing out the exception.
519 runCommandEval c = ghciHandle handleEval (doCommand c)
521 handleEval (ExitException code) = io (exitWith code)
522 handleEval e = do showException e
523 io (exitWith (ExitFailure 1))
525 doCommand (':' : command) = specialCommand command
527 = do nms <- runStmt stmt
529 Nothing -> io (exitWith (ExitFailure 1))
530 -- failure to run the command causes exit(1) for ghc -e.
531 _ -> finishEvalExpr nms
533 -- This is the exception handler for exceptions generated by the
534 -- user's code; it normally just prints out the exception. The
535 -- handler must be recursive, in case showing the exception causes
536 -- more exceptions to be raised.
538 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
539 -- raising another exception. We therefore don't put the recursive
540 -- handler arond the flushing operation, so if stderr is closed
541 -- GHCi will just die gracefully rather than going into an infinite loop.
542 handler :: Exception -> GHCi Bool
543 handler exception = do
545 io installSignalHandlers
546 ghciHandle handler (showException exception >> return False)
548 showException (DynException dyn) =
549 case fromDynamic dyn of
550 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
551 Just Interrupted -> io (putStrLn "Interrupted.")
552 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
553 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
554 Just other_ghc_ex -> io (print other_ghc_ex)
556 showException other_exception
557 = io (putStrLn ("*** Exception: " ++ show other_exception))
559 runStmt :: String -> GHCi (Maybe [Name])
561 | null (filter (not.isSpace) stmt) = return (Just [])
563 = do st <- getGHCiState
564 session <- getSession
565 result <- io $ withProgName (progname st) $ withArgs (args st) $
566 GHC.runStmt session stmt
568 GHC.RunFailed -> return Nothing
569 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
570 GHC.RunOk names -> return (Just names)
572 -- possibly print the type and revert CAFs after evaluating an expression
573 finishEvalExpr mb_names
574 = do b <- isOptionSet ShowType
575 session <- getSession
578 Just names -> when b (mapM_ (showTypeOfName session) names)
581 io installSignalHandlers
582 b <- isOptionSet RevertCAFs
583 io (when b revertCAFs)
586 showTypeOfName :: Session -> Name -> GHCi ()
587 showTypeOfName session n
588 = do maybe_tything <- io (GHC.lookupName session n)
589 case maybe_tything of
591 Just thing -> showTyThing thing
593 showForUser :: SDoc -> GHCi String
595 session <- getSession
596 unqual <- io (GHC.getPrintUnqual session)
597 return $! showSDocForUser unqual doc
599 specialCommand :: String -> GHCi Bool
600 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
601 specialCommand str = do
602 let (cmd,rest) = break isSpace str
603 maybe_cmd <- io (lookupCommand cmd)
605 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
606 ++ shortHelpText) >> return False)
607 Just (_,f,_,_) -> f (dropWhile isSpace rest)
609 lookupCommand :: String -> IO (Maybe Command)
610 lookupCommand str = do
611 cmds <- readIORef commands
612 -- look for exact match first, then the first prefix match
613 case [ c | c <- cmds, str == cmdName c ] of
614 c:_ -> return (Just c)
615 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
617 c:_ -> return (Just c)
619 -----------------------------------------------------------------------------
620 -- To flush buffers for the *interpreted* computation we need
621 -- to refer to *its* stdout/stderr handles
623 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
624 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
626 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
627 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
628 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
630 initInterpBuffering :: Session -> IO ()
631 initInterpBuffering session
632 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
635 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
636 other -> panic "interactiveUI:setBuffering"
638 maybe_hval <- GHC.compileExpr session flush_cmd
640 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
641 _ -> panic "interactiveUI:flush"
643 turnOffBuffering -- Turn it off right now
648 flushInterpBuffers :: GHCi ()
650 = io $ do Monad.join (readIORef flush_interp)
653 turnOffBuffering :: IO ()
655 = do Monad.join (readIORef turn_off_buffering)
658 -----------------------------------------------------------------------------
661 help :: String -> GHCi ()
662 help _ = io (putStr helpText)
664 info :: String -> GHCi ()
665 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
666 info s = do { let names = words s
667 ; session <- getSession
668 ; dflags <- getDynFlags
669 ; let exts = dopt Opt_GlasgowExts dflags
670 ; mapM_ (infoThing exts session) names }
672 infoThing exts session str = io $ do
673 names <- GHC.parseName session str
674 let filtered = filterOutChildren names
675 mb_stuffs <- mapM (GHC.getInfo session) filtered
676 unqual <- GHC.getPrintUnqual session
677 putStrLn (showSDocForUser unqual $
678 vcat (intersperse (text "") $
679 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
681 -- Filter out names whose parent is also there Good
682 -- example is '[]', which is both a type and data
683 -- constructor in the same type
684 filterOutChildren :: [Name] -> [Name]
685 filterOutChildren names = filter (not . parent_is_there) names
686 where parent_is_there n
687 | Just p <- GHC.nameParent_maybe n = p `elem` names
690 pprInfo exts (thing, fixity, insts)
691 = pprTyThingInContextLoc exts thing
692 $$ show_fixity fixity
693 $$ vcat (map GHC.pprInstance insts)
696 | fix == GHC.defaultFixity = empty
697 | otherwise = ppr fix <+> ppr (GHC.getName thing)
699 -----------------------------------------------------------------------------
702 runMain :: String -> GHCi ()
704 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
705 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
708 addModule :: [FilePath] -> GHCi ()
710 io (revertCAFs) -- always revert CAFs on load/add.
711 files <- mapM expandPath files
712 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
713 session <- getSession
714 io (mapM_ (GHC.addTarget session) targets)
715 ok <- io (GHC.load session LoadAllTargets)
718 changeDirectory :: String -> GHCi ()
719 changeDirectory dir = do
720 session <- getSession
721 graph <- io (GHC.getModuleGraph session)
722 when (not (null graph)) $
723 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
724 io (GHC.setTargets session [])
725 io (GHC.load session LoadAllTargets)
726 setContextAfterLoad session []
727 io (GHC.workingDirectoryChanged session)
728 dir <- expandPath dir
729 io (setCurrentDirectory dir)
731 defineMacro :: String -> GHCi ()
733 let (macro_name, definition) = break isSpace s
734 cmds <- io (readIORef commands)
736 then throwDyn (CmdLineError "invalid macro name")
738 if (macro_name `elem` map cmdName cmds)
739 then throwDyn (CmdLineError
740 ("command '" ++ macro_name ++ "' is already defined"))
743 -- give the expression a type signature, so we can be sure we're getting
744 -- something of the right type.
745 let new_expr = '(' : definition ++ ") :: String -> IO String"
747 -- compile the expression
749 maybe_hv <- io (GHC.compileExpr cms new_expr)
752 Just hv -> io (writeIORef commands --
753 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
755 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
757 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
758 stringLoop (lines str)
760 undefineMacro :: String -> GHCi ()
761 undefineMacro macro_name = do
762 cmds <- io (readIORef commands)
763 if (macro_name `elem` map cmdName builtin_commands)
764 then throwDyn (CmdLineError
765 ("command '" ++ macro_name ++ "' cannot be undefined"))
767 if (macro_name `notElem` map cmdName cmds)
768 then throwDyn (CmdLineError
769 ("command '" ++ macro_name ++ "' not defined"))
771 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
774 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
775 loadModule fs = timeIt (loadModule' fs)
777 loadModule_ :: [FilePath] -> GHCi ()
778 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
780 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
781 loadModule' files = do
782 session <- getSession
785 io (GHC.setTargets session [])
786 io (GHC.load session LoadAllTargets)
789 let (filenames, phases) = unzip files
790 exp_filenames <- mapM expandPath filenames
791 let files' = zip exp_filenames phases
792 targets <- io (mapM (uncurry GHC.guessTarget) files')
794 -- NOTE: we used to do the dependency anal first, so that if it
795 -- fails we didn't throw away the current set of modules. This would
796 -- require some re-working of the GHC interface, so we'll leave it
797 -- as a ToDo for now.
799 io (GHC.setTargets session targets)
800 ok <- io (GHC.load session LoadAllTargets)
804 checkModule :: String -> GHCi ()
806 let modl = GHC.mkModule m
807 session <- getSession
808 result <- io (GHC.checkModule session modl)
810 Nothing -> io $ putStrLn "Nothing"
811 Just r -> io $ putStrLn (showSDoc (
812 case checkedModuleInfo r of
813 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
815 (local,global) = partition ((== modl) . GHC.nameModule) scope
817 (text "global names: " <+> ppr global) $$
818 (text "local names: " <+> ppr local)
820 afterLoad (successIf (isJust result)) session
822 reloadModule :: String -> GHCi ()
824 io (revertCAFs) -- always revert CAFs on reload.
825 session <- getSession
826 ok <- io (GHC.load session LoadAllTargets)
829 io (revertCAFs) -- always revert CAFs on reload.
830 session <- getSession
831 ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m)))
834 afterLoad ok session = do
835 io (revertCAFs) -- always revert CAFs on load.
836 graph <- io (GHC.getModuleGraph session)
837 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
838 setContextAfterLoad session graph'
839 modulesLoadedMsg ok (map GHC.ms_mod graph')
840 #if defined(GHCI) && defined(BREAKPOINT)
841 io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
842 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
845 setContextAfterLoad session [] = do
846 io (GHC.setContext session [] [prelude_mod])
847 setContextAfterLoad session ms = do
848 -- load a target if one is available, otherwise load the topmost module.
849 targets <- io (GHC.getTargets session)
850 case [ m | Just m <- map (findTarget ms) targets ] of
852 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
853 load_this (last graph')
858 = case filter (`matches` t) ms of
862 summary `matches` Target (TargetModule m) _
863 = GHC.ms_mod summary == m
864 summary `matches` Target (TargetFile f _) _
865 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
866 summary `matches` target
869 load_this summary | m <- GHC.ms_mod summary = do
870 b <- io (GHC.moduleIsInterpreted session m)
871 if b then io (GHC.setContext session [m] [])
872 else io (GHC.setContext session [] [prelude_mod,m])
875 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
876 modulesLoadedMsg ok mods = do
877 dflags <- getDynFlags
878 when (verbosity dflags > 0) $ do
880 | null mods = text "none."
882 punctuate comma (map pprModule mods)) <> text "."
885 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
887 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
890 typeOfExpr :: String -> GHCi ()
892 = do cms <- getSession
893 maybe_ty <- io (GHC.exprType cms str)
896 Just ty -> do ty' <- cleanType ty
897 tystr <- showForUser (ppr ty')
898 io (putStrLn (str ++ " :: " ++ tystr))
900 kindOfType :: String -> GHCi ()
902 = do cms <- getSession
903 maybe_ty <- io (GHC.typeKind cms str)
906 Just ty -> do tystr <- showForUser (ppr ty)
907 io (putStrLn (str ++ " :: " ++ tystr))
909 quit :: String -> GHCi Bool
912 shellEscape :: String -> GHCi Bool
913 shellEscape str = io (system str >> return False)
915 -----------------------------------------------------------------------------
916 -- create tags file for currently loaded modules.
918 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
920 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
921 createCTagsFileCmd file = ghciCreateTagsFile CTags file
923 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
924 createETagsFileCmd file = ghciCreateTagsFile ETags file
926 data TagsKind = ETags | CTags
928 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
929 ghciCreateTagsFile kind file = do
930 session <- getSession
931 io $ createTagsFile session kind file
934 -- - remove restriction that all modules must be interpreted
935 -- (problem: we don't know source locations for entities unless
936 -- we compiled the module.
938 -- - extract createTagsFile so it can be used from the command-line
939 -- (probably need to fix first problem before this is useful).
941 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
942 createTagsFile session tagskind tagFile = do
943 graph <- GHC.getModuleGraph session
944 let ms = map GHC.ms_mod graph
946 is_interpreted <- GHC.moduleIsInterpreted session m
947 -- should we just skip these?
948 when (not is_interpreted) $
949 throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
951 mbModInfo <- GHC.getModuleInfo session m
953 | Just modinfo <- mbModInfo,
954 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
955 | otherwise = GHC.alwaysQualify
958 Just modInfo -> return $! listTags unqual modInfo
961 mtags <- mapM tagModule ms
962 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
964 Left e -> hPutStrLn stderr $ ioeGetErrorString e
967 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
968 listTags unqual modInfo =
969 [ tagInfo unqual name loc
970 | name <- GHC.modInfoExports modInfo
971 , let loc = nameSrcLoc name
975 type TagInfo = (String -- tag name
978 ,Int -- column number
981 -- get tag info, for later translation into Vim or Emacs style
982 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
983 tagInfo unqual name loc
984 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
985 , showSDocForUser unqual $ ftext (srcLocFile loc)
990 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
991 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
992 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
993 IO.try (writeFile file tags)
994 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
995 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
996 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
997 tagGroups <- mapM tagFileGroup groups
998 IO.try (writeFile file $ concat tagGroups)
1000 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
1001 tagFileGroup group@((_,fileName,_,_):_) = do
1002 file <- readFile fileName -- need to get additional info from sources..
1003 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
1004 sortedGroup = sortLe byLine group
1005 tags = unlines $ perFile sortedGroup 1 0 $ lines file
1006 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
1007 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
1008 perFile (tagInfo:tags) (count+1) (pos+length line) lines
1009 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
1010 showETag tagInfo line pos : perFile tags count pos lines
1011 perFile tags count pos lines = []
1013 -- simple ctags format, for Vim et al
1014 showTag :: TagInfo -> String
1015 showTag (tag,file,lineNo,colNo)
1016 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
1018 -- etags format, for Emacs/XEmacs
1019 showETag :: TagInfo -> String -> Int -> String
1020 showETag (tag,file,lineNo,colNo) line charPos
1021 = take colNo line ++ tag
1023 ++ "\x01" ++ show lineNo
1024 ++ "," ++ show charPos
1026 -----------------------------------------------------------------------------
1027 -- Browsing a module's contents
1029 browseCmd :: String -> GHCi ()
1032 ['*':m] | looksLikeModuleName m -> browseModule m False
1033 [m] | looksLikeModuleName m -> browseModule m True
1034 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1036 browseModule m exports_only = do
1039 let modl = GHC.mkModule m
1040 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1041 when (not is_interpreted && not exports_only) $
1042 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1044 -- Temporarily set the context to the module we're interested in,
1045 -- just so we can get an appropriate PrintUnqualified
1046 (as,bs) <- io (GHC.getContext s)
1047 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
1048 else GHC.setContext s [modl] [])
1049 unqual <- io (GHC.getPrintUnqual s)
1050 io (GHC.setContext s as bs)
1052 mb_mod_info <- io $ GHC.getModuleInfo s modl
1054 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1057 | exports_only = GHC.modInfoExports mod_info
1058 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1060 filtered = filterOutChildren names
1062 things <- io $ mapM (GHC.lookupName s) filtered
1064 dflags <- getDynFlags
1065 let exts = dopt Opt_GlasgowExts dflags
1066 io (putStrLn (showSDocForUser unqual (
1067 vcat (map (pprTyThingInContext exts) (catMaybes things))
1069 -- ToDo: modInfoInstances currently throws an exception for
1070 -- package modules. When it works, we can do this:
1071 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1073 -----------------------------------------------------------------------------
1074 -- Setting the module context
1077 | all sensible mods = fn mods
1078 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1080 (fn, mods) = case str of
1081 '+':stuff -> (addToContext, words stuff)
1082 '-':stuff -> (removeFromContext, words stuff)
1083 stuff -> (newContext, words stuff)
1085 sensible ('*':m) = looksLikeModuleName m
1086 sensible m = looksLikeModuleName m
1088 newContext mods = do
1089 session <- getSession
1090 (as,bs) <- separate session mods [] []
1091 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
1092 io (GHC.setContext session as bs')
1094 separate :: Session -> [String] -> [Module] -> [Module]
1095 -> GHCi ([Module],[Module])
1096 separate session [] as bs = return (as,bs)
1097 separate session (('*':m):ms) as bs = do
1098 let modl = GHC.mkModule m
1099 b <- io (GHC.moduleIsInterpreted session modl)
1100 if b then separate session ms (modl:as) bs
1101 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1102 separate session (m:ms) as bs = separate session ms as (GHC.mkModule m:bs)
1104 prelude_mod = GHC.mkModule "Prelude"
1107 addToContext mods = do
1109 (as,bs) <- io (GHC.getContext cms)
1111 (as',bs') <- separate cms mods [] []
1113 let as_to_add = as' \\ (as ++ bs)
1114 bs_to_add = bs' \\ (as ++ bs)
1116 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
1119 removeFromContext mods = do
1121 (as,bs) <- io (GHC.getContext cms)
1123 (as_to_remove,bs_to_remove) <- separate cms mods [] []
1125 let as' = as \\ (as_to_remove ++ bs_to_remove)
1126 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1128 io (GHC.setContext cms as' bs')
1130 ----------------------------------------------------------------------------
1133 -- set options in the interpreter. Syntax is exactly the same as the
1134 -- ghc command line, except that certain options aren't available (-C,
1137 -- This is pretty fragile: most options won't work as expected. ToDo:
1138 -- figure out which ones & disallow them.
1140 setCmd :: String -> GHCi ()
1142 = do st <- getGHCiState
1143 let opts = options st
1144 io $ putStrLn (showSDoc (
1145 text "options currently set: " <>
1148 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1152 ("args":args) -> setArgs args
1153 ("prog":prog) -> setProg prog
1154 ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
1155 wds -> setOptions wds
1159 setGHCiState st{ args = args }
1163 setGHCiState st{ progname = prog }
1165 io (hPutStrLn stderr "syntax: :set prog <progname>")
1167 setPrompt value = do
1170 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1171 else setGHCiState st{ prompt = remQuotes value }
1173 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1177 do -- first, deal with the GHCi opts (+s, +t, etc.)
1178 let (plus_opts, minus_opts) = partition isPlus wds
1179 mapM_ setOpt plus_opts
1181 -- then, dynamic flags
1182 dflags <- getDynFlags
1183 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1186 -- update things if the users wants more packages
1188 let new_packages = pkgs_after \\ pkgs_before
1189 when (not (null new_packages)) $
1190 newPackages new_packages
1193 if (not (null leftovers))
1194 then throwDyn (CmdLineError ("unrecognised flags: " ++
1199 unsetOptions :: String -> GHCi ()
1201 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1202 let opts = words str
1203 (minus_opts, rest1) = partition isMinus opts
1204 (plus_opts, rest2) = partition isPlus rest1
1206 if (not (null rest2))
1207 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1210 mapM_ unsetOpt plus_opts
1212 -- can't do GHC flags for now
1213 if (not (null minus_opts))
1214 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1217 isMinus ('-':s) = True
1220 isPlus ('+':s) = True
1224 = case strToGHCiOpt str of
1225 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1226 Just o -> setOption o
1229 = case strToGHCiOpt str of
1230 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1231 Just o -> unsetOption o
1233 strToGHCiOpt :: String -> (Maybe GHCiOption)
1234 strToGHCiOpt "s" = Just ShowTiming
1235 strToGHCiOpt "t" = Just ShowType
1236 strToGHCiOpt "r" = Just RevertCAFs
1237 strToGHCiOpt _ = Nothing
1239 optToStr :: GHCiOption -> String
1240 optToStr ShowTiming = "s"
1241 optToStr ShowType = "t"
1242 optToStr RevertCAFs = "r"
1245 newPackages new_pkgs = do -- The new packages are already in v_Packages
1246 session <- getSession
1247 io (GHC.setTargets session [])
1248 io (GHC.load session Nothing)
1249 dflags <- getDynFlags
1250 io (linkPackages dflags new_pkgs)
1251 setContextAfterLoad []
1254 -- ---------------------------------------------------------------------------
1259 ["modules" ] -> showModules
1260 ["bindings"] -> showBindings
1261 ["linker"] -> io showLinkerState
1262 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1265 session <- getSession
1266 let show_one ms = do m <- io (GHC.showModule session ms)
1268 graph <- io (GHC.getModuleGraph session)
1269 mapM_ show_one graph
1273 unqual <- io (GHC.getPrintUnqual s)
1274 bindings <- io (GHC.getBindings s)
1275 mapM_ showTyThing bindings
1278 showTyThing (AnId id) = do
1279 ty' <- cleanType (GHC.idType id)
1280 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1282 showTyThing _ = return ()
1284 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1285 cleanType :: Type -> GHCi Type
1287 dflags <- getDynFlags
1288 if dopt Opt_GlasgowExts dflags
1290 else return $! GHC.dropForAlls ty
1292 -- -----------------------------------------------------------------------------
1295 completeNone :: String -> IO [String]
1296 completeNone w = return []
1299 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1300 completeWord w start end = do
1301 line <- Readline.getLineBuffer
1303 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1305 | Just c <- is_cmd line -> do
1306 maybe_cmd <- lookupCommand c
1307 let (n,w') = selectWord (words' 0 line)
1309 Nothing -> return Nothing
1310 Just (_,_,False,complete) -> wrapCompleter complete w
1311 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1312 return (map (drop n) rets)
1313 in wrapCompleter complete' w'
1315 --printf "complete %s, start = %d, end = %d\n" w start end
1316 wrapCompleter completeIdentifier w
1317 where words' _ [] = []
1318 words' n str = let (w,r) = break isSpace str
1319 (s,r') = span isSpace r
1320 in (n,w):words' (n+length w+length s) r'
1321 -- In a Haskell expression we want to parse 'a-b' as three words
1322 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1323 -- only be a single word.
1324 selectWord [] = (0,w)
1325 selectWord ((offset,x):xs)
1326 | offset+length x >= start = (start-offset,take (end-offset) x)
1327 | otherwise = selectWord xs
1330 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1331 | otherwise = Nothing
1334 cmds <- readIORef commands
1335 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1337 completeMacro w = do
1338 cmds <- readIORef commands
1339 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1340 return (filter (w `isPrefixOf`) cmds')
1342 completeIdentifier w = do
1344 rdrs <- GHC.getRdrNamesInScope s
1345 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1347 completeModule w = do
1349 dflags <- GHC.getSessionDynFlags s
1350 let pkg_mods = allExposedModules dflags
1351 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1353 completeHomeModule w = do
1355 g <- GHC.getModuleGraph s
1356 let home_mods = map GHC.ms_mod g
1357 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1359 completeSetOptions w = do
1360 return (filter (w `isPrefixOf`) options)
1361 where options = "args":"prog":allFlags
1363 completeFilename = Readline.filenameCompletionFunction
1365 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1367 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1368 unionComplete f1 f2 w = do
1373 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1374 wrapCompleter fun w = do
1377 [] -> return Nothing
1378 [x] -> return (Just (x,[]))
1379 xs -> case getCommonPrefix xs of
1380 "" -> return (Just ("",xs))
1381 pref -> return (Just (pref,xs))
1383 getCommonPrefix :: [String] -> String
1384 getCommonPrefix [] = ""
1385 getCommonPrefix (s:ss) = foldl common s ss
1386 where common s "" = s
1388 common (c:cs) (d:ds)
1389 | c == d = c : common cs ds
1392 allExposedModules :: DynFlags -> [Module]
1393 allExposedModules dflags
1394 = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1396 pkg_db = pkgIdMap (pkgState dflags)
1398 completeCmd = completeNone
1399 completeMacro = completeNone
1400 completeIdentifier = completeNone
1401 completeModule = completeNone
1402 completeHomeModule = completeNone
1403 completeSetOptions = completeNone
1404 completeFilename = completeNone
1405 completeHomeModuleOrFile=completeNone
1408 -----------------------------------------------------------------------------
1411 data GHCiState = GHCiState
1416 session :: GHC.Session,
1417 options :: [GHCiOption]
1421 = ShowTiming -- show time/allocs after evaluation
1422 | ShowType -- show the type of expressions
1423 | RevertCAFs -- revert CAFs after every evaluation
1426 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1428 startGHCi :: GHCi a -> GHCiState -> IO a
1429 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1431 instance Monad GHCi where
1432 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1433 return a = GHCi $ \s -> return a
1435 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1436 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1437 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1439 getGHCiState = GHCi $ \r -> readIORef r
1440 setGHCiState s = GHCi $ \r -> writeIORef r s
1442 -- for convenience...
1443 getSession = getGHCiState >>= return . session
1445 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
1446 no_saved_sess = error "no saved_ses"
1447 saveSession = getSession >>= io . writeIORef saved_sess
1448 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
1449 restoreSession = readIORef saved_sess
1453 io (GHC.getSessionDynFlags s)
1454 setDynFlags dflags = do
1456 io (GHC.setSessionDynFlags s dflags)
1458 isOptionSet :: GHCiOption -> GHCi Bool
1460 = do st <- getGHCiState
1461 return (opt `elem` options st)
1463 setOption :: GHCiOption -> GHCi ()
1465 = do st <- getGHCiState
1466 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1468 unsetOption :: GHCiOption -> GHCi ()
1470 = do st <- getGHCiState
1471 setGHCiState (st{ options = filter (/= opt) (options st) })
1473 io :: IO a -> GHCi a
1474 io m = GHCi { unGHCi = \s -> m >>= return }
1476 -----------------------------------------------------------------------------
1477 -- recursive exception handlers
1479 -- Don't forget to unblock async exceptions in the handler, or if we're
1480 -- in an exception loop (eg. let a = error a in a) the ^C exception
1481 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1483 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1484 ghciHandle h (GHCi m) = GHCi $ \s ->
1485 Exception.catch (m s)
1486 (\e -> unGHCi (ghciUnblock (h e)) s)
1488 ghciUnblock :: GHCi a -> GHCi a
1489 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1491 -----------------------------------------------------------------------------
1492 -- timing & statistics
1494 timeIt :: GHCi a -> GHCi a
1496 = do b <- isOptionSet ShowTiming
1499 else do allocs1 <- io $ getAllocations
1500 time1 <- io $ getCPUTime
1502 allocs2 <- io $ getAllocations
1503 time2 <- io $ getCPUTime
1504 io $ printTimes (fromIntegral (allocs2 - allocs1))
1508 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1509 -- defined in ghc/rts/Stats.c
1511 printTimes :: Integer -> Integer -> IO ()
1512 printTimes allocs psecs
1513 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1514 secs_str = showFFloat (Just 2) secs
1515 putStrLn (showSDoc (
1516 parens (text (secs_str "") <+> text "secs" <> comma <+>
1517 text (show allocs) <+> text "bytes")))
1519 -----------------------------------------------------------------------------
1526 -- Have to turn off buffering again, because we just
1527 -- reverted stdout, stderr & stdin to their defaults.
1529 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1530 -- Make it "safe", just in case
1532 -- -----------------------------------------------------------------------------
1535 expandPath :: String -> GHCi String
1537 case dropWhile isSpace path of
1539 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1540 return (tilde ++ '/':d)