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,
30 import PrelNames ( breakpointJumpName, breakpointCondJumpName )
35 import GHC ( Session, dopt, DynFlag(..), Target(..),
36 TargetId(..), DynFlags(..),
37 pprModule, Type, Module, ModuleName, SuccessFlag(..),
38 TyThing(..), Name, LoadHowMuch(..), Phase,
39 GhcException(..), showGhcException,
40 CheckedModule(..), SrcLoc )
41 import DynFlags ( allFlags )
42 import Packages ( PackageState(..) )
43 import PackageConfig ( InstalledPackageInfo(..) )
44 import UniqFM ( eltsUFM )
48 -- for createtags (should these come via GHC?)
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, linkPackages )
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, isNothing, 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 )
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 ("e", keepGoing editFile, False, completeFilename),
127 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
128 ("edit", keepGoing editFile, False, completeFilename),
129 ("help", keepGoing help, False, completeNone),
130 ("?", keepGoing help, False, completeNone),
131 ("info", keepGoing info, False, completeIdentifier),
132 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
133 ("module", keepGoing setContext, False, completeModule),
134 ("main", keepGoing runMain, False, completeIdentifier),
135 ("reload", keepGoing reloadModule, False, completeNone),
136 ("check", keepGoing checkModule, False, completeHomeModule),
137 ("set", keepGoing setCmd, True, completeSetOptions),
138 ("show", keepGoing showCmd, False, completeNone),
139 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
140 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
141 ("type", keepGoing typeOfExpr, False, completeIdentifier),
142 ("kind", keepGoing kindOfType, False, completeIdentifier),
143 ("unset", keepGoing unsetOptions, True, completeSetOptions),
144 ("undef", keepGoing undefineMacro, False, completeMacro),
145 ("quit", quit, False, completeNone)
148 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
149 keepGoing a str = a str >> return False
151 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
152 keepGoingPaths a str = a (toArgs str) >> return False
154 shortHelpText = "use :? for help.\n"
156 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
158 " Commands available from the prompt:\n" ++
160 " <stmt> evaluate/run <stmt>\n" ++
161 " :add <filename> ... add module(s) to the current target set\n" ++
162 " :browse [*]<module> display the names defined by <module>\n" ++
163 " :cd <dir> change directory to <dir>\n" ++
164 " :def <cmd> <expr> define a command :<cmd>\n" ++
165 " :edit <file> edit file\n" ++
166 " :edit edit last module\n" ++
167 " :help, :? display this list of commands\n" ++
168 " :info [<name> ...] display information about the given names\n" ++
169 " :load <filename> ... load module(s) and their dependents\n" ++
170 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
171 " :main [<arguments> ...] run the main function with the given arguments\n" ++
172 " :reload reload the current module set\n" ++
174 " :set <option> ... set options\n" ++
175 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
176 " :set prog <progname> set the value returned by System.getProgName\n" ++
177 " :set prompt <prompt> set the prompt used in GHCi\n" ++
178 " :set editor <cmd> set the comand used for :edit\n" ++
180 " :show modules show the currently loaded modules\n" ++
181 " :show bindings show the current bindings made at the prompt\n" ++
183 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
184 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
185 " :type <expr> show the type of <expr>\n" ++
186 " :kind <type> show the kind of <type>\n" ++
187 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
188 " :unset <option> ... unset options\n" ++
189 " :quit exit GHCi\n" ++
190 " :!<command> run the shell command <command>\n" ++
192 " Options for ':set' and ':unset':\n" ++
194 " +r revert top-level expressions after each evaluation\n" ++
195 " +s print timing/memory stats after each evaluation\n" ++
196 " +t print type after evaluation\n" ++
197 " -<flags> most GHC command line flags can also be set here\n" ++
198 " (eg. -v2, -fglasgow-exts, etc.)\n"
201 #if defined(GHCI) && defined(BREAKPOINT)
202 globaliseAndTidy :: Id -> Id
204 -- Give the Id a Global Name, and tidy its type
205 = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
207 tidy_type = tidyTopType (idType id)
210 printScopeMsg :: Session -> String -> [Id] -> IO ()
211 printScopeMsg session location ids
212 = GHC.getPrintUnqual session >>= \unqual ->
213 printForUser stdout unqual $
214 text "Local bindings in scope:" $$
215 nest 2 (pprWithCommas showId ids)
216 where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
218 jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
219 jumpCondFunction session ptr hValues location True b = b
220 jumpCondFunction session ptr hValues location False b
221 = jumpFunction session ptr hValues location b
223 jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
224 jumpFunction session@(Session ref) (I# idsPtr) hValues location b
226 do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
227 let names = map idName ids
228 ASSERT (length names == length hValues) return ()
229 printScopeMsg session location ids
230 hsc_env <- readIORef ref
232 let ictxt = hsc_IC hsc_env
233 global_ids = map globaliseAndTidy ids
234 rn_env = ic_rn_local_env ictxt
235 type_env = ic_type_env ictxt
236 bound_names = map idName global_ids
237 new_rn_env = extendLocalRdrEnv rn_env bound_names
238 -- Remove any shadowed bindings from the type_env;
239 -- they are inaccessible but might, I suppose, cause
240 -- a space leak if we leave them there
241 shadowed = [ n | name <- bound_names,
242 let rdr_name = mkRdrUnqual (nameOccName name),
243 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
244 filtered_type_env = delListFromNameEnv type_env shadowed
245 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
246 new_ic = ictxt { ic_rn_local_env = new_rn_env,
247 ic_type_env = new_type_env }
248 writeIORef ref (hsc_env { hsc_IC = new_ic })
249 is_tty <- hIsTerminalDevice stdin
250 prel_mod <- GHC.findModule session prel_name Nothing
251 default_editor <- findEditor
252 withExtendedLinkEnv (zip names hValues) $
253 startGHCi (interactiveLoop is_tty True)
254 GHCiState{ progname = "<interactive>",
256 prompt = location++"> ",
257 editor = default_editor,
261 writeIORef ref hsc_env
262 putStrLn $ "Returning to normal execution..."
269 #ifdef mingw32_HOST_OS
270 GetWindowsDirectory ++ "\\notepad.exe", or something
275 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
276 interactiveUI session srcs maybe_expr = do
277 #if defined(GHCI) && defined(BREAKPOINT)
278 initDynLinker =<< GHC.getSessionDynFlags session
279 extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
280 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
282 -- HACK! If we happen to get into an infinite loop (eg the user
283 -- types 'let x=x in x' at the prompt), then the thread will block
284 -- on a blackhole, and become unreachable during GC. The GC will
285 -- detect that it is unreachable and send it the NonTermination
286 -- exception. However, since the thread is unreachable, everything
287 -- it refers to might be finalized, including the standard Handles.
288 -- This sounds like a bug, but we don't have a good solution right
294 -- Initialise buffering for the *interpreted* I/O system
295 initInterpBuffering session
297 when (isNothing maybe_expr) $ do
298 -- Only for GHCi (not runghc and ghc -e):
299 -- Turn buffering off for the compiled program's stdout/stderr
301 -- Turn buffering off for GHCi's stdout
303 hSetBuffering stdout NoBuffering
304 -- We don't want the cmd line to buffer any input that might be
305 -- intended for the program, so unbuffer stdin.
306 hSetBuffering stdin NoBuffering
308 -- initial context is just the Prelude
309 prel_mod <- GHC.findModule session prel_name Nothing
310 GHC.setContext session [] [prel_mod]
314 Readline.setAttemptedCompletionFunction (Just completeWord)
315 --Readline.parseAndBind "set show-all-if-ambiguous 1"
317 let symbols = "!#$%&*+/<=>?@\\^|-~"
318 specials = "(),;[]`{}"
320 word_break_chars = spaces ++ specials ++ symbols
322 Readline.setBasicWordBreakCharacters word_break_chars
323 Readline.setCompleterWordBreakCharacters word_break_chars
326 default_editor <- findEditor
328 startGHCi (runGHCi srcs maybe_expr)
329 GHCiState{ progname = "<interactive>",
332 editor = default_editor,
338 Readline.resetTerminal Nothing
343 prel_name = GHC.mkModuleName "Prelude"
345 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
346 runGHCi paths maybe_expr = do
347 let read_dot_files = not opt_IgnoreDotGhci
349 when (read_dot_files) $ do
352 exists <- io (doesFileExist file)
354 dir_ok <- io (checkPerms ".")
355 file_ok <- io (checkPerms file)
356 when (dir_ok && file_ok) $ do
357 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
360 Right hdl -> fileLoop hdl False
362 when (read_dot_files) $ do
363 -- Read in $HOME/.ghci
364 either_dir <- io (IO.try (getEnv "HOME"))
368 cwd <- io (getCurrentDirectory)
369 when (dir /= cwd) $ do
370 let file = dir ++ "/.ghci"
371 ok <- io (checkPerms file)
373 either_hdl <- io (IO.try (openFile file ReadMode))
376 Right hdl -> fileLoop hdl False
378 -- Perform a :load for files given on the GHCi command line
379 -- When in -e mode, if the load fails then we want to stop
380 -- immediately rather than going on to evaluate the expression.
381 when (not (null paths)) $ do
382 ok <- ghciHandle (\e -> do showException e; return Failed) $
384 when (isJust maybe_expr && failed ok) $
385 io (exitWith (ExitFailure 1))
387 -- if verbosity is greater than 0, or we are connected to a
388 -- terminal, display the prompt in the interactive loop.
389 is_tty <- io (hIsTerminalDevice stdin)
390 dflags <- getDynFlags
391 let show_prompt = verbosity dflags > 0 || is_tty
396 #if defined(mingw32_HOST_OS)
397 -- The win32 Console API mutates the first character of
398 -- type-ahead when reading from it in a non-buffered manner. Work
399 -- around this by flushing the input buffer of type-ahead characters,
400 -- but only if stdin is available.
401 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
403 Left err | isDoesNotExistError err -> return ()
404 | otherwise -> io (ioError err)
405 Right () -> return ()
407 -- initialise the console if necessary
410 -- enter the interactive loop
411 interactiveLoop is_tty show_prompt
413 -- just evaluate the expression we were given
418 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
421 interactiveLoop is_tty show_prompt =
422 -- Ignore ^C exceptions caught here
423 ghciHandleDyn (\e -> case e of
425 #if defined(mingw32_HOST_OS)
428 interactiveLoop is_tty show_prompt
429 _other -> return ()) $
431 ghciUnblock $ do -- unblock necessary if we recursed from the
432 -- exception handler above.
434 -- read commands from stdin
438 else fileLoop stdin show_prompt
440 fileLoop stdin show_prompt
444 -- NOTE: We only read .ghci files if they are owned by the current user,
445 -- and aren't world writable. Otherwise, we could be accidentally
446 -- running code planted by a malicious third party.
448 -- Furthermore, We only read ./.ghci if . is owned by the current user
449 -- and isn't writable by anyone else. I think this is sufficient: we
450 -- don't need to check .. and ../.. etc. because "." always refers to
451 -- the same directory while a process is running.
453 checkPerms :: String -> IO Bool
455 #ifdef mingw32_HOST_OS
458 Util.handle (\_ -> return False) $ do
459 st <- getFileStatus name
461 if fileOwner st /= me then do
462 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
465 let mode = fileMode st
466 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
467 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
469 putStrLn $ "*** WARNING: " ++ name ++
470 " is writable by someone else, IGNORING!"
475 fileLoop :: Handle -> Bool -> GHCi ()
476 fileLoop hdl show_prompt = do
477 session <- getSession
478 (mod,imports) <- io (GHC.getContext session)
480 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
481 l <- io (IO.try (hGetLine hdl))
483 Left e | isEOFError e -> return ()
484 | InvalidArgument <- etype -> return ()
485 | otherwise -> io (ioError e)
486 where etype = ioeGetErrorType e
487 -- treat InvalidArgument in the same way as EOF:
488 -- this can happen if the user closed stdin, or
489 -- perhaps did getContents which closes stdin at
492 case removeSpaces l of
493 "" -> fileLoop hdl show_prompt
494 l -> do quit <- runCommand l
495 if quit then return () else fileLoop hdl show_prompt
497 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
498 stringLoop [] = return False
499 stringLoop (s:ss) = do
500 case removeSpaces s of
502 l -> do quit <- runCommand l
503 if quit then return True else stringLoop ss
505 mkPrompt toplevs exports prompt
506 = showSDoc $ f prompt
508 f ('%':'s':xs) = perc_s <> f xs
509 f ('%':'%':xs) = char '%' <> f xs
510 f (x:xs) = char x <> f xs
513 perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
514 hsep (map (ppr . GHC.moduleName) exports)
518 readlineLoop :: GHCi ()
520 session <- getSession
521 (mod,imports) <- io (GHC.getContext session)
523 saveSession -- for use by completion
525 l <- io (readline (mkPrompt mod imports (prompt st))
526 `finally` setNonBlockingFD 0)
527 -- readline sometimes puts stdin into blocking mode,
528 -- so we need to put it back for the IO library
533 case removeSpaces l of
538 if quit then return () else readlineLoop
541 runCommand :: String -> GHCi Bool
542 runCommand c = ghciHandle handler (doCommand c)
544 doCommand (':' : command) = specialCommand command
546 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
549 -- This version is for the GHC command-line option -e. The only difference
550 -- from runCommand is that it catches the ExitException exception and
551 -- exits, rather than printing out the exception.
552 runCommandEval c = ghciHandle handleEval (doCommand c)
554 handleEval (ExitException code) = io (exitWith code)
555 handleEval e = do handler e
556 io (exitWith (ExitFailure 1))
558 doCommand (':' : command) = specialCommand command
560 = do nms <- runStmt stmt
562 Nothing -> io (exitWith (ExitFailure 1))
563 -- failure to run the command causes exit(1) for ghc -e.
564 _ -> finishEvalExpr nms
566 -- This is the exception handler for exceptions generated by the
567 -- user's code; it normally just prints out the exception. The
568 -- handler must be recursive, in case showing the exception causes
569 -- more exceptions to be raised.
571 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
572 -- raising another exception. We therefore don't put the recursive
573 -- handler arond the flushing operation, so if stderr is closed
574 -- GHCi will just die gracefully rather than going into an infinite loop.
575 handler :: Exception -> GHCi Bool
576 handler exception = do
578 io installSignalHandlers
579 ghciHandle handler (showException exception >> return False)
581 showException (DynException dyn) =
582 case fromDynamic dyn of
583 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
584 Just Interrupted -> io (putStrLn "Interrupted.")
585 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
586 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
587 Just other_ghc_ex -> io (print other_ghc_ex)
589 showException other_exception
590 = io (putStrLn ("*** Exception: " ++ show other_exception))
592 runStmt :: String -> GHCi (Maybe [Name])
594 | null (filter (not.isSpace) stmt) = return (Just [])
596 = do st <- getGHCiState
597 session <- getSession
598 result <- io $ withProgName (progname st) $ withArgs (args st) $
599 GHC.runStmt session stmt
601 GHC.RunFailed -> return Nothing
602 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
603 GHC.RunOk names -> return (Just names)
605 -- possibly print the type and revert CAFs after evaluating an expression
606 finishEvalExpr mb_names
607 = do b <- isOptionSet ShowType
608 session <- getSession
611 Just names -> when b (mapM_ (showTypeOfName session) names)
614 io installSignalHandlers
615 b <- isOptionSet RevertCAFs
616 io (when b revertCAFs)
619 showTypeOfName :: Session -> Name -> GHCi ()
620 showTypeOfName session n
621 = do maybe_tything <- io (GHC.lookupName session n)
622 case maybe_tything of
624 Just thing -> showTyThing thing
626 showForUser :: SDoc -> GHCi String
628 session <- getSession
629 unqual <- io (GHC.getPrintUnqual session)
630 return $! showSDocForUser unqual doc
632 specialCommand :: String -> GHCi Bool
633 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
634 specialCommand str = do
635 let (cmd,rest) = break isSpace str
636 maybe_cmd <- io (lookupCommand cmd)
638 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
639 ++ shortHelpText) >> return False)
640 Just (_,f,_,_) -> f (dropWhile isSpace rest)
642 lookupCommand :: String -> IO (Maybe Command)
643 lookupCommand str = do
644 cmds <- readIORef commands
645 -- look for exact match first, then the first prefix match
646 case [ c | c <- cmds, str == cmdName c ] of
647 c:_ -> return (Just c)
648 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
650 c:_ -> return (Just c)
652 -----------------------------------------------------------------------------
653 -- To flush buffers for the *interpreted* computation we need
654 -- to refer to *its* stdout/stderr handles
656 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
657 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
659 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
660 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
661 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
663 initInterpBuffering :: Session -> IO ()
664 initInterpBuffering session
665 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
668 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
669 other -> panic "interactiveUI:setBuffering"
671 maybe_hval <- GHC.compileExpr session flush_cmd
673 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
674 _ -> panic "interactiveUI:flush"
679 flushInterpBuffers :: GHCi ()
681 = io $ do Monad.join (readIORef flush_interp)
684 turnOffBuffering :: IO ()
686 = do Monad.join (readIORef turn_off_buffering)
689 -----------------------------------------------------------------------------
692 help :: String -> GHCi ()
693 help _ = io (putStr helpText)
695 info :: String -> GHCi ()
696 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
697 info s = do { let names = words s
698 ; session <- getSession
699 ; dflags <- getDynFlags
700 ; let exts = dopt Opt_GlasgowExts dflags
701 ; mapM_ (infoThing exts session) names }
703 infoThing exts session str = io $ do
704 names <- GHC.parseName session str
705 let filtered = filterOutChildren names
706 mb_stuffs <- mapM (GHC.getInfo session) filtered
707 unqual <- GHC.getPrintUnqual session
708 putStrLn (showSDocForUser unqual $
709 vcat (intersperse (text "") $
710 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
712 -- Filter out names whose parent is also there Good
713 -- example is '[]', which is both a type and data
714 -- constructor in the same type
715 filterOutChildren :: [Name] -> [Name]
716 filterOutChildren names = filter (not . parent_is_there) names
717 where parent_is_there n
718 | Just p <- GHC.nameParent_maybe n = p `elem` names
721 pprInfo exts (thing, fixity, insts)
722 = pprTyThingInContextLoc exts thing
723 $$ show_fixity fixity
724 $$ vcat (map GHC.pprInstance insts)
727 | fix == GHC.defaultFixity = empty
728 | otherwise = ppr fix <+> ppr (GHC.getName thing)
730 -----------------------------------------------------------------------------
733 runMain :: String -> GHCi ()
735 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
736 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
739 addModule :: [FilePath] -> GHCi ()
741 io (revertCAFs) -- always revert CAFs on load/add.
742 files <- mapM expandPath files
743 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
744 session <- getSession
745 io (mapM_ (GHC.addTarget session) targets)
746 ok <- io (GHC.load session LoadAllTargets)
749 changeDirectory :: String -> GHCi ()
750 changeDirectory dir = do
751 session <- getSession
752 graph <- io (GHC.getModuleGraph session)
753 when (not (null graph)) $
754 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
755 io (GHC.setTargets session [])
756 io (GHC.load session LoadAllTargets)
757 setContextAfterLoad session []
758 io (GHC.workingDirectoryChanged session)
759 dir <- expandPath dir
760 io (setCurrentDirectory dir)
762 editFile :: String -> GHCi ()
765 -- find the name of the "topmost" file loaded
766 session <- getSession
767 graph0 <- io (GHC.getModuleGraph session)
768 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
769 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
770 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
771 Just file -> do_edit file
772 Nothing -> throwDyn (CmdLineError "unknown file name")
773 | otherwise = do_edit str
779 throwDyn (CmdLineError "editor not set, use :set editor")
780 io $ system (cmd ++ ' ':file)
783 defineMacro :: String -> GHCi ()
785 let (macro_name, definition) = break isSpace s
786 cmds <- io (readIORef commands)
788 then throwDyn (CmdLineError "invalid macro name")
790 if (macro_name `elem` map cmdName cmds)
791 then throwDyn (CmdLineError
792 ("command '" ++ macro_name ++ "' is already defined"))
795 -- give the expression a type signature, so we can be sure we're getting
796 -- something of the right type.
797 let new_expr = '(' : definition ++ ") :: String -> IO String"
799 -- compile the expression
801 maybe_hv <- io (GHC.compileExpr cms new_expr)
804 Just hv -> io (writeIORef commands --
805 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
807 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
809 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
810 stringLoop (lines str)
812 undefineMacro :: String -> GHCi ()
813 undefineMacro macro_name = do
814 cmds <- io (readIORef commands)
815 if (macro_name `elem` map cmdName builtin_commands)
816 then throwDyn (CmdLineError
817 ("command '" ++ macro_name ++ "' cannot be undefined"))
819 if (macro_name `notElem` map cmdName cmds)
820 then throwDyn (CmdLineError
821 ("command '" ++ macro_name ++ "' not defined"))
823 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
826 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
827 loadModule fs = timeIt (loadModule' fs)
829 loadModule_ :: [FilePath] -> GHCi ()
830 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
832 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
833 loadModule' files = do
834 session <- getSession
837 io (GHC.setTargets session [])
838 io (GHC.load session LoadAllTargets)
841 let (filenames, phases) = unzip files
842 exp_filenames <- mapM expandPath filenames
843 let files' = zip exp_filenames phases
844 targets <- io (mapM (uncurry GHC.guessTarget) files')
846 -- NOTE: we used to do the dependency anal first, so that if it
847 -- fails we didn't throw away the current set of modules. This would
848 -- require some re-working of the GHC interface, so we'll leave it
849 -- as a ToDo for now.
851 io (GHC.setTargets session targets)
852 ok <- io (GHC.load session LoadAllTargets)
856 checkModule :: String -> GHCi ()
858 let modl = GHC.mkModuleName m
859 session <- getSession
860 result <- io (GHC.checkModule session modl)
862 Nothing -> io $ putStrLn "Nothing"
863 Just r -> io $ putStrLn (showSDoc (
864 case checkedModuleInfo r of
865 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
867 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
869 (text "global names: " <+> ppr global) $$
870 (text "local names: " <+> ppr local)
872 afterLoad (successIf (isJust result)) session
874 reloadModule :: String -> GHCi ()
876 io (revertCAFs) -- always revert CAFs on reload.
877 session <- getSession
878 ok <- io (GHC.load session LoadAllTargets)
881 io (revertCAFs) -- always revert CAFs on reload.
882 session <- getSession
883 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
886 afterLoad ok session = do
887 io (revertCAFs) -- always revert CAFs on load.
888 graph <- io (GHC.getModuleGraph session)
889 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
890 setContextAfterLoad session graph'
891 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
892 #if defined(GHCI) && defined(BREAKPOINT)
893 io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
894 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
897 setContextAfterLoad session [] = do
898 prel_mod <- getPrelude
899 io (GHC.setContext session [] [prel_mod])
900 setContextAfterLoad session ms = do
901 -- load a target if one is available, otherwise load the topmost module.
902 targets <- io (GHC.getTargets session)
903 case [ m | Just m <- map (findTarget ms) targets ] of
905 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
906 load_this (last graph')
911 = case filter (`matches` t) ms of
915 summary `matches` Target (TargetModule m) _
916 = GHC.ms_mod_name summary == m
917 summary `matches` Target (TargetFile f _) _
918 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
919 summary `matches` target
922 load_this summary | m <- GHC.ms_mod summary = do
923 b <- io (GHC.moduleIsInterpreted session m)
924 if b then io (GHC.setContext session [m] [])
926 prel_mod <- getPrelude
927 io (GHC.setContext session [] [prel_mod,m])
930 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
931 modulesLoadedMsg ok mods = do
932 dflags <- getDynFlags
933 when (verbosity dflags > 0) $ do
935 | null mods = text "none."
937 punctuate comma (map ppr mods)) <> text "."
940 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
942 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
945 typeOfExpr :: String -> GHCi ()
947 = do cms <- getSession
948 maybe_ty <- io (GHC.exprType cms str)
951 Just ty -> do ty' <- cleanType ty
952 tystr <- showForUser (ppr ty')
953 io (putStrLn (str ++ " :: " ++ tystr))
955 kindOfType :: String -> GHCi ()
957 = do cms <- getSession
958 maybe_ty <- io (GHC.typeKind cms str)
961 Just ty -> do tystr <- showForUser (ppr ty)
962 io (putStrLn (str ++ " :: " ++ tystr))
964 quit :: String -> GHCi Bool
967 shellEscape :: String -> GHCi Bool
968 shellEscape str = io (system str >> return False)
970 -----------------------------------------------------------------------------
971 -- create tags file for currently loaded modules.
973 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
975 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
976 createCTagsFileCmd file = ghciCreateTagsFile CTags file
978 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
979 createETagsFileCmd file = ghciCreateTagsFile ETags file
981 data TagsKind = ETags | CTags
983 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
984 ghciCreateTagsFile kind file = do
985 session <- getSession
986 io $ createTagsFile session kind file
989 -- - remove restriction that all modules must be interpreted
990 -- (problem: we don't know source locations for entities unless
991 -- we compiled the module.
993 -- - extract createTagsFile so it can be used from the command-line
994 -- (probably need to fix first problem before this is useful).
996 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
997 createTagsFile session tagskind tagFile = do
998 graph <- GHC.getModuleGraph session
999 let ms = map GHC.ms_mod graph
1001 is_interpreted <- GHC.moduleIsInterpreted session m
1002 -- should we just skip these?
1003 when (not is_interpreted) $
1004 throwDyn (CmdLineError ("module '"
1005 ++ GHC.moduleNameString (GHC.moduleName m)
1006 ++ "' is not interpreted"))
1007 mbModInfo <- GHC.getModuleInfo session m
1009 | Just modinfo <- mbModInfo,
1010 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
1011 | otherwise = GHC.alwaysQualify
1014 Just modInfo -> return $! listTags unqual modInfo
1017 mtags <- mapM tagModule ms
1018 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
1020 Left e -> hPutStrLn stderr $ ioeGetErrorString e
1021 Right _ -> return ()
1023 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
1024 listTags unqual modInfo =
1025 [ tagInfo unqual name loc
1026 | name <- GHC.modInfoExports modInfo
1027 , let loc = nameSrcLoc name
1031 type TagInfo = (String -- tag name
1032 ,String -- file name
1034 ,Int -- column number
1037 -- get tag info, for later translation into Vim or Emacs style
1038 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
1039 tagInfo unqual name loc
1040 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
1041 , showSDocForUser unqual $ ftext (srcLocFile loc)
1046 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
1047 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
1048 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
1049 IO.try (writeFile file tags)
1050 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
1051 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
1052 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
1053 tagGroups <- mapM tagFileGroup groups
1054 IO.try (writeFile file $ concat tagGroups)
1056 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
1057 tagFileGroup group@((_,fileName,_,_):_) = do
1058 file <- readFile fileName -- need to get additional info from sources..
1059 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
1060 sortedGroup = sortLe byLine group
1061 tags = unlines $ perFile sortedGroup 1 0 $ lines file
1062 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
1063 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
1064 perFile (tagInfo:tags) (count+1) (pos+length line) lines
1065 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
1066 showETag tagInfo line pos : perFile tags count pos lines
1067 perFile tags count pos lines = []
1069 -- simple ctags format, for Vim et al
1070 showTag :: TagInfo -> String
1071 showTag (tag,file,lineNo,colNo)
1072 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
1074 -- etags format, for Emacs/XEmacs
1075 showETag :: TagInfo -> String -> Int -> String
1076 showETag (tag,file,lineNo,colNo) line charPos
1077 = take colNo line ++ tag
1079 ++ "\x01" ++ show lineNo
1080 ++ "," ++ show charPos
1082 -----------------------------------------------------------------------------
1083 -- Browsing a module's contents
1085 browseCmd :: String -> GHCi ()
1088 ['*':m] | looksLikeModuleName m -> browseModule m False
1089 [m] | looksLikeModuleName m -> browseModule m True
1090 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1092 browseModule m exports_only = do
1094 modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
1095 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1096 when (not is_interpreted && not exports_only) $
1097 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1099 -- Temporarily set the context to the module we're interested in,
1100 -- just so we can get an appropriate PrintUnqualified
1101 (as,bs) <- io (GHC.getContext s)
1102 prel_mod <- getPrelude
1103 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1104 else GHC.setContext s [modl] [])
1105 unqual <- io (GHC.getPrintUnqual s)
1106 io (GHC.setContext s as bs)
1108 mb_mod_info <- io $ GHC.getModuleInfo s modl
1110 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1113 | exports_only = GHC.modInfoExports mod_info
1114 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1116 filtered = filterOutChildren names
1118 things <- io $ mapM (GHC.lookupName s) filtered
1120 dflags <- getDynFlags
1121 let exts = dopt Opt_GlasgowExts dflags
1122 io (putStrLn (showSDocForUser unqual (
1123 vcat (map (pprTyThingInContext exts) (catMaybes things))
1125 -- ToDo: modInfoInstances currently throws an exception for
1126 -- package modules. When it works, we can do this:
1127 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1129 -----------------------------------------------------------------------------
1130 -- Setting the module context
1133 | all sensible mods = fn mods
1134 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1136 (fn, mods) = case str of
1137 '+':stuff -> (addToContext, words stuff)
1138 '-':stuff -> (removeFromContext, words stuff)
1139 stuff -> (newContext, words stuff)
1141 sensible ('*':m) = looksLikeModuleName m
1142 sensible m = looksLikeModuleName m
1144 separate :: Session -> [String] -> [Module] -> [Module]
1145 -> GHCi ([Module],[Module])
1146 separate session [] as bs = return (as,bs)
1147 separate session (('*':str):ms) as bs = do
1148 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1149 b <- io $ GHC.moduleIsInterpreted session m
1150 if b then separate session ms (m:as) bs
1151 else throwDyn (CmdLineError ("module '"
1152 ++ GHC.moduleNameString (GHC.moduleName m)
1153 ++ "' is not interpreted"))
1154 separate session (str:ms) as bs = do
1155 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1156 separate session ms as (m:bs)
1158 newContext :: [String] -> GHCi ()
1159 newContext strs = do
1161 (as,bs) <- separate s strs [] []
1162 prel_mod <- getPrelude
1163 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1164 io $ GHC.setContext s as bs'
1167 addToContext :: [String] -> GHCi ()
1168 addToContext strs = do
1170 (as,bs) <- io $ GHC.getContext s
1172 (new_as,new_bs) <- separate s strs [] []
1174 let as_to_add = new_as \\ (as ++ bs)
1175 bs_to_add = new_bs \\ (as ++ bs)
1177 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1180 removeFromContext :: [String] -> GHCi ()
1181 removeFromContext strs = do
1183 (as,bs) <- io $ GHC.getContext s
1185 (as_to_remove,bs_to_remove) <- separate s strs [] []
1187 let as' = as \\ (as_to_remove ++ bs_to_remove)
1188 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1190 io $ GHC.setContext s as' bs'
1192 ----------------------------------------------------------------------------
1195 -- set options in the interpreter. Syntax is exactly the same as the
1196 -- ghc command line, except that certain options aren't available (-C,
1199 -- This is pretty fragile: most options won't work as expected. ToDo:
1200 -- figure out which ones & disallow them.
1202 setCmd :: String -> GHCi ()
1204 = do st <- getGHCiState
1205 let opts = options st
1206 io $ putStrLn (showSDoc (
1207 text "options currently set: " <>
1210 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1213 = case toArgs str of
1214 ("args":args) -> setArgs args
1215 ("prog":prog) -> setProg prog
1216 ("prompt":prompt) -> setPrompt (after 6)
1217 ("editor":cmd) -> setEditor (after 6)
1218 wds -> setOptions wds
1219 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1223 setGHCiState st{ args = args }
1227 setGHCiState st{ progname = prog }
1229 io (hPutStrLn stderr "syntax: :set prog <progname>")
1233 setGHCiState st{ editor = cmd }
1235 setPrompt value = do
1238 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1239 else setGHCiState st{ prompt = remQuotes value }
1241 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1245 do -- first, deal with the GHCi opts (+s, +t, etc.)
1246 let (plus_opts, minus_opts) = partition isPlus wds
1247 mapM_ setOpt plus_opts
1249 -- then, dynamic flags
1250 dflags <- getDynFlags
1251 let pkg_flags = packageFlags dflags
1252 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1254 if (not (null leftovers))
1255 then throwDyn (CmdLineError ("unrecognised flags: " ++
1259 new_pkgs <- setDynFlags dflags'
1261 -- if the package flags changed, we should reset the context
1262 -- and link the new packages.
1263 dflags <- getDynFlags
1264 when (packageFlags dflags /= pkg_flags) $ do
1265 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1266 session <- getSession
1267 io (GHC.setTargets session [])
1268 io (GHC.load session LoadAllTargets)
1269 io (linkPackages dflags new_pkgs)
1270 setContextAfterLoad session []
1274 unsetOptions :: String -> GHCi ()
1276 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1277 let opts = words str
1278 (minus_opts, rest1) = partition isMinus opts
1279 (plus_opts, rest2) = partition isPlus rest1
1281 if (not (null rest2))
1282 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1285 mapM_ unsetOpt plus_opts
1287 -- can't do GHC flags for now
1288 if (not (null minus_opts))
1289 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1292 isMinus ('-':s) = True
1295 isPlus ('+':s) = True
1299 = case strToGHCiOpt str of
1300 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1301 Just o -> setOption o
1304 = case strToGHCiOpt str of
1305 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1306 Just o -> unsetOption o
1308 strToGHCiOpt :: String -> (Maybe GHCiOption)
1309 strToGHCiOpt "s" = Just ShowTiming
1310 strToGHCiOpt "t" = Just ShowType
1311 strToGHCiOpt "r" = Just RevertCAFs
1312 strToGHCiOpt _ = Nothing
1314 optToStr :: GHCiOption -> String
1315 optToStr ShowTiming = "s"
1316 optToStr ShowType = "t"
1317 optToStr RevertCAFs = "r"
1319 -- ---------------------------------------------------------------------------
1324 ["modules" ] -> showModules
1325 ["bindings"] -> showBindings
1326 ["linker"] -> io showLinkerState
1327 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1330 session <- getSession
1331 let show_one ms = do m <- io (GHC.showModule session ms)
1333 graph <- io (GHC.getModuleGraph session)
1334 mapM_ show_one graph
1338 unqual <- io (GHC.getPrintUnqual s)
1339 bindings <- io (GHC.getBindings s)
1340 mapM_ showTyThing bindings
1343 showTyThing (AnId id) = do
1344 ty' <- cleanType (GHC.idType id)
1345 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1347 showTyThing _ = return ()
1349 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1350 cleanType :: Type -> GHCi Type
1352 dflags <- getDynFlags
1353 if dopt Opt_GlasgowExts dflags
1355 else return $! GHC.dropForAlls ty
1357 -- -----------------------------------------------------------------------------
1360 completeNone :: String -> IO [String]
1361 completeNone w = return []
1364 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1365 completeWord w start end = do
1366 line <- Readline.getLineBuffer
1368 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1370 | Just c <- is_cmd line -> do
1371 maybe_cmd <- lookupCommand c
1372 let (n,w') = selectWord (words' 0 line)
1374 Nothing -> return Nothing
1375 Just (_,_,False,complete) -> wrapCompleter complete w
1376 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1377 return (map (drop n) rets)
1378 in wrapCompleter complete' w'
1380 --printf "complete %s, start = %d, end = %d\n" w start end
1381 wrapCompleter completeIdentifier w
1382 where words' _ [] = []
1383 words' n str = let (w,r) = break isSpace str
1384 (s,r') = span isSpace r
1385 in (n,w):words' (n+length w+length s) r'
1386 -- In a Haskell expression we want to parse 'a-b' as three words
1387 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1388 -- only be a single word.
1389 selectWord [] = (0,w)
1390 selectWord ((offset,x):xs)
1391 | offset+length x >= start = (start-offset,take (end-offset) x)
1392 | otherwise = selectWord xs
1395 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1396 | otherwise = Nothing
1399 cmds <- readIORef commands
1400 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1402 completeMacro w = do
1403 cmds <- readIORef commands
1404 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1405 return (filter (w `isPrefixOf`) cmds')
1407 completeIdentifier w = do
1409 rdrs <- GHC.getRdrNamesInScope s
1410 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1412 completeModule w = do
1414 dflags <- GHC.getSessionDynFlags s
1415 let pkg_mods = allExposedModules dflags
1416 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1418 completeHomeModule w = do
1420 g <- GHC.getModuleGraph s
1421 let home_mods = map GHC.ms_mod_name g
1422 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1424 completeSetOptions w = do
1425 return (filter (w `isPrefixOf`) options)
1426 where options = "args":"prog":allFlags
1428 completeFilename = Readline.filenameCompletionFunction
1430 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1432 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1433 unionComplete f1 f2 w = do
1438 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1439 wrapCompleter fun w = do
1442 [] -> return Nothing
1443 [x] -> return (Just (x,[]))
1444 xs -> case getCommonPrefix xs of
1445 "" -> return (Just ("",xs))
1446 pref -> return (Just (pref,xs))
1448 getCommonPrefix :: [String] -> String
1449 getCommonPrefix [] = ""
1450 getCommonPrefix (s:ss) = foldl common s ss
1451 where common s "" = s
1453 common (c:cs) (d:ds)
1454 | c == d = c : common cs ds
1457 allExposedModules :: DynFlags -> [ModuleName]
1458 allExposedModules dflags
1459 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1461 pkg_db = pkgIdMap (pkgState dflags)
1463 completeCmd = completeNone
1464 completeMacro = completeNone
1465 completeIdentifier = completeNone
1466 completeModule = completeNone
1467 completeHomeModule = completeNone
1468 completeSetOptions = completeNone
1469 completeFilename = completeNone
1470 completeHomeModuleOrFile=completeNone
1473 -----------------------------------------------------------------------------
1476 data GHCiState = GHCiState
1482 session :: GHC.Session,
1483 options :: [GHCiOption],
1488 = ShowTiming -- show time/allocs after evaluation
1489 | ShowType -- show the type of expressions
1490 | RevertCAFs -- revert CAFs after every evaluation
1493 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1495 startGHCi :: GHCi a -> GHCiState -> IO a
1496 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1498 instance Monad GHCi where
1499 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1500 return a = GHCi $ \s -> return a
1502 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1503 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1504 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1506 getGHCiState = GHCi $ \r -> readIORef r
1507 setGHCiState s = GHCi $ \r -> writeIORef r s
1509 -- for convenience...
1510 getSession = getGHCiState >>= return . session
1511 getPrelude = getGHCiState >>= return . prelude
1513 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
1514 no_saved_sess = error "no saved_ses"
1515 saveSession = getSession >>= io . writeIORef saved_sess
1516 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
1517 restoreSession = readIORef saved_sess
1521 io (GHC.getSessionDynFlags s)
1522 setDynFlags dflags = do
1524 io (GHC.setSessionDynFlags s dflags)
1526 isOptionSet :: GHCiOption -> GHCi Bool
1528 = do st <- getGHCiState
1529 return (opt `elem` options st)
1531 setOption :: GHCiOption -> GHCi ()
1533 = do st <- getGHCiState
1534 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1536 unsetOption :: GHCiOption -> GHCi ()
1538 = do st <- getGHCiState
1539 setGHCiState (st{ options = filter (/= opt) (options st) })
1541 io :: IO a -> GHCi a
1542 io m = GHCi { unGHCi = \s -> m >>= return }
1544 -----------------------------------------------------------------------------
1545 -- recursive exception handlers
1547 -- Don't forget to unblock async exceptions in the handler, or if we're
1548 -- in an exception loop (eg. let a = error a in a) the ^C exception
1549 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1551 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1552 ghciHandle h (GHCi m) = GHCi $ \s ->
1553 Exception.catch (m s)
1554 (\e -> unGHCi (ghciUnblock (h e)) s)
1556 ghciUnblock :: GHCi a -> GHCi a
1557 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1559 -----------------------------------------------------------------------------
1560 -- timing & statistics
1562 timeIt :: GHCi a -> GHCi a
1564 = do b <- isOptionSet ShowTiming
1567 else do allocs1 <- io $ getAllocations
1568 time1 <- io $ getCPUTime
1570 allocs2 <- io $ getAllocations
1571 time2 <- io $ getCPUTime
1572 io $ printTimes (fromIntegral (allocs2 - allocs1))
1576 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1577 -- defined in ghc/rts/Stats.c
1579 printTimes :: Integer -> Integer -> IO ()
1580 printTimes allocs psecs
1581 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1582 secs_str = showFFloat (Just 2) secs
1583 putStrLn (showSDoc (
1584 parens (text (secs_str "") <+> text "secs" <> comma <+>
1585 text (show allocs) <+> text "bytes")))
1587 -----------------------------------------------------------------------------
1594 -- Have to turn off buffering again, because we just
1595 -- reverted stdout, stderr & stdin to their defaults.
1597 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1598 -- Make it "safe", just in case
1600 -- ----------------------------------------------------------------------------
1603 expandPath :: String -> GHCi String
1605 case dropWhile isSpace path of
1607 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1608 return (tilde ++ '/':d)
1612 -- ----------------------------------------------------------------------------
1613 -- Windows console setup
1615 setUpConsole :: IO ()
1617 #ifdef mingw32_HOST_OS
1618 -- On Windows we need to set a known code page, otherwise the characters
1619 -- we read from the console will be be in some strange encoding, and
1620 -- similarly for characters we write to the console.
1622 -- At the moment, GHCi pretends all input is Latin-1. In the
1623 -- future we should support UTF-8, but for now we set the code pages
1626 -- It seems you have to set the font in the console window to
1627 -- a Unicode font in order for output to work properly,
1628 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1629 -- (see MSDN for SetConsoleOutputCP()).
1631 setConsoleCP 28591 -- ISO Latin-1
1632 setConsoleOutputCP 28591 -- ISO Latin-1