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 )
70 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
74 import Control.Concurrent ( yield ) -- Used in readline loop
75 import System.Console.Readline as Readline
80 import Control.Exception as Exception
82 -- import Control.Concurrent
86 import Data.Int ( Int64 )
87 import Data.Maybe ( isJust, fromMaybe, catMaybes )
90 import System.Environment
91 import System.Exit ( exitWith, ExitCode(..) )
92 import System.Directory
94 import System.IO.Error as IO
96 import Control.Monad as Monad
97 import Foreign.StablePtr ( newStablePtr )
100 import GHC.Exts ( unsafeCoerce# )
101 import GHC.IOBase ( IOErrorType(InvalidArgument) )
103 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
105 import System.Posix.Internals ( setNonBlockingFD )
107 -----------------------------------------------------------------------------
111 " / _ \\ /\\ /\\/ __(_)\n"++
112 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
113 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
114 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
116 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
117 cmdName (n,_,_,_) = n
119 GLOBAL_VAR(commands, builtin_commands, [Command])
121 builtin_commands :: [Command]
123 ("add", keepGoingPaths addModule, False, completeFilename),
124 ("browse", keepGoing browseCmd, False, completeModule),
125 ("cd", keepGoing changeDirectory, False, completeFilename),
126 ("def", keepGoing defineMacro, False, completeIdentifier),
127 ("help", keepGoing help, False, completeNone),
128 ("?", keepGoing help, False, completeNone),
129 ("info", keepGoing info, False, completeIdentifier),
130 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
131 ("module", keepGoing setContext, False, completeModule),
132 ("main", keepGoing runMain, False, completeIdentifier),
133 ("reload", keepGoing reloadModule, False, completeNone),
134 ("check", keepGoing checkModule, False, completeHomeModule),
135 ("set", keepGoing setCmd, True, completeSetOptions),
136 ("show", keepGoing showCmd, False, completeNone),
137 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
138 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
139 ("type", keepGoing typeOfExpr, False, completeIdentifier),
140 ("kind", keepGoing kindOfType, False, completeIdentifier),
141 ("unset", keepGoing unsetOptions, True, completeSetOptions),
142 ("undef", keepGoing undefineMacro, False, completeMacro),
143 ("quit", quit, False, completeNone)
146 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
147 keepGoing a str = a str >> return False
149 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
150 keepGoingPaths a str = a (toArgs str) >> return False
152 shortHelpText = "use :? for help.\n"
154 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
156 " Commands available from the prompt:\n" ++
158 " <stmt> evaluate/run <stmt>\n" ++
159 " :add <filename> ... add module(s) to the current target set\n" ++
160 " :browse [*]<module> display the names defined by <module>\n" ++
161 " :cd <dir> change directory to <dir>\n" ++
162 " :def <cmd> <expr> define a command :<cmd>\n" ++
163 " :help, :? display this list of commands\n" ++
164 " :info [<name> ...] display information about the given names\n" ++
165 " :load <filename> ... load module(s) and their dependents\n" ++
166 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
167 " :main [<arguments> ...] run the main function with the given arguments\n" ++
168 " :reload reload the current module set\n" ++
170 " :set <option> ... set options\n" ++
171 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
172 " :set prog <progname> set the value returned by System.getProgName\n" ++
173 " :set prompt <prompt> set the prompt used in GHCi\n" ++
175 " :show modules show the currently loaded modules\n" ++
176 " :show bindings show the current bindings made at the prompt\n" ++
178 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
179 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
180 " :type <expr> show the type of <expr>\n" ++
181 " :kind <type> show the kind of <type>\n" ++
182 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
183 " :unset <option> ... unset options\n" ++
184 " :quit exit GHCi\n" ++
185 " :!<command> run the shell command <command>\n" ++
187 " Options for ':set' and ':unset':\n" ++
189 " +r revert top-level expressions after each evaluation\n" ++
190 " +s print timing/memory stats after each evaluation\n" ++
191 " +t print type after evaluation\n" ++
192 " -<flags> most GHC command line flags can also be set here\n" ++
193 " (eg. -v2, -fglasgow-exts, etc.)\n"
196 #if defined(GHCI) && defined(BREAKPOINT)
197 globaliseAndTidy :: Id -> Id
199 -- Give the Id a Global Name, and tidy its type
200 = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
202 tidy_type = tidyTopType (idType id)
205 printScopeMsg :: Session -> String -> [Id] -> IO ()
206 printScopeMsg session location ids
207 = GHC.getPrintUnqual session >>= \unqual ->
208 printForUser stdout unqual $
209 text "Local bindings in scope:" $$
210 nest 2 (pprWithCommas showId ids)
211 where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
213 jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
214 jumpCondFunction session ptr hValues location True b = b
215 jumpCondFunction session ptr hValues location False b
216 = jumpFunction session ptr hValues location b
218 jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
219 jumpFunction session@(Session ref) (I# idsPtr) hValues location b
221 do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
222 let names = map idName ids
223 ASSERT (length names == length hValues) return ()
224 printScopeMsg session location ids
225 hsc_env <- readIORef ref
227 let ictxt = hsc_IC hsc_env
228 global_ids = map globaliseAndTidy ids
229 rn_env = ic_rn_local_env ictxt
230 type_env = ic_type_env ictxt
231 bound_names = map idName global_ids
232 new_rn_env = extendLocalRdrEnv rn_env bound_names
233 -- Remove any shadowed bindings from the type_env;
234 -- they are inaccessible but might, I suppose, cause
235 -- a space leak if we leave them there
236 shadowed = [ n | name <- bound_names,
237 let rdr_name = mkRdrUnqual (nameOccName name),
238 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
239 filtered_type_env = delListFromNameEnv type_env shadowed
240 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
241 new_ic = ictxt { ic_rn_local_env = new_rn_env,
242 ic_type_env = new_type_env }
243 writeIORef ref (hsc_env { hsc_IC = new_ic })
244 is_tty <- hIsTerminalDevice stdin
245 withExtendedLinkEnv (zip names hValues) $
246 startGHCi (interactiveLoop is_tty True)
247 GHCiState{ progname = "<interactive>",
249 prompt = location++"> ",
252 writeIORef ref hsc_env
253 putStrLn $ "Returning to normal execution..."
257 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
258 interactiveUI session srcs maybe_expr = do
259 #if defined(GHCI) && defined(BREAKPOINT)
260 initDynLinker =<< GHC.getSessionDynFlags session
261 extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
262 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
264 -- HACK! If we happen to get into an infinite loop (eg the user
265 -- types 'let x=x in x' at the prompt), then the thread will block
266 -- on a blackhole, and become unreachable during GC. The GC will
267 -- detect that it is unreachable and send it the NonTermination
268 -- exception. However, since the thread is unreachable, everything
269 -- it refers to might be finalized, including the standard Handles.
270 -- This sounds like a bug, but we don't have a good solution right
277 hSetBuffering stdout NoBuffering
279 -- Initialise buffering for the *interpreted* I/O system
280 initInterpBuffering session
282 -- We don't want the cmd line to buffer any input that might be
283 -- intended for the program, so unbuffer stdin.
284 hSetBuffering stdin NoBuffering
286 -- initial context is just the Prelude
287 GHC.setContext session [] [prelude_mod]
291 Readline.setAttemptedCompletionFunction (Just completeWord)
292 --Readline.parseAndBind "set show-all-if-ambiguous 1"
294 let symbols = "!#$%&*+/<=>?@\\^|-~"
295 specials = "(),;[]`{}"
297 word_break_chars = spaces ++ specials ++ symbols
299 Readline.setBasicWordBreakCharacters word_break_chars
300 Readline.setCompleterWordBreakCharacters word_break_chars
303 startGHCi (runGHCi srcs maybe_expr)
304 GHCiState{ progname = "<interactive>",
311 Readline.resetTerminal Nothing
316 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
317 runGHCi paths maybe_expr = do
318 let read_dot_files = not opt_IgnoreDotGhci
320 when (read_dot_files) $ do
323 exists <- io (doesFileExist file)
325 dir_ok <- io (checkPerms ".")
326 file_ok <- io (checkPerms file)
327 when (dir_ok && file_ok) $ do
328 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
331 Right hdl -> fileLoop hdl False
333 when (read_dot_files) $ do
334 -- Read in $HOME/.ghci
335 either_dir <- io (IO.try (getEnv "HOME"))
339 cwd <- io (getCurrentDirectory)
340 when (dir /= cwd) $ do
341 let file = dir ++ "/.ghci"
342 ok <- io (checkPerms file)
344 either_hdl <- io (IO.try (openFile file ReadMode))
347 Right hdl -> fileLoop hdl False
349 -- Perform a :load for files given on the GHCi command line
350 -- When in -e mode, if the load fails then we want to stop
351 -- immediately rather than going on to evaluate the expression.
352 when (not (null paths)) $ do
353 ok <- ghciHandle (\e -> do showException e; return Failed) $
355 when (isJust maybe_expr && failed ok) $
356 io (exitWith (ExitFailure 1))
358 -- if verbosity is greater than 0, or we are connected to a
359 -- terminal, display the prompt in the interactive loop.
360 is_tty <- io (hIsTerminalDevice stdin)
361 dflags <- getDynFlags
362 let show_prompt = verbosity dflags > 0 || is_tty
367 #if defined(mingw32_HOST_OS)
368 -- The win32 Console API mutates the first character of
369 -- type-ahead when reading from it in a non-buffered manner. Work
370 -- around this by flushing the input buffer of type-ahead characters,
371 -- but only if stdin is available.
372 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
374 Left err | isDoesNotExistError err -> return ()
375 | otherwise -> io (ioError err)
376 Right () -> return ()
378 -- initialise the console if necessary
381 -- enter the interactive loop
382 interactiveLoop is_tty show_prompt
384 -- just evaluate the expression we were given
389 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
392 interactiveLoop is_tty show_prompt =
393 -- Ignore ^C exceptions caught here
394 ghciHandleDyn (\e -> case e of
396 #if defined(mingw32_HOST_OS)
399 interactiveLoop is_tty show_prompt
400 _other -> return ()) $
402 ghciUnblock $ do -- unblock necessary if we recursed from the
403 -- exception handler above.
405 -- read commands from stdin
409 else fileLoop stdin show_prompt
411 fileLoop stdin show_prompt
415 -- NOTE: We only read .ghci files if they are owned by the current user,
416 -- and aren't world writable. Otherwise, we could be accidentally
417 -- running code planted by a malicious third party.
419 -- Furthermore, We only read ./.ghci if . is owned by the current user
420 -- and isn't writable by anyone else. I think this is sufficient: we
421 -- don't need to check .. and ../.. etc. because "." always refers to
422 -- the same directory while a process is running.
424 checkPerms :: String -> IO Bool
426 #ifdef mingw32_HOST_OS
429 Util.handle (\_ -> return False) $ do
430 st <- getFileStatus name
432 if fileOwner st /= me then do
433 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
436 let mode = fileMode st
437 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
438 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
440 putStrLn $ "*** WARNING: " ++ name ++
441 " is writable by someone else, IGNORING!"
446 fileLoop :: Handle -> Bool -> GHCi ()
447 fileLoop hdl show_prompt = do
448 session <- getSession
449 (mod,imports) <- io (GHC.getContext session)
451 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
452 l <- io (IO.try (hGetLine hdl))
454 Left e | isEOFError e -> return ()
455 | InvalidArgument <- etype -> return ()
456 | otherwise -> io (ioError e)
457 where etype = ioeGetErrorType e
458 -- treat InvalidArgument in the same way as EOF:
459 -- this can happen if the user closed stdin, or
460 -- perhaps did getContents which closes stdin at
463 case removeSpaces l of
464 "" -> fileLoop hdl show_prompt
465 l -> do quit <- runCommand l
466 if quit then return () else fileLoop hdl show_prompt
468 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
469 stringLoop [] = return False
470 stringLoop (s:ss) = do
471 case removeSpaces s of
473 l -> do quit <- runCommand l
474 if quit then return True else stringLoop ss
476 mkPrompt toplevs exports prompt
477 = showSDoc $ f prompt
479 f ('%':'s':xs) = perc_s <> f xs
480 f ('%':'%':xs) = char '%' <> f xs
481 f (x:xs) = char x <> f xs
484 perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+>
485 hsep (map pprModule exports)
489 readlineLoop :: GHCi ()
491 session <- getSession
492 (mod,imports) <- io (GHC.getContext session)
494 saveSession -- for use by completion
496 l <- io (readline (mkPrompt mod imports (prompt st))
497 `finally` setNonBlockingFD 0)
498 -- readline sometimes puts stdin into blocking mode,
499 -- so we need to put it back for the IO library
504 case removeSpaces l of
509 if quit then return () else readlineLoop
512 runCommand :: String -> GHCi Bool
513 runCommand c = ghciHandle handler (doCommand c)
515 doCommand (':' : command) = specialCommand command
517 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
520 -- This version is for the GHC command-line option -e. The only difference
521 -- from runCommand is that it catches the ExitException exception and
522 -- exits, rather than printing out the exception.
523 runCommandEval c = ghciHandle handleEval (doCommand c)
525 handleEval (ExitException code) = io (exitWith code)
526 handleEval e = do showException e
527 io (exitWith (ExitFailure 1))
529 doCommand (':' : command) = specialCommand command
531 = do nms <- runStmt stmt
533 Nothing -> io (exitWith (ExitFailure 1))
534 -- failure to run the command causes exit(1) for ghc -e.
535 _ -> finishEvalExpr nms
537 -- This is the exception handler for exceptions generated by the
538 -- user's code; it normally just prints out the exception. The
539 -- handler must be recursive, in case showing the exception causes
540 -- more exceptions to be raised.
542 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
543 -- raising another exception. We therefore don't put the recursive
544 -- handler arond the flushing operation, so if stderr is closed
545 -- GHCi will just die gracefully rather than going into an infinite loop.
546 handler :: Exception -> GHCi Bool
547 handler exception = do
549 io installSignalHandlers
550 ghciHandle handler (showException exception >> return False)
552 showException (DynException dyn) =
553 case fromDynamic dyn of
554 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
555 Just Interrupted -> io (putStrLn "Interrupted.")
556 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
557 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
558 Just other_ghc_ex -> io (print other_ghc_ex)
560 showException other_exception
561 = io (putStrLn ("*** Exception: " ++ show other_exception))
563 runStmt :: String -> GHCi (Maybe [Name])
565 | null (filter (not.isSpace) stmt) = return (Just [])
567 = do st <- getGHCiState
568 session <- getSession
569 result <- io $ withProgName (progname st) $ withArgs (args st) $
570 GHC.runStmt session stmt
572 GHC.RunFailed -> return Nothing
573 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
574 GHC.RunOk names -> return (Just names)
576 -- possibly print the type and revert CAFs after evaluating an expression
577 finishEvalExpr mb_names
578 = do b <- isOptionSet ShowType
579 session <- getSession
582 Just names -> when b (mapM_ (showTypeOfName session) names)
585 io installSignalHandlers
586 b <- isOptionSet RevertCAFs
587 io (when b revertCAFs)
590 showTypeOfName :: Session -> Name -> GHCi ()
591 showTypeOfName session n
592 = do maybe_tything <- io (GHC.lookupName session n)
593 case maybe_tything of
595 Just thing -> showTyThing thing
597 showForUser :: SDoc -> GHCi String
599 session <- getSession
600 unqual <- io (GHC.getPrintUnqual session)
601 return $! showSDocForUser unqual doc
603 specialCommand :: String -> GHCi Bool
604 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
605 specialCommand str = do
606 let (cmd,rest) = break isSpace str
607 maybe_cmd <- io (lookupCommand cmd)
609 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
610 ++ shortHelpText) >> return False)
611 Just (_,f,_,_) -> f (dropWhile isSpace rest)
613 lookupCommand :: String -> IO (Maybe Command)
614 lookupCommand str = do
615 cmds <- readIORef commands
616 -- look for exact match first, then the first prefix match
617 case [ c | c <- cmds, str == cmdName c ] of
618 c:_ -> return (Just c)
619 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
621 c:_ -> return (Just c)
623 -----------------------------------------------------------------------------
624 -- To flush buffers for the *interpreted* computation we need
625 -- to refer to *its* stdout/stderr handles
627 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
628 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
630 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
631 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
632 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
634 initInterpBuffering :: Session -> IO ()
635 initInterpBuffering session
636 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
639 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
640 other -> panic "interactiveUI:setBuffering"
642 maybe_hval <- GHC.compileExpr session flush_cmd
644 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
645 _ -> panic "interactiveUI:flush"
647 turnOffBuffering -- Turn it off right now
652 flushInterpBuffers :: GHCi ()
654 = io $ do Monad.join (readIORef flush_interp)
657 turnOffBuffering :: IO ()
659 = do Monad.join (readIORef turn_off_buffering)
662 -----------------------------------------------------------------------------
665 help :: String -> GHCi ()
666 help _ = io (putStr helpText)
668 info :: String -> GHCi ()
669 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
670 info s = do { let names = words s
671 ; session <- getSession
672 ; dflags <- getDynFlags
673 ; let exts = dopt Opt_GlasgowExts dflags
674 ; mapM_ (infoThing exts session) names }
676 infoThing exts session str = io $ do
677 names <- GHC.parseName session str
678 let filtered = filterOutChildren names
679 mb_stuffs <- mapM (GHC.getInfo session) filtered
680 unqual <- GHC.getPrintUnqual session
681 putStrLn (showSDocForUser unqual $
682 vcat (intersperse (text "") $
683 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
685 -- Filter out names whose parent is also there Good
686 -- example is '[]', which is both a type and data
687 -- constructor in the same type
688 filterOutChildren :: [Name] -> [Name]
689 filterOutChildren names = filter (not . parent_is_there) names
690 where parent_is_there n
691 | Just p <- GHC.nameParent_maybe n = p `elem` names
694 pprInfo exts (thing, fixity, insts)
695 = pprTyThingInContextLoc exts thing
696 $$ show_fixity fixity
697 $$ vcat (map GHC.pprInstance insts)
700 | fix == GHC.defaultFixity = empty
701 | otherwise = ppr fix <+> ppr (GHC.getName thing)
703 -----------------------------------------------------------------------------
706 runMain :: String -> GHCi ()
708 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
709 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
712 addModule :: [FilePath] -> GHCi ()
714 io (revertCAFs) -- always revert CAFs on load/add.
715 files <- mapM expandPath files
716 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
717 session <- getSession
718 io (mapM_ (GHC.addTarget session) targets)
719 ok <- io (GHC.load session LoadAllTargets)
722 changeDirectory :: String -> GHCi ()
723 changeDirectory dir = do
724 session <- getSession
725 graph <- io (GHC.getModuleGraph session)
726 when (not (null graph)) $
727 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
728 io (GHC.setTargets session [])
729 io (GHC.load session LoadAllTargets)
730 setContextAfterLoad session []
731 io (GHC.workingDirectoryChanged session)
732 dir <- expandPath dir
733 io (setCurrentDirectory dir)
735 defineMacro :: String -> GHCi ()
737 let (macro_name, definition) = break isSpace s
738 cmds <- io (readIORef commands)
740 then throwDyn (CmdLineError "invalid macro name")
742 if (macro_name `elem` map cmdName cmds)
743 then throwDyn (CmdLineError
744 ("command '" ++ macro_name ++ "' is already defined"))
747 -- give the expression a type signature, so we can be sure we're getting
748 -- something of the right type.
749 let new_expr = '(' : definition ++ ") :: String -> IO String"
751 -- compile the expression
753 maybe_hv <- io (GHC.compileExpr cms new_expr)
756 Just hv -> io (writeIORef commands --
757 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
759 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
761 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
762 stringLoop (lines str)
764 undefineMacro :: String -> GHCi ()
765 undefineMacro macro_name = do
766 cmds <- io (readIORef commands)
767 if (macro_name `elem` map cmdName builtin_commands)
768 then throwDyn (CmdLineError
769 ("command '" ++ macro_name ++ "' cannot be undefined"))
771 if (macro_name `notElem` map cmdName cmds)
772 then throwDyn (CmdLineError
773 ("command '" ++ macro_name ++ "' not defined"))
775 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
778 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
779 loadModule fs = timeIt (loadModule' fs)
781 loadModule_ :: [FilePath] -> GHCi ()
782 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
784 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
785 loadModule' files = do
786 session <- getSession
789 io (GHC.setTargets session [])
790 io (GHC.load session LoadAllTargets)
793 let (filenames, phases) = unzip files
794 exp_filenames <- mapM expandPath filenames
795 let files' = zip exp_filenames phases
796 targets <- io (mapM (uncurry GHC.guessTarget) files')
798 -- NOTE: we used to do the dependency anal first, so that if it
799 -- fails we didn't throw away the current set of modules. This would
800 -- require some re-working of the GHC interface, so we'll leave it
801 -- as a ToDo for now.
803 io (GHC.setTargets session targets)
804 ok <- io (GHC.load session LoadAllTargets)
808 checkModule :: String -> GHCi ()
810 let modl = GHC.mkModule m
811 session <- getSession
812 result <- io (GHC.checkModule session modl)
814 Nothing -> io $ putStrLn "Nothing"
815 Just r -> io $ putStrLn (showSDoc (
816 case checkedModuleInfo r of
817 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
819 (local,global) = partition ((== modl) . GHC.nameModule) scope
821 (text "global names: " <+> ppr global) $$
822 (text "local names: " <+> ppr local)
824 afterLoad (successIf (isJust result)) session
826 reloadModule :: String -> GHCi ()
828 io (revertCAFs) -- always revert CAFs on reload.
829 session <- getSession
830 ok <- io (GHC.load session LoadAllTargets)
833 io (revertCAFs) -- always revert CAFs on reload.
834 session <- getSession
835 ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m)))
838 afterLoad ok session = do
839 io (revertCAFs) -- always revert CAFs on load.
840 graph <- io (GHC.getModuleGraph session)
841 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
842 setContextAfterLoad session graph'
843 modulesLoadedMsg ok (map GHC.ms_mod graph')
844 #if defined(GHCI) && defined(BREAKPOINT)
845 io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
846 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
849 setContextAfterLoad session [] = do
850 io (GHC.setContext session [] [prelude_mod])
851 setContextAfterLoad session ms = do
852 -- load a target if one is available, otherwise load the topmost module.
853 targets <- io (GHC.getTargets session)
854 case [ m | Just m <- map (findTarget ms) targets ] of
856 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
857 load_this (last graph')
862 = case filter (`matches` t) ms of
866 summary `matches` Target (TargetModule m) _
867 = GHC.ms_mod summary == m
868 summary `matches` Target (TargetFile f _) _
869 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
870 summary `matches` target
873 load_this summary | m <- GHC.ms_mod summary = do
874 b <- io (GHC.moduleIsInterpreted session m)
875 if b then io (GHC.setContext session [m] [])
876 else io (GHC.setContext session [] [prelude_mod,m])
879 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
880 modulesLoadedMsg ok mods = do
881 dflags <- getDynFlags
882 when (verbosity dflags > 0) $ do
884 | null mods = text "none."
886 punctuate comma (map pprModule mods)) <> text "."
889 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
891 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
894 typeOfExpr :: String -> GHCi ()
896 = do cms <- getSession
897 maybe_ty <- io (GHC.exprType cms str)
900 Just ty -> do ty' <- cleanType ty
901 tystr <- showForUser (ppr ty')
902 io (putStrLn (str ++ " :: " ++ tystr))
904 kindOfType :: String -> GHCi ()
906 = do cms <- getSession
907 maybe_ty <- io (GHC.typeKind cms str)
910 Just ty -> do tystr <- showForUser (ppr ty)
911 io (putStrLn (str ++ " :: " ++ tystr))
913 quit :: String -> GHCi Bool
916 shellEscape :: String -> GHCi Bool
917 shellEscape str = io (system str >> return False)
919 -----------------------------------------------------------------------------
920 -- create tags file for currently loaded modules.
922 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
924 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
925 createCTagsFileCmd file = ghciCreateTagsFile CTags file
927 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
928 createETagsFileCmd file = ghciCreateTagsFile ETags file
930 data TagsKind = ETags | CTags
932 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
933 ghciCreateTagsFile kind file = do
934 session <- getSession
935 io $ createTagsFile session kind file
938 -- - remove restriction that all modules must be interpreted
939 -- (problem: we don't know source locations for entities unless
940 -- we compiled the module.
942 -- - extract createTagsFile so it can be used from the command-line
943 -- (probably need to fix first problem before this is useful).
945 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
946 createTagsFile session tagskind tagFile = do
947 graph <- GHC.getModuleGraph session
948 let ms = map GHC.ms_mod graph
950 is_interpreted <- GHC.moduleIsInterpreted session m
951 -- should we just skip these?
952 when (not is_interpreted) $
953 throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
955 mbModInfo <- GHC.getModuleInfo session m
957 | Just modinfo <- mbModInfo,
958 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
959 | otherwise = GHC.alwaysQualify
962 Just modInfo -> return $! listTags unqual modInfo
965 mtags <- mapM tagModule ms
966 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
968 Left e -> hPutStrLn stderr $ ioeGetErrorString e
971 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
972 listTags unqual modInfo =
973 [ tagInfo unqual name loc
974 | name <- GHC.modInfoExports modInfo
975 , let loc = nameSrcLoc name
979 type TagInfo = (String -- tag name
982 ,Int -- column number
985 -- get tag info, for later translation into Vim or Emacs style
986 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
987 tagInfo unqual name loc
988 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
989 , showSDocForUser unqual $ ftext (srcLocFile loc)
994 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
995 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
996 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
997 IO.try (writeFile file tags)
998 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
999 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
1000 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
1001 tagGroups <- mapM tagFileGroup groups
1002 IO.try (writeFile file $ concat tagGroups)
1004 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
1005 tagFileGroup group@((_,fileName,_,_):_) = do
1006 file <- readFile fileName -- need to get additional info from sources..
1007 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
1008 sortedGroup = sortLe byLine group
1009 tags = unlines $ perFile sortedGroup 1 0 $ lines file
1010 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
1011 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
1012 perFile (tagInfo:tags) (count+1) (pos+length line) lines
1013 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
1014 showETag tagInfo line pos : perFile tags count pos lines
1015 perFile tags count pos lines = []
1017 -- simple ctags format, for Vim et al
1018 showTag :: TagInfo -> String
1019 showTag (tag,file,lineNo,colNo)
1020 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
1022 -- etags format, for Emacs/XEmacs
1023 showETag :: TagInfo -> String -> Int -> String
1024 showETag (tag,file,lineNo,colNo) line charPos
1025 = take colNo line ++ tag
1027 ++ "\x01" ++ show lineNo
1028 ++ "," ++ show charPos
1030 -----------------------------------------------------------------------------
1031 -- Browsing a module's contents
1033 browseCmd :: String -> GHCi ()
1036 ['*':m] | looksLikeModuleName m -> browseModule m False
1037 [m] | looksLikeModuleName m -> browseModule m True
1038 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1040 browseModule m exports_only = do
1043 let modl = GHC.mkModule m
1044 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1045 when (not is_interpreted && not exports_only) $
1046 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1048 -- Temporarily set the context to the module we're interested in,
1049 -- just so we can get an appropriate PrintUnqualified
1050 (as,bs) <- io (GHC.getContext s)
1051 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
1052 else GHC.setContext s [modl] [])
1053 unqual <- io (GHC.getPrintUnqual s)
1054 io (GHC.setContext s as bs)
1056 mb_mod_info <- io $ GHC.getModuleInfo s modl
1058 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1061 | exports_only = GHC.modInfoExports mod_info
1062 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1064 filtered = filterOutChildren names
1066 things <- io $ mapM (GHC.lookupName s) filtered
1068 dflags <- getDynFlags
1069 let exts = dopt Opt_GlasgowExts dflags
1070 io (putStrLn (showSDocForUser unqual (
1071 vcat (map (pprTyThingInContext exts) (catMaybes things))
1073 -- ToDo: modInfoInstances currently throws an exception for
1074 -- package modules. When it works, we can do this:
1075 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1077 -----------------------------------------------------------------------------
1078 -- Setting the module context
1081 | all sensible mods = fn mods
1082 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1084 (fn, mods) = case str of
1085 '+':stuff -> (addToContext, words stuff)
1086 '-':stuff -> (removeFromContext, words stuff)
1087 stuff -> (newContext, words stuff)
1089 sensible ('*':m) = looksLikeModuleName m
1090 sensible m = looksLikeModuleName m
1092 newContext mods = do
1093 session <- getSession
1094 (as,bs) <- separate session mods [] []
1095 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
1096 io (GHC.setContext session as bs')
1098 separate :: Session -> [String] -> [Module] -> [Module]
1099 -> GHCi ([Module],[Module])
1100 separate session [] as bs = return (as,bs)
1101 separate session (('*':m):ms) as bs = do
1102 let modl = GHC.mkModule m
1103 b <- io (GHC.moduleIsInterpreted session modl)
1104 if b then separate session ms (modl:as) bs
1105 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1106 separate session (m:ms) as bs = separate session ms as (GHC.mkModule m:bs)
1108 prelude_mod = GHC.mkModule "Prelude"
1111 addToContext mods = do
1113 (as,bs) <- io (GHC.getContext cms)
1115 (as',bs') <- separate cms mods [] []
1117 let as_to_add = as' \\ (as ++ bs)
1118 bs_to_add = bs' \\ (as ++ bs)
1120 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
1123 removeFromContext mods = do
1125 (as,bs) <- io (GHC.getContext cms)
1127 (as_to_remove,bs_to_remove) <- separate cms mods [] []
1129 let as' = as \\ (as_to_remove ++ bs_to_remove)
1130 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1132 io (GHC.setContext cms as' bs')
1134 ----------------------------------------------------------------------------
1137 -- set options in the interpreter. Syntax is exactly the same as the
1138 -- ghc command line, except that certain options aren't available (-C,
1141 -- This is pretty fragile: most options won't work as expected. ToDo:
1142 -- figure out which ones & disallow them.
1144 setCmd :: String -> GHCi ()
1146 = do st <- getGHCiState
1147 let opts = options st
1148 io $ putStrLn (showSDoc (
1149 text "options currently set: " <>
1152 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1156 ("args":args) -> setArgs args
1157 ("prog":prog) -> setProg prog
1158 ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
1159 wds -> setOptions wds
1163 setGHCiState st{ args = args }
1167 setGHCiState st{ progname = prog }
1169 io (hPutStrLn stderr "syntax: :set prog <progname>")
1171 setPrompt value = do
1174 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1175 else setGHCiState st{ prompt = remQuotes value }
1177 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1181 do -- first, deal with the GHCi opts (+s, +t, etc.)
1182 let (plus_opts, minus_opts) = partition isPlus wds
1183 mapM_ setOpt plus_opts
1185 -- then, dynamic flags
1186 dflags <- getDynFlags
1187 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1190 -- update things if the users wants more packages
1192 let new_packages = pkgs_after \\ pkgs_before
1193 when (not (null new_packages)) $
1194 newPackages new_packages
1197 if (not (null leftovers))
1198 then throwDyn (CmdLineError ("unrecognised flags: " ++
1203 unsetOptions :: String -> GHCi ()
1205 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1206 let opts = words str
1207 (minus_opts, rest1) = partition isMinus opts
1208 (plus_opts, rest2) = partition isPlus rest1
1210 if (not (null rest2))
1211 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1214 mapM_ unsetOpt plus_opts
1216 -- can't do GHC flags for now
1217 if (not (null minus_opts))
1218 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1221 isMinus ('-':s) = True
1224 isPlus ('+':s) = True
1228 = case strToGHCiOpt str of
1229 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1230 Just o -> setOption o
1233 = case strToGHCiOpt str of
1234 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1235 Just o -> unsetOption o
1237 strToGHCiOpt :: String -> (Maybe GHCiOption)
1238 strToGHCiOpt "s" = Just ShowTiming
1239 strToGHCiOpt "t" = Just ShowType
1240 strToGHCiOpt "r" = Just RevertCAFs
1241 strToGHCiOpt _ = Nothing
1243 optToStr :: GHCiOption -> String
1244 optToStr ShowTiming = "s"
1245 optToStr ShowType = "t"
1246 optToStr RevertCAFs = "r"
1249 newPackages new_pkgs = do -- The new packages are already in v_Packages
1250 session <- getSession
1251 io (GHC.setTargets session [])
1252 io (GHC.load session Nothing)
1253 dflags <- getDynFlags
1254 io (linkPackages dflags new_pkgs)
1255 setContextAfterLoad []
1258 -- ---------------------------------------------------------------------------
1263 ["modules" ] -> showModules
1264 ["bindings"] -> showBindings
1265 ["linker"] -> io showLinkerState
1266 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1269 session <- getSession
1270 let show_one ms = do m <- io (GHC.showModule session ms)
1272 graph <- io (GHC.getModuleGraph session)
1273 mapM_ show_one graph
1277 unqual <- io (GHC.getPrintUnqual s)
1278 bindings <- io (GHC.getBindings s)
1279 mapM_ showTyThing bindings
1282 showTyThing (AnId id) = do
1283 ty' <- cleanType (GHC.idType id)
1284 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1286 showTyThing _ = return ()
1288 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1289 cleanType :: Type -> GHCi Type
1291 dflags <- getDynFlags
1292 if dopt Opt_GlasgowExts dflags
1294 else return $! GHC.dropForAlls ty
1296 -- -----------------------------------------------------------------------------
1299 completeNone :: String -> IO [String]
1300 completeNone w = return []
1303 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1304 completeWord w start end = do
1305 line <- Readline.getLineBuffer
1307 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1309 | Just c <- is_cmd line -> do
1310 maybe_cmd <- lookupCommand c
1311 let (n,w') = selectWord (words' 0 line)
1313 Nothing -> return Nothing
1314 Just (_,_,False,complete) -> wrapCompleter complete w
1315 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1316 return (map (drop n) rets)
1317 in wrapCompleter complete' w'
1319 --printf "complete %s, start = %d, end = %d\n" w start end
1320 wrapCompleter completeIdentifier w
1321 where words' _ [] = []
1322 words' n str = let (w,r) = break isSpace str
1323 (s,r') = span isSpace r
1324 in (n,w):words' (n+length w+length s) r'
1325 -- In a Haskell expression we want to parse 'a-b' as three words
1326 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1327 -- only be a single word.
1328 selectWord [] = (0,w)
1329 selectWord ((offset,x):xs)
1330 | offset+length x >= start = (start-offset,take (end-offset) x)
1331 | otherwise = selectWord xs
1334 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1335 | otherwise = Nothing
1338 cmds <- readIORef commands
1339 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1341 completeMacro w = do
1342 cmds <- readIORef commands
1343 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1344 return (filter (w `isPrefixOf`) cmds')
1346 completeIdentifier w = do
1348 rdrs <- GHC.getRdrNamesInScope s
1349 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1351 completeModule w = do
1353 dflags <- GHC.getSessionDynFlags s
1354 let pkg_mods = allExposedModules dflags
1355 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1357 completeHomeModule w = do
1359 g <- GHC.getModuleGraph s
1360 let home_mods = map GHC.ms_mod g
1361 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1363 completeSetOptions w = do
1364 return (filter (w `isPrefixOf`) options)
1365 where options = "args":"prog":allFlags
1367 completeFilename = Readline.filenameCompletionFunction
1369 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1371 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1372 unionComplete f1 f2 w = do
1377 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1378 wrapCompleter fun w = do
1381 [] -> return Nothing
1382 [x] -> return (Just (x,[]))
1383 xs -> case getCommonPrefix xs of
1384 "" -> return (Just ("",xs))
1385 pref -> return (Just (pref,xs))
1387 getCommonPrefix :: [String] -> String
1388 getCommonPrefix [] = ""
1389 getCommonPrefix (s:ss) = foldl common s ss
1390 where common s "" = s
1392 common (c:cs) (d:ds)
1393 | c == d = c : common cs ds
1396 allExposedModules :: DynFlags -> [Module]
1397 allExposedModules dflags
1398 = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1400 pkg_db = pkgIdMap (pkgState dflags)
1402 completeCmd = completeNone
1403 completeMacro = completeNone
1404 completeIdentifier = completeNone
1405 completeModule = completeNone
1406 completeHomeModule = completeNone
1407 completeSetOptions = completeNone
1408 completeFilename = completeNone
1409 completeHomeModuleOrFile=completeNone
1412 -----------------------------------------------------------------------------
1415 data GHCiState = GHCiState
1420 session :: GHC.Session,
1421 options :: [GHCiOption]
1425 = ShowTiming -- show time/allocs after evaluation
1426 | ShowType -- show the type of expressions
1427 | RevertCAFs -- revert CAFs after every evaluation
1430 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1432 startGHCi :: GHCi a -> GHCiState -> IO a
1433 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1435 instance Monad GHCi where
1436 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1437 return a = GHCi $ \s -> return a
1439 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1440 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1441 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1443 getGHCiState = GHCi $ \r -> readIORef r
1444 setGHCiState s = GHCi $ \r -> writeIORef r s
1446 -- for convenience...
1447 getSession = getGHCiState >>= return . session
1449 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
1450 no_saved_sess = error "no saved_ses"
1451 saveSession = getSession >>= io . writeIORef saved_sess
1452 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
1453 restoreSession = readIORef saved_sess
1457 io (GHC.getSessionDynFlags s)
1458 setDynFlags dflags = do
1460 io (GHC.setSessionDynFlags s dflags)
1462 isOptionSet :: GHCiOption -> GHCi Bool
1464 = do st <- getGHCiState
1465 return (opt `elem` options st)
1467 setOption :: GHCiOption -> GHCi ()
1469 = do st <- getGHCiState
1470 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1472 unsetOption :: GHCiOption -> GHCi ()
1474 = do st <- getGHCiState
1475 setGHCiState (st{ options = filter (/= opt) (options st) })
1477 io :: IO a -> GHCi a
1478 io m = GHCi { unGHCi = \s -> m >>= return }
1480 -----------------------------------------------------------------------------
1481 -- recursive exception handlers
1483 -- Don't forget to unblock async exceptions in the handler, or if we're
1484 -- in an exception loop (eg. let a = error a in a) the ^C exception
1485 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1487 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1488 ghciHandle h (GHCi m) = GHCi $ \s ->
1489 Exception.catch (m s)
1490 (\e -> unGHCi (ghciUnblock (h e)) s)
1492 ghciUnblock :: GHCi a -> GHCi a
1493 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1495 -----------------------------------------------------------------------------
1496 -- timing & statistics
1498 timeIt :: GHCi a -> GHCi a
1500 = do b <- isOptionSet ShowTiming
1503 else do allocs1 <- io $ getAllocations
1504 time1 <- io $ getCPUTime
1506 allocs2 <- io $ getAllocations
1507 time2 <- io $ getCPUTime
1508 io $ printTimes (fromIntegral (allocs2 - allocs1))
1512 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1513 -- defined in ghc/rts/Stats.c
1515 printTimes :: Integer -> Integer -> IO ()
1516 printTimes allocs psecs
1517 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1518 secs_str = showFFloat (Just 2) secs
1519 putStrLn (showSDoc (
1520 parens (text (secs_str "") <+> text "secs" <> comma <+>
1521 text (show allocs) <+> text "bytes")))
1523 -----------------------------------------------------------------------------
1530 -- Have to turn off buffering again, because we just
1531 -- reverted stdout, stderr & stdin to their defaults.
1533 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1534 -- Make it "safe", just in case
1536 -- ----------------------------------------------------------------------------
1539 expandPath :: String -> GHCi String
1541 case dropWhile isSpace path of
1543 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1544 return (tilde ++ '/':d)
1548 -- ----------------------------------------------------------------------------
1549 -- Windows console setup
1551 setUpConsole :: IO ()
1553 #ifdef mingw32_HOST_OS
1554 -- On Windows we need to set a known code page, otherwise the characters
1555 -- we read from the console will be be in some strange encoding, and
1556 -- similarly for characters we write to the console.
1558 -- At the moment, GHCi pretends all input is Latin-1. In the
1559 -- future we should support UTF-8, but for now we set the code pages
1562 -- It seems you have to set the font in the console window to
1563 -- a Unicode font in order for output to work properly,
1564 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1565 -- (see MSDN for SetConsoleOutputCP()).
1567 setConsoleCP 28591 -- ISO Latin-1
1568 setConsoleOutputCP 28591 -- ISO Latin-1