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,
64 #ifndef mingw32_HOST_OS
66 #if __GLASGOW_HASKELL__ > 504
70 import GHC.ConsoleHandler ( flushConsole )
71 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
72 import qualified System.Win32
76 import Control.Concurrent ( yield ) -- Used in readline loop
77 import System.Console.Readline as Readline
82 import Control.Exception as Exception
84 -- import Control.Concurrent
88 import Data.Int ( Int64 )
89 import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
92 import System.Environment
93 import System.Exit ( exitWith, ExitCode(..) )
94 import System.Directory
96 import System.IO.Error as IO
98 import Control.Monad as Monad
99 import Foreign.StablePtr ( newStablePtr )
101 import GHC.Exts ( unsafeCoerce# )
102 import GHC.IOBase ( IOErrorType(InvalidArgument) )
104 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
106 import System.Posix.Internals ( setNonBlockingFD )
108 -----------------------------------------------------------------------------
112 " / _ \\ /\\ /\\/ __(_)\n"++
113 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
114 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
115 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
117 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
118 cmdName (n,_,_,_) = n
120 GLOBAL_VAR(commands, builtin_commands, [Command])
122 builtin_commands :: [Command]
124 ("add", keepGoingPaths addModule, False, completeFilename),
125 ("browse", keepGoing browseCmd, False, completeModule),
126 ("cd", keepGoing changeDirectory, False, completeFilename),
127 ("def", keepGoing defineMacro, False, completeIdentifier),
128 ("e", keepGoing editFile, False, completeFilename),
129 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
130 ("edit", keepGoing editFile, False, completeFilename),
131 ("help", keepGoing help, False, completeNone),
132 ("?", keepGoing help, False, completeNone),
133 ("info", keepGoing info, False, completeIdentifier),
134 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
135 ("module", keepGoing setContext, False, completeModule),
136 ("main", keepGoing runMain, False, completeIdentifier),
137 ("reload", keepGoing reloadModule, False, completeNone),
138 ("check", keepGoing checkModule, False, completeHomeModule),
139 ("set", keepGoing setCmd, True, completeSetOptions),
140 ("show", keepGoing showCmd, False, completeNone),
141 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
142 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
143 ("type", keepGoing typeOfExpr, False, completeIdentifier),
144 ("kind", keepGoing kindOfType, False, completeIdentifier),
145 ("unset", keepGoing unsetOptions, True, completeSetOptions),
146 ("undef", keepGoing undefineMacro, False, completeMacro),
147 ("quit", quit, False, completeNone)
150 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
151 keepGoing a str = a str >> return False
153 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
154 keepGoingPaths a str = a (toArgs str) >> return False
156 shortHelpText = "use :? for help.\n"
158 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
160 " Commands available from the prompt:\n" ++
162 " <stmt> evaluate/run <stmt>\n" ++
163 " :add <filename> ... add module(s) to the current target set\n" ++
164 " :browse [*]<module> display the names defined by <module>\n" ++
165 " :cd <dir> change directory to <dir>\n" ++
166 " :def <cmd> <expr> define a command :<cmd>\n" ++
167 " :edit <file> edit file\n" ++
168 " :edit edit last module\n" ++
169 " :help, :? display this list of commands\n" ++
170 " :info [<name> ...] display information about the given names\n" ++
171 " :load <filename> ... load module(s) and their dependents\n" ++
172 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
173 " :main [<arguments> ...] run the main function with the given arguments\n" ++
174 " :reload reload the current module set\n" ++
176 " :set <option> ... set options\n" ++
177 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
178 " :set prog <progname> set the value returned by System.getProgName\n" ++
179 " :set prompt <prompt> set the prompt used in GHCi\n" ++
180 " :set editor <cmd> set the comand used for :edit\n" ++
182 " :show modules show the currently loaded modules\n" ++
183 " :show bindings show the current bindings made at the prompt\n" ++
185 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
186 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
187 " :type <expr> show the type of <expr>\n" ++
188 " :kind <type> show the kind of <type>\n" ++
189 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
190 " :unset <option> ... unset options\n" ++
191 " :quit exit GHCi\n" ++
192 " :!<command> run the shell command <command>\n" ++
194 " Options for ':set' and ':unset':\n" ++
196 " +r revert top-level expressions after each evaluation\n" ++
197 " +s print timing/memory stats after each evaluation\n" ++
198 " +t print type after evaluation\n" ++
199 " -<flags> most GHC command line flags can also be set here\n" ++
200 " (eg. -v2, -fglasgow-exts, etc.)\n"
203 #if defined(GHCI) && defined(BREAKPOINT)
204 globaliseAndTidy :: Id -> Id
206 -- Give the Id a Global Name, and tidy its type
207 = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
209 tidy_type = tidyTopType (idType id)
212 printScopeMsg :: Session -> String -> [Id] -> IO ()
213 printScopeMsg session location ids
214 = GHC.getPrintUnqual session >>= \unqual ->
215 printForUser stdout unqual $
216 text "Local bindings in scope:" $$
217 nest 2 (pprWithCommas showId ids)
218 where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
220 jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
221 jumpCondFunction session ptr hValues location True b = b
222 jumpCondFunction session ptr hValues location False b
223 = jumpFunction session ptr hValues location b
225 jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
226 jumpFunction session@(Session ref) (I# idsPtr) hValues location b
228 do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
229 let names = map idName ids
230 ASSERT (length names == length hValues) return ()
231 printScopeMsg session location ids
232 hsc_env <- readIORef ref
234 let ictxt = hsc_IC hsc_env
235 global_ids = map globaliseAndTidy ids
236 rn_env = ic_rn_local_env ictxt
237 type_env = ic_type_env ictxt
238 bound_names = map idName global_ids
239 new_rn_env = extendLocalRdrEnv rn_env bound_names
240 -- Remove any shadowed bindings from the type_env;
241 -- they are inaccessible but might, I suppose, cause
242 -- a space leak if we leave them there
243 shadowed = [ n | name <- bound_names,
244 let rdr_name = mkRdrUnqual (nameOccName name),
245 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
246 filtered_type_env = delListFromNameEnv type_env shadowed
247 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
248 new_ic = ictxt { ic_rn_local_env = new_rn_env,
249 ic_type_env = new_type_env }
250 writeIORef ref (hsc_env { hsc_IC = new_ic })
251 is_tty <- hIsTerminalDevice stdin
252 prel_mod <- GHC.findModule session prel_name Nothing
253 default_editor <- findEditor
254 withExtendedLinkEnv (zip names hValues) $
255 startGHCi (interactiveLoop is_tty True)
256 GHCiState{ progname = "<interactive>",
258 prompt = location++"> ",
259 editor = default_editor,
263 writeIORef ref hsc_env
264 putStrLn $ "Returning to normal execution..."
272 win <- System.Win32.getWindowsDirectory
273 return (win `joinFileName` "notepad.exe")
278 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
279 interactiveUI session srcs maybe_expr = do
280 #if defined(GHCI) && defined(BREAKPOINT)
281 initDynLinker =<< GHC.getSessionDynFlags session
282 extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
283 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
285 -- HACK! If we happen to get into an infinite loop (eg the user
286 -- types 'let x=x in x' at the prompt), then the thread will block
287 -- on a blackhole, and become unreachable during GC. The GC will
288 -- detect that it is unreachable and send it the NonTermination
289 -- exception. However, since the thread is unreachable, everything
290 -- it refers to might be finalized, including the standard Handles.
291 -- This sounds like a bug, but we don't have a good solution right
297 -- Initialise buffering for the *interpreted* I/O system
298 initInterpBuffering session
300 when (isNothing maybe_expr) $ do
301 -- Only for GHCi (not runghc and ghc -e):
302 -- Turn buffering off for the compiled program's stdout/stderr
304 -- Turn buffering off for GHCi's stdout
306 hSetBuffering stdout NoBuffering
307 -- We don't want the cmd line to buffer any input that might be
308 -- intended for the program, so unbuffer stdin.
309 hSetBuffering stdin NoBuffering
311 -- initial context is just the Prelude
312 prel_mod <- GHC.findModule session prel_name Nothing
313 GHC.setContext session [] [prel_mod]
317 Readline.setAttemptedCompletionFunction (Just completeWord)
318 --Readline.parseAndBind "set show-all-if-ambiguous 1"
320 let symbols = "!#$%&*+/<=>?@\\^|-~"
321 specials = "(),;[]`{}"
323 word_break_chars = spaces ++ specials ++ symbols
325 Readline.setBasicWordBreakCharacters word_break_chars
326 Readline.setCompleterWordBreakCharacters word_break_chars
329 default_editor <- findEditor
331 startGHCi (runGHCi srcs maybe_expr)
332 GHCiState{ progname = "<interactive>",
335 editor = default_editor,
341 Readline.resetTerminal Nothing
346 prel_name = GHC.mkModuleName "Prelude"
348 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
349 runGHCi paths maybe_expr = do
350 let read_dot_files = not opt_IgnoreDotGhci
352 when (read_dot_files) $ do
355 exists <- io (doesFileExist file)
357 dir_ok <- io (checkPerms ".")
358 file_ok <- io (checkPerms file)
359 when (dir_ok && file_ok) $ do
360 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
363 Right hdl -> fileLoop hdl False
365 when (read_dot_files) $ do
366 -- Read in $HOME/.ghci
367 either_dir <- io (IO.try (getEnv "HOME"))
371 cwd <- io (getCurrentDirectory)
372 when (dir /= cwd) $ do
373 let file = dir ++ "/.ghci"
374 ok <- io (checkPerms file)
376 either_hdl <- io (IO.try (openFile file ReadMode))
379 Right hdl -> fileLoop hdl False
381 -- Perform a :load for files given on the GHCi command line
382 -- When in -e mode, if the load fails then we want to stop
383 -- immediately rather than going on to evaluate the expression.
384 when (not (null paths)) $ do
385 ok <- ghciHandle (\e -> do showException e; return Failed) $
387 when (isJust maybe_expr && failed ok) $
388 io (exitWith (ExitFailure 1))
390 -- if verbosity is greater than 0, or we are connected to a
391 -- terminal, display the prompt in the interactive loop.
392 is_tty <- io (hIsTerminalDevice stdin)
393 dflags <- getDynFlags
394 let show_prompt = verbosity dflags > 0 || is_tty
399 #if defined(mingw32_HOST_OS)
400 -- The win32 Console API mutates the first character of
401 -- type-ahead when reading from it in a non-buffered manner. Work
402 -- around this by flushing the input buffer of type-ahead characters,
403 -- but only if stdin is available.
404 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
406 Left err | isDoesNotExistError err -> return ()
407 | otherwise -> io (ioError err)
408 Right () -> return ()
410 -- initialise the console if necessary
413 -- enter the interactive loop
414 interactiveLoop is_tty show_prompt
416 -- just evaluate the expression we were given
421 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
424 interactiveLoop is_tty show_prompt =
425 -- Ignore ^C exceptions caught here
426 ghciHandleDyn (\e -> case e of
428 #if defined(mingw32_HOST_OS)
431 interactiveLoop is_tty show_prompt
432 _other -> return ()) $
434 ghciUnblock $ do -- unblock necessary if we recursed from the
435 -- exception handler above.
437 -- read commands from stdin
441 else fileLoop stdin show_prompt
443 fileLoop stdin show_prompt
447 -- NOTE: We only read .ghci files if they are owned by the current user,
448 -- and aren't world writable. Otherwise, we could be accidentally
449 -- running code planted by a malicious third party.
451 -- Furthermore, We only read ./.ghci if . is owned by the current user
452 -- and isn't writable by anyone else. I think this is sufficient: we
453 -- don't need to check .. and ../.. etc. because "." always refers to
454 -- the same directory while a process is running.
456 checkPerms :: String -> IO Bool
458 #ifdef mingw32_HOST_OS
461 Util.handle (\_ -> return False) $ do
462 st <- getFileStatus name
464 if fileOwner st /= me then do
465 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
468 let mode = fileMode st
469 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
470 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
472 putStrLn $ "*** WARNING: " ++ name ++
473 " is writable by someone else, IGNORING!"
478 fileLoop :: Handle -> Bool -> GHCi ()
479 fileLoop hdl show_prompt = do
480 session <- getSession
481 (mod,imports) <- io (GHC.getContext session)
483 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
484 l <- io (IO.try (hGetLine hdl))
486 Left e | isEOFError e -> return ()
487 | InvalidArgument <- etype -> return ()
488 | otherwise -> io (ioError e)
489 where etype = ioeGetErrorType e
490 -- treat InvalidArgument in the same way as EOF:
491 -- this can happen if the user closed stdin, or
492 -- perhaps did getContents which closes stdin at
495 case removeSpaces l of
496 "" -> fileLoop hdl show_prompt
497 l -> do quit <- runCommand l
498 if quit then return () else fileLoop hdl show_prompt
500 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
501 stringLoop [] = return False
502 stringLoop (s:ss) = do
503 case removeSpaces s of
505 l -> do quit <- runCommand l
506 if quit then return True else stringLoop ss
508 mkPrompt toplevs exports prompt
509 = showSDoc $ f prompt
511 f ('%':'s':xs) = perc_s <> f xs
512 f ('%':'%':xs) = char '%' <> f xs
513 f (x:xs) = char x <> f xs
516 perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
517 hsep (map (ppr . GHC.moduleName) exports)
521 readlineLoop :: GHCi ()
523 session <- getSession
524 (mod,imports) <- io (GHC.getContext session)
526 saveSession -- for use by completion
528 l <- io (readline (mkPrompt mod imports (prompt st))
529 `finally` setNonBlockingFD 0)
530 -- readline sometimes puts stdin into blocking mode,
531 -- so we need to put it back for the IO library
536 case removeSpaces l of
541 if quit then return () else readlineLoop
544 runCommand :: String -> GHCi Bool
545 runCommand c = ghciHandle handler (doCommand c)
547 doCommand (':' : command) = specialCommand command
549 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
552 -- This version is for the GHC command-line option -e. The only difference
553 -- from runCommand is that it catches the ExitException exception and
554 -- exits, rather than printing out the exception.
555 runCommandEval c = ghciHandle handleEval (doCommand c)
557 handleEval (ExitException code) = io (exitWith code)
558 handleEval e = do handler e
559 io (exitWith (ExitFailure 1))
561 doCommand (':' : command) = specialCommand command
563 = do nms <- runStmt stmt
565 Nothing -> io (exitWith (ExitFailure 1))
566 -- failure to run the command causes exit(1) for ghc -e.
567 _ -> finishEvalExpr nms
569 -- This is the exception handler for exceptions generated by the
570 -- user's code; it normally just prints out the exception. The
571 -- handler must be recursive, in case showing the exception causes
572 -- more exceptions to be raised.
574 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
575 -- raising another exception. We therefore don't put the recursive
576 -- handler arond the flushing operation, so if stderr is closed
577 -- GHCi will just die gracefully rather than going into an infinite loop.
578 handler :: Exception -> GHCi Bool
579 handler exception = do
581 io installSignalHandlers
582 ghciHandle handler (showException exception >> return False)
584 showException (DynException dyn) =
585 case fromDynamic dyn of
586 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
587 Just Interrupted -> io (putStrLn "Interrupted.")
588 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
589 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
590 Just other_ghc_ex -> io (print other_ghc_ex)
592 showException other_exception
593 = io (putStrLn ("*** Exception: " ++ show other_exception))
595 runStmt :: String -> GHCi (Maybe [Name])
597 | null (filter (not.isSpace) stmt) = return (Just [])
599 = do st <- getGHCiState
600 session <- getSession
601 result <- io $ withProgName (progname st) $ withArgs (args st) $
602 GHC.runStmt session stmt
604 GHC.RunFailed -> return Nothing
605 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
606 GHC.RunOk names -> return (Just names)
608 -- possibly print the type and revert CAFs after evaluating an expression
609 finishEvalExpr mb_names
610 = do b <- isOptionSet ShowType
611 session <- getSession
614 Just names -> when b (mapM_ (showTypeOfName session) names)
617 io installSignalHandlers
618 b <- isOptionSet RevertCAFs
619 io (when b revertCAFs)
622 showTypeOfName :: Session -> Name -> GHCi ()
623 showTypeOfName session n
624 = do maybe_tything <- io (GHC.lookupName session n)
625 case maybe_tything of
627 Just thing -> showTyThing thing
629 showForUser :: SDoc -> GHCi String
631 session <- getSession
632 unqual <- io (GHC.getPrintUnqual session)
633 return $! showSDocForUser unqual doc
635 specialCommand :: String -> GHCi Bool
636 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
637 specialCommand str = do
638 let (cmd,rest) = break isSpace str
639 maybe_cmd <- io (lookupCommand cmd)
641 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
642 ++ shortHelpText) >> return False)
643 Just (_,f,_,_) -> f (dropWhile isSpace rest)
645 lookupCommand :: String -> IO (Maybe Command)
646 lookupCommand str = do
647 cmds <- readIORef commands
648 -- look for exact match first, then the first prefix match
649 case [ c | c <- cmds, str == cmdName c ] of
650 c:_ -> return (Just c)
651 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
653 c:_ -> return (Just c)
655 -----------------------------------------------------------------------------
656 -- To flush buffers for the *interpreted* computation we need
657 -- to refer to *its* stdout/stderr handles
659 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
660 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
662 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
663 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
664 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
666 initInterpBuffering :: Session -> IO ()
667 initInterpBuffering session
668 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
671 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
672 other -> panic "interactiveUI:setBuffering"
674 maybe_hval <- GHC.compileExpr session flush_cmd
676 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
677 _ -> panic "interactiveUI:flush"
682 flushInterpBuffers :: GHCi ()
684 = io $ do Monad.join (readIORef flush_interp)
687 turnOffBuffering :: IO ()
689 = do Monad.join (readIORef turn_off_buffering)
692 -----------------------------------------------------------------------------
695 help :: String -> GHCi ()
696 help _ = io (putStr helpText)
698 info :: String -> GHCi ()
699 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
700 info s = do { let names = words s
701 ; session <- getSession
702 ; dflags <- getDynFlags
703 ; let exts = dopt Opt_GlasgowExts dflags
704 ; mapM_ (infoThing exts session) names }
706 infoThing exts session str = io $ do
707 names <- GHC.parseName session str
708 let filtered = filterOutChildren names
709 mb_stuffs <- mapM (GHC.getInfo session) filtered
710 unqual <- GHC.getPrintUnqual session
711 putStrLn (showSDocForUser unqual $
712 vcat (intersperse (text "") $
713 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
715 -- Filter out names whose parent is also there Good
716 -- example is '[]', which is both a type and data
717 -- constructor in the same type
718 filterOutChildren :: [Name] -> [Name]
719 filterOutChildren names = filter (not . parent_is_there) names
720 where parent_is_there n
721 | Just p <- GHC.nameParent_maybe n = p `elem` names
724 pprInfo exts (thing, fixity, insts)
725 = pprTyThingInContextLoc exts thing
726 $$ show_fixity fixity
727 $$ vcat (map GHC.pprInstance insts)
730 | fix == GHC.defaultFixity = empty
731 | otherwise = ppr fix <+> ppr (GHC.getName thing)
733 -----------------------------------------------------------------------------
736 runMain :: String -> GHCi ()
738 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
739 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
742 addModule :: [FilePath] -> GHCi ()
744 io (revertCAFs) -- always revert CAFs on load/add.
745 files <- mapM expandPath files
746 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
747 session <- getSession
748 io (mapM_ (GHC.addTarget session) targets)
749 ok <- io (GHC.load session LoadAllTargets)
752 changeDirectory :: String -> GHCi ()
753 changeDirectory dir = do
754 session <- getSession
755 graph <- io (GHC.getModuleGraph session)
756 when (not (null graph)) $
757 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
758 io (GHC.setTargets session [])
759 io (GHC.load session LoadAllTargets)
760 setContextAfterLoad session []
761 io (GHC.workingDirectoryChanged session)
762 dir <- expandPath dir
763 io (setCurrentDirectory dir)
765 editFile :: String -> GHCi ()
768 -- find the name of the "topmost" file loaded
769 session <- getSession
770 graph0 <- io (GHC.getModuleGraph session)
771 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
772 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
773 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
774 Just file -> do_edit file
775 Nothing -> throwDyn (CmdLineError "unknown file name")
776 | otherwise = do_edit str
782 throwDyn (CmdLineError "editor not set, use :set editor")
783 io $ system (cmd ++ ' ':file)
786 defineMacro :: String -> GHCi ()
788 let (macro_name, definition) = break isSpace s
789 cmds <- io (readIORef commands)
791 then throwDyn (CmdLineError "invalid macro name")
793 if (macro_name `elem` map cmdName cmds)
794 then throwDyn (CmdLineError
795 ("command '" ++ macro_name ++ "' is already defined"))
798 -- give the expression a type signature, so we can be sure we're getting
799 -- something of the right type.
800 let new_expr = '(' : definition ++ ") :: String -> IO String"
802 -- compile the expression
804 maybe_hv <- io (GHC.compileExpr cms new_expr)
807 Just hv -> io (writeIORef commands --
808 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
810 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
812 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
813 stringLoop (lines str)
815 undefineMacro :: String -> GHCi ()
816 undefineMacro macro_name = do
817 cmds <- io (readIORef commands)
818 if (macro_name `elem` map cmdName builtin_commands)
819 then throwDyn (CmdLineError
820 ("command '" ++ macro_name ++ "' cannot be undefined"))
822 if (macro_name `notElem` map cmdName cmds)
823 then throwDyn (CmdLineError
824 ("command '" ++ macro_name ++ "' not defined"))
826 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
829 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
830 loadModule fs = timeIt (loadModule' fs)
832 loadModule_ :: [FilePath] -> GHCi ()
833 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
835 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
836 loadModule' files = do
837 session <- getSession
840 io (GHC.setTargets session [])
841 io (GHC.load session LoadAllTargets)
844 let (filenames, phases) = unzip files
845 exp_filenames <- mapM expandPath filenames
846 let files' = zip exp_filenames phases
847 targets <- io (mapM (uncurry GHC.guessTarget) files')
849 -- NOTE: we used to do the dependency anal first, so that if it
850 -- fails we didn't throw away the current set of modules. This would
851 -- require some re-working of the GHC interface, so we'll leave it
852 -- as a ToDo for now.
854 io (GHC.setTargets session targets)
855 ok <- io (GHC.load session LoadAllTargets)
859 checkModule :: String -> GHCi ()
861 let modl = GHC.mkModuleName m
862 session <- getSession
863 result <- io (GHC.checkModule session modl)
865 Nothing -> io $ putStrLn "Nothing"
866 Just r -> io $ putStrLn (showSDoc (
867 case checkedModuleInfo r of
868 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
870 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
872 (text "global names: " <+> ppr global) $$
873 (text "local names: " <+> ppr local)
875 afterLoad (successIf (isJust result)) session
877 reloadModule :: String -> GHCi ()
879 io (revertCAFs) -- always revert CAFs on reload.
880 session <- getSession
881 ok <- io (GHC.load session LoadAllTargets)
884 io (revertCAFs) -- always revert CAFs on reload.
885 session <- getSession
886 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
889 afterLoad ok session = do
890 io (revertCAFs) -- always revert CAFs on load.
891 graph <- io (GHC.getModuleGraph session)
892 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
893 setContextAfterLoad session graph'
894 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
895 #if defined(GHCI) && defined(BREAKPOINT)
896 io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
897 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
900 setContextAfterLoad session [] = do
901 prel_mod <- getPrelude
902 io (GHC.setContext session [] [prel_mod])
903 setContextAfterLoad session ms = do
904 -- load a target if one is available, otherwise load the topmost module.
905 targets <- io (GHC.getTargets session)
906 case [ m | Just m <- map (findTarget ms) targets ] of
908 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
909 load_this (last graph')
914 = case filter (`matches` t) ms of
918 summary `matches` Target (TargetModule m) _
919 = GHC.ms_mod_name summary == m
920 summary `matches` Target (TargetFile f _) _
921 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
922 summary `matches` target
925 load_this summary | m <- GHC.ms_mod summary = do
926 b <- io (GHC.moduleIsInterpreted session m)
927 if b then io (GHC.setContext session [m] [])
929 prel_mod <- getPrelude
930 io (GHC.setContext session [] [prel_mod,m])
933 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
934 modulesLoadedMsg ok mods = do
935 dflags <- getDynFlags
936 when (verbosity dflags > 0) $ do
938 | null mods = text "none."
940 punctuate comma (map ppr mods)) <> text "."
943 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
945 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
948 typeOfExpr :: String -> GHCi ()
950 = do cms <- getSession
951 maybe_ty <- io (GHC.exprType cms str)
954 Just ty -> do ty' <- cleanType ty
955 tystr <- showForUser (ppr ty')
956 io (putStrLn (str ++ " :: " ++ tystr))
958 kindOfType :: String -> GHCi ()
960 = do cms <- getSession
961 maybe_ty <- io (GHC.typeKind cms str)
964 Just ty -> do tystr <- showForUser (ppr ty)
965 io (putStrLn (str ++ " :: " ++ tystr))
967 quit :: String -> GHCi Bool
970 shellEscape :: String -> GHCi Bool
971 shellEscape str = io (system str >> return False)
973 -----------------------------------------------------------------------------
974 -- create tags file for currently loaded modules.
976 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
978 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
979 createCTagsFileCmd file = ghciCreateTagsFile CTags file
981 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
982 createETagsFileCmd file = ghciCreateTagsFile ETags file
984 data TagsKind = ETags | CTags
986 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
987 ghciCreateTagsFile kind file = do
988 session <- getSession
989 io $ createTagsFile session kind file
992 -- - remove restriction that all modules must be interpreted
993 -- (problem: we don't know source locations for entities unless
994 -- we compiled the module.
996 -- - extract createTagsFile so it can be used from the command-line
997 -- (probably need to fix first problem before this is useful).
999 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
1000 createTagsFile session tagskind tagFile = do
1001 graph <- GHC.getModuleGraph session
1002 let ms = map GHC.ms_mod graph
1004 is_interpreted <- GHC.moduleIsInterpreted session m
1005 -- should we just skip these?
1006 when (not is_interpreted) $
1007 throwDyn (CmdLineError ("module '"
1008 ++ GHC.moduleNameString (GHC.moduleName m)
1009 ++ "' is not interpreted"))
1010 mbModInfo <- GHC.getModuleInfo session m
1012 | Just modinfo <- mbModInfo,
1013 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
1014 | otherwise = GHC.alwaysQualify
1017 Just modInfo -> return $! listTags unqual modInfo
1020 mtags <- mapM tagModule ms
1021 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
1023 Left e -> hPutStrLn stderr $ ioeGetErrorString e
1024 Right _ -> return ()
1026 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
1027 listTags unqual modInfo =
1028 [ tagInfo unqual name loc
1029 | name <- GHC.modInfoExports modInfo
1030 , let loc = nameSrcLoc name
1034 type TagInfo = (String -- tag name
1035 ,String -- file name
1037 ,Int -- column number
1040 -- get tag info, for later translation into Vim or Emacs style
1041 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
1042 tagInfo unqual name loc
1043 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
1044 , showSDocForUser unqual $ ftext (srcLocFile loc)
1049 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
1050 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
1051 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
1052 IO.try (writeFile file tags)
1053 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
1054 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
1055 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
1056 tagGroups <- mapM tagFileGroup groups
1057 IO.try (writeFile file $ concat tagGroups)
1059 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
1060 tagFileGroup group@((_,fileName,_,_):_) = do
1061 file <- readFile fileName -- need to get additional info from sources..
1062 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
1063 sortedGroup = sortLe byLine group
1064 tags = unlines $ perFile sortedGroup 1 0 $ lines file
1065 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
1066 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
1067 perFile (tagInfo:tags) (count+1) (pos+length line) lines
1068 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
1069 showETag tagInfo line pos : perFile tags count pos lines
1070 perFile tags count pos lines = []
1072 -- simple ctags format, for Vim et al
1073 showTag :: TagInfo -> String
1074 showTag (tag,file,lineNo,colNo)
1075 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
1077 -- etags format, for Emacs/XEmacs
1078 showETag :: TagInfo -> String -> Int -> String
1079 showETag (tag,file,lineNo,colNo) line charPos
1080 = take colNo line ++ tag
1082 ++ "\x01" ++ show lineNo
1083 ++ "," ++ show charPos
1085 -----------------------------------------------------------------------------
1086 -- Browsing a module's contents
1088 browseCmd :: String -> GHCi ()
1091 ['*':m] | looksLikeModuleName m -> browseModule m False
1092 [m] | looksLikeModuleName m -> browseModule m True
1093 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1095 browseModule m exports_only = do
1097 modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
1098 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1099 when (not is_interpreted && not exports_only) $
1100 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1102 -- Temporarily set the context to the module we're interested in,
1103 -- just so we can get an appropriate PrintUnqualified
1104 (as,bs) <- io (GHC.getContext s)
1105 prel_mod <- getPrelude
1106 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1107 else GHC.setContext s [modl] [])
1108 unqual <- io (GHC.getPrintUnqual s)
1109 io (GHC.setContext s as bs)
1111 mb_mod_info <- io $ GHC.getModuleInfo s modl
1113 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1116 | exports_only = GHC.modInfoExports mod_info
1117 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1119 filtered = filterOutChildren names
1121 things <- io $ mapM (GHC.lookupName s) filtered
1123 dflags <- getDynFlags
1124 let exts = dopt Opt_GlasgowExts dflags
1125 io (putStrLn (showSDocForUser unqual (
1126 vcat (map (pprTyThingInContext exts) (catMaybes things))
1128 -- ToDo: modInfoInstances currently throws an exception for
1129 -- package modules. When it works, we can do this:
1130 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1132 -----------------------------------------------------------------------------
1133 -- Setting the module context
1136 | all sensible mods = fn mods
1137 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1139 (fn, mods) = case str of
1140 '+':stuff -> (addToContext, words stuff)
1141 '-':stuff -> (removeFromContext, words stuff)
1142 stuff -> (newContext, words stuff)
1144 sensible ('*':m) = looksLikeModuleName m
1145 sensible m = looksLikeModuleName m
1147 separate :: Session -> [String] -> [Module] -> [Module]
1148 -> GHCi ([Module],[Module])
1149 separate session [] as bs = return (as,bs)
1150 separate session (('*':str):ms) as bs = do
1151 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1152 b <- io $ GHC.moduleIsInterpreted session m
1153 if b then separate session ms (m:as) bs
1154 else throwDyn (CmdLineError ("module '"
1155 ++ GHC.moduleNameString (GHC.moduleName m)
1156 ++ "' is not interpreted"))
1157 separate session (str:ms) as bs = do
1158 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1159 separate session ms as (m:bs)
1161 newContext :: [String] -> GHCi ()
1162 newContext strs = do
1164 (as,bs) <- separate s strs [] []
1165 prel_mod <- getPrelude
1166 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1167 io $ GHC.setContext s as bs'
1170 addToContext :: [String] -> GHCi ()
1171 addToContext strs = do
1173 (as,bs) <- io $ GHC.getContext s
1175 (new_as,new_bs) <- separate s strs [] []
1177 let as_to_add = new_as \\ (as ++ bs)
1178 bs_to_add = new_bs \\ (as ++ bs)
1180 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1183 removeFromContext :: [String] -> GHCi ()
1184 removeFromContext strs = do
1186 (as,bs) <- io $ GHC.getContext s
1188 (as_to_remove,bs_to_remove) <- separate s strs [] []
1190 let as' = as \\ (as_to_remove ++ bs_to_remove)
1191 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1193 io $ GHC.setContext s as' bs'
1195 ----------------------------------------------------------------------------
1198 -- set options in the interpreter. Syntax is exactly the same as the
1199 -- ghc command line, except that certain options aren't available (-C,
1202 -- This is pretty fragile: most options won't work as expected. ToDo:
1203 -- figure out which ones & disallow them.
1205 setCmd :: String -> GHCi ()
1207 = do st <- getGHCiState
1208 let opts = options st
1209 io $ putStrLn (showSDoc (
1210 text "options currently set: " <>
1213 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1216 = case toArgs str of
1217 ("args":args) -> setArgs args
1218 ("prog":prog) -> setProg prog
1219 ("prompt":prompt) -> setPrompt (after 6)
1220 ("editor":cmd) -> setEditor (after 6)
1221 wds -> setOptions wds
1222 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1226 setGHCiState st{ args = args }
1230 setGHCiState st{ progname = prog }
1232 io (hPutStrLn stderr "syntax: :set prog <progname>")
1236 setGHCiState st{ editor = cmd }
1238 setPrompt value = do
1241 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1242 else setGHCiState st{ prompt = remQuotes value }
1244 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1248 do -- first, deal with the GHCi opts (+s, +t, etc.)
1249 let (plus_opts, minus_opts) = partition isPlus wds
1250 mapM_ setOpt plus_opts
1252 -- then, dynamic flags
1253 dflags <- getDynFlags
1254 let pkg_flags = packageFlags dflags
1255 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1257 if (not (null leftovers))
1258 then throwDyn (CmdLineError ("unrecognised flags: " ++
1262 new_pkgs <- setDynFlags dflags'
1264 -- if the package flags changed, we should reset the context
1265 -- and link the new packages.
1266 dflags <- getDynFlags
1267 when (packageFlags dflags /= pkg_flags) $ do
1268 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1269 session <- getSession
1270 io (GHC.setTargets session [])
1271 io (GHC.load session LoadAllTargets)
1272 io (linkPackages dflags new_pkgs)
1273 setContextAfterLoad session []
1277 unsetOptions :: String -> GHCi ()
1279 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1280 let opts = words str
1281 (minus_opts, rest1) = partition isMinus opts
1282 (plus_opts, rest2) = partition isPlus rest1
1284 if (not (null rest2))
1285 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1288 mapM_ unsetOpt plus_opts
1290 -- can't do GHC flags for now
1291 if (not (null minus_opts))
1292 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1295 isMinus ('-':s) = True
1298 isPlus ('+':s) = True
1302 = case strToGHCiOpt str of
1303 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1304 Just o -> setOption o
1307 = case strToGHCiOpt str of
1308 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1309 Just o -> unsetOption o
1311 strToGHCiOpt :: String -> (Maybe GHCiOption)
1312 strToGHCiOpt "s" = Just ShowTiming
1313 strToGHCiOpt "t" = Just ShowType
1314 strToGHCiOpt "r" = Just RevertCAFs
1315 strToGHCiOpt _ = Nothing
1317 optToStr :: GHCiOption -> String
1318 optToStr ShowTiming = "s"
1319 optToStr ShowType = "t"
1320 optToStr RevertCAFs = "r"
1322 -- ---------------------------------------------------------------------------
1327 ["modules" ] -> showModules
1328 ["bindings"] -> showBindings
1329 ["linker"] -> io showLinkerState
1330 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1333 session <- getSession
1334 let show_one ms = do m <- io (GHC.showModule session ms)
1336 graph <- io (GHC.getModuleGraph session)
1337 mapM_ show_one graph
1341 unqual <- io (GHC.getPrintUnqual s)
1342 bindings <- io (GHC.getBindings s)
1343 mapM_ showTyThing bindings
1346 showTyThing (AnId id) = do
1347 ty' <- cleanType (GHC.idType id)
1348 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1350 showTyThing _ = return ()
1352 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1353 cleanType :: Type -> GHCi Type
1355 dflags <- getDynFlags
1356 if dopt Opt_GlasgowExts dflags
1358 else return $! GHC.dropForAlls ty
1360 -- -----------------------------------------------------------------------------
1363 completeNone :: String -> IO [String]
1364 completeNone w = return []
1367 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1368 completeWord w start end = do
1369 line <- Readline.getLineBuffer
1371 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1373 | Just c <- is_cmd line -> do
1374 maybe_cmd <- lookupCommand c
1375 let (n,w') = selectWord (words' 0 line)
1377 Nothing -> return Nothing
1378 Just (_,_,False,complete) -> wrapCompleter complete w
1379 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1380 return (map (drop n) rets)
1381 in wrapCompleter complete' w'
1383 --printf "complete %s, start = %d, end = %d\n" w start end
1384 wrapCompleter completeIdentifier w
1385 where words' _ [] = []
1386 words' n str = let (w,r) = break isSpace str
1387 (s,r') = span isSpace r
1388 in (n,w):words' (n+length w+length s) r'
1389 -- In a Haskell expression we want to parse 'a-b' as three words
1390 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1391 -- only be a single word.
1392 selectWord [] = (0,w)
1393 selectWord ((offset,x):xs)
1394 | offset+length x >= start = (start-offset,take (end-offset) x)
1395 | otherwise = selectWord xs
1398 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1399 | otherwise = Nothing
1402 cmds <- readIORef commands
1403 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1405 completeMacro w = do
1406 cmds <- readIORef commands
1407 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1408 return (filter (w `isPrefixOf`) cmds')
1410 completeIdentifier w = do
1412 rdrs <- GHC.getRdrNamesInScope s
1413 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1415 completeModule w = do
1417 dflags <- GHC.getSessionDynFlags s
1418 let pkg_mods = allExposedModules dflags
1419 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1421 completeHomeModule w = do
1423 g <- GHC.getModuleGraph s
1424 let home_mods = map GHC.ms_mod_name g
1425 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1427 completeSetOptions w = do
1428 return (filter (w `isPrefixOf`) options)
1429 where options = "args":"prog":allFlags
1431 completeFilename = Readline.filenameCompletionFunction
1433 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1435 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1436 unionComplete f1 f2 w = do
1441 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1442 wrapCompleter fun w = do
1445 [] -> return Nothing
1446 [x] -> return (Just (x,[]))
1447 xs -> case getCommonPrefix xs of
1448 "" -> return (Just ("",xs))
1449 pref -> return (Just (pref,xs))
1451 getCommonPrefix :: [String] -> String
1452 getCommonPrefix [] = ""
1453 getCommonPrefix (s:ss) = foldl common s ss
1454 where common s "" = s
1456 common (c:cs) (d:ds)
1457 | c == d = c : common cs ds
1460 allExposedModules :: DynFlags -> [ModuleName]
1461 allExposedModules dflags
1462 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1464 pkg_db = pkgIdMap (pkgState dflags)
1466 completeCmd = completeNone
1467 completeMacro = completeNone
1468 completeIdentifier = completeNone
1469 completeModule = completeNone
1470 completeHomeModule = completeNone
1471 completeSetOptions = completeNone
1472 completeFilename = completeNone
1473 completeHomeModuleOrFile=completeNone
1476 -----------------------------------------------------------------------------
1479 data GHCiState = GHCiState
1485 session :: GHC.Session,
1486 options :: [GHCiOption],
1491 = ShowTiming -- show time/allocs after evaluation
1492 | ShowType -- show the type of expressions
1493 | RevertCAFs -- revert CAFs after every evaluation
1496 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1498 startGHCi :: GHCi a -> GHCiState -> IO a
1499 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1501 instance Monad GHCi where
1502 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1503 return a = GHCi $ \s -> return a
1505 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1506 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1507 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1509 getGHCiState = GHCi $ \r -> readIORef r
1510 setGHCiState s = GHCi $ \r -> writeIORef r s
1512 -- for convenience...
1513 getSession = getGHCiState >>= return . session
1514 getPrelude = getGHCiState >>= return . prelude
1516 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
1517 no_saved_sess = error "no saved_ses"
1518 saveSession = getSession >>= io . writeIORef saved_sess
1519 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
1520 restoreSession = readIORef saved_sess
1524 io (GHC.getSessionDynFlags s)
1525 setDynFlags dflags = do
1527 io (GHC.setSessionDynFlags s dflags)
1529 isOptionSet :: GHCiOption -> GHCi Bool
1531 = do st <- getGHCiState
1532 return (opt `elem` options st)
1534 setOption :: GHCiOption -> GHCi ()
1536 = do st <- getGHCiState
1537 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1539 unsetOption :: GHCiOption -> GHCi ()
1541 = do st <- getGHCiState
1542 setGHCiState (st{ options = filter (/= opt) (options st) })
1544 io :: IO a -> GHCi a
1545 io m = GHCi { unGHCi = \s -> m >>= return }
1547 -----------------------------------------------------------------------------
1548 -- recursive exception handlers
1550 -- Don't forget to unblock async exceptions in the handler, or if we're
1551 -- in an exception loop (eg. let a = error a in a) the ^C exception
1552 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1554 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1555 ghciHandle h (GHCi m) = GHCi $ \s ->
1556 Exception.catch (m s)
1557 (\e -> unGHCi (ghciUnblock (h e)) s)
1559 ghciUnblock :: GHCi a -> GHCi a
1560 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1562 -----------------------------------------------------------------------------
1563 -- timing & statistics
1565 timeIt :: GHCi a -> GHCi a
1567 = do b <- isOptionSet ShowTiming
1570 else do allocs1 <- io $ getAllocations
1571 time1 <- io $ getCPUTime
1573 allocs2 <- io $ getAllocations
1574 time2 <- io $ getCPUTime
1575 io $ printTimes (fromIntegral (allocs2 - allocs1))
1579 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1580 -- defined in ghc/rts/Stats.c
1582 printTimes :: Integer -> Integer -> IO ()
1583 printTimes allocs psecs
1584 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1585 secs_str = showFFloat (Just 2) secs
1586 putStrLn (showSDoc (
1587 parens (text (secs_str "") <+> text "secs" <> comma <+>
1588 text (show allocs) <+> text "bytes")))
1590 -----------------------------------------------------------------------------
1597 -- Have to turn off buffering again, because we just
1598 -- reverted stdout, stderr & stdin to their defaults.
1600 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1601 -- Make it "safe", just in case
1603 -- ----------------------------------------------------------------------------
1606 expandPath :: String -> GHCi String
1608 case dropWhile isSpace path of
1610 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1611 return (tilde ++ '/':d)
1615 -- ----------------------------------------------------------------------------
1616 -- Windows console setup
1618 setUpConsole :: IO ()
1620 #ifdef mingw32_HOST_OS
1621 -- On Windows we need to set a known code page, otherwise the characters
1622 -- we read from the console will be be in some strange encoding, and
1623 -- similarly for characters we write to the console.
1625 -- At the moment, GHCi pretends all input is Latin-1. In the
1626 -- future we should support UTF-8, but for now we set the code pages
1629 -- It seems you have to set the font in the console window to
1630 -- a Unicode font in order for output to work properly,
1631 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1632 -- (see MSDN for SetConsoleOutputCP()).
1634 setConsoleCP 28591 -- ISO Latin-1
1635 setConsoleOutputCP 28591 -- ISO Latin-1