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,
29 initDynLinker, linkPackages )
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 )
60 import Util ( removeSpaces, handle, global, toArgs,
61 looksLikeModuleName, prefixMatch, sortLe )
63 #ifndef mingw32_HOST_OS
65 #if __GLASGOW_HASKELL__ > 504
69 import GHC.ConsoleHandler ( flushConsole )
70 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
74 import Control.Concurrent ( yield ) -- Used in readline loop
75 import System.Console.Readline as Readline
80 import Control.Exception as Exception
82 -- import Control.Concurrent
86 import Data.Int ( Int64 )
87 import Data.Maybe ( isJust, fromMaybe, catMaybes )
90 import System.Environment
91 import System.Exit ( exitWith, ExitCode(..) )
92 import System.Directory
94 import System.IO.Error as IO
96 import Control.Monad as Monad
97 import Foreign.StablePtr ( newStablePtr )
99 import GHC.Exts ( unsafeCoerce# )
100 import GHC.IOBase ( IOErrorType(InvalidArgument) )
102 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
104 import System.Posix.Internals ( setNonBlockingFD )
106 -----------------------------------------------------------------------------
110 " / _ \\ /\\ /\\/ __(_)\n"++
111 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
112 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
113 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
115 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
116 cmdName (n,_,_,_) = n
118 GLOBAL_VAR(commands, builtin_commands, [Command])
120 builtin_commands :: [Command]
122 ("add", keepGoingPaths addModule, False, completeFilename),
123 ("browse", keepGoing browseCmd, False, completeModule),
124 ("cd", keepGoing changeDirectory, False, completeFilename),
125 ("def", keepGoing defineMacro, False, completeIdentifier),
126 ("help", keepGoing help, False, completeNone),
127 ("?", keepGoing help, False, completeNone),
128 ("info", keepGoing info, False, completeIdentifier),
129 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
130 ("module", keepGoing setContext, False, completeModule),
131 ("main", keepGoing runMain, False, completeIdentifier),
132 ("reload", keepGoing reloadModule, False, completeNone),
133 ("check", keepGoing checkModule, False, completeHomeModule),
134 ("set", keepGoing setCmd, True, completeSetOptions),
135 ("show", keepGoing showCmd, False, completeNone),
136 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
137 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
138 ("type", keepGoing typeOfExpr, False, completeIdentifier),
139 ("kind", keepGoing kindOfType, False, completeIdentifier),
140 ("unset", keepGoing unsetOptions, True, completeSetOptions),
141 ("undef", keepGoing undefineMacro, False, completeMacro),
142 ("quit", quit, False, completeNone)
145 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
146 keepGoing a str = a str >> return False
148 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
149 keepGoingPaths a str = a (toArgs str) >> return False
151 shortHelpText = "use :? for help.\n"
153 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
155 " Commands available from the prompt:\n" ++
157 " <stmt> evaluate/run <stmt>\n" ++
158 " :add <filename> ... add module(s) to the current target set\n" ++
159 " :browse [*]<module> display the names defined by <module>\n" ++
160 " :cd <dir> change directory to <dir>\n" ++
161 " :def <cmd> <expr> define a command :<cmd>\n" ++
162 " :help, :? display this list of commands\n" ++
163 " :info [<name> ...] display information about the given names\n" ++
164 " :load <filename> ... load module(s) and their dependents\n" ++
165 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
166 " :main [<arguments> ...] run the main function with the given arguments\n" ++
167 " :reload reload the current module set\n" ++
169 " :set <option> ... set options\n" ++
170 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
171 " :set prog <progname> set the value returned by System.getProgName\n" ++
172 " :set prompt <prompt> set the prompt used in GHCi\n" ++
174 " :show modules show the currently loaded modules\n" ++
175 " :show bindings show the current bindings made at the prompt\n" ++
177 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
178 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
179 " :type <expr> show the type of <expr>\n" ++
180 " :kind <type> show the kind of <type>\n" ++
181 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
182 " :unset <option> ... unset options\n" ++
183 " :quit exit GHCi\n" ++
184 " :!<command> run the shell command <command>\n" ++
186 " Options for ':set' and ':unset':\n" ++
188 " +r revert top-level expressions after each evaluation\n" ++
189 " +s print timing/memory stats after each evaluation\n" ++
190 " +t print type after evaluation\n" ++
191 " -<flags> most GHC command line flags can also be set here\n" ++
192 " (eg. -v2, -fglasgow-exts, etc.)\n"
195 #if defined(GHCI) && defined(BREAKPOINT)
196 globaliseAndTidy :: Id -> Id
198 -- Give the Id a Global Name, and tidy its type
199 = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
201 tidy_type = tidyTopType (idType id)
204 printScopeMsg :: Session -> String -> [Id] -> IO ()
205 printScopeMsg session location ids
206 = GHC.getPrintUnqual session >>= \unqual ->
207 printForUser stdout unqual $
208 text "Local bindings in scope:" $$
209 nest 2 (pprWithCommas showId ids)
210 where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
212 jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
213 jumpCondFunction session ptr hValues location True b = b
214 jumpCondFunction session ptr hValues location False b
215 = jumpFunction session ptr hValues location b
217 jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
218 jumpFunction session@(Session ref) (I# idsPtr) hValues location b
220 do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
221 let names = map idName ids
222 ASSERT (length names == length hValues) return ()
223 printScopeMsg session location ids
224 hsc_env <- readIORef ref
226 let ictxt = hsc_IC hsc_env
227 global_ids = map globaliseAndTidy ids
228 rn_env = ic_rn_local_env ictxt
229 type_env = ic_type_env ictxt
230 bound_names = map idName global_ids
231 new_rn_env = extendLocalRdrEnv rn_env bound_names
232 -- Remove any shadowed bindings from the type_env;
233 -- they are inaccessible but might, I suppose, cause
234 -- a space leak if we leave them there
235 shadowed = [ n | name <- bound_names,
236 let rdr_name = mkRdrUnqual (nameOccName name),
237 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
238 filtered_type_env = delListFromNameEnv type_env shadowed
239 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
240 new_ic = ictxt { ic_rn_local_env = new_rn_env,
241 ic_type_env = new_type_env }
242 writeIORef ref (hsc_env { hsc_IC = new_ic })
243 is_tty <- hIsTerminalDevice stdin
244 prel_mod <- GHC.findModule session prel_name Nothing
245 withExtendedLinkEnv (zip names hValues) $
246 startGHCi (interactiveLoop is_tty True)
247 GHCiState{ progname = "<interactive>",
249 prompt = location++"> ",
253 writeIORef ref hsc_env
254 putStrLn $ "Returning to normal execution..."
258 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
259 interactiveUI session srcs maybe_expr = do
260 #if defined(GHCI) && defined(BREAKPOINT)
261 initDynLinker =<< GHC.getSessionDynFlags session
262 extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
263 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
265 -- HACK! If we happen to get into an infinite loop (eg the user
266 -- types 'let x=x in x' at the prompt), then the thread will block
267 -- on a blackhole, and become unreachable during GC. The GC will
268 -- detect that it is unreachable and send it the NonTermination
269 -- exception. However, since the thread is unreachable, everything
270 -- it refers to might be finalized, including the standard Handles.
271 -- This sounds like a bug, but we don't have a good solution right
278 hSetBuffering stdout NoBuffering
280 -- Initialise buffering for the *interpreted* I/O system
281 initInterpBuffering session
283 -- We don't want the cmd line to buffer any input that might be
284 -- intended for the program, so unbuffer stdin.
285 hSetBuffering stdin NoBuffering
287 -- initial context is just the Prelude
288 prel_mod <- GHC.findModule session prel_name Nothing
289 GHC.setContext session [] [prel_mod]
293 Readline.setAttemptedCompletionFunction (Just completeWord)
294 --Readline.parseAndBind "set show-all-if-ambiguous 1"
296 let symbols = "!#$%&*+/<=>?@\\^|-~"
297 specials = "(),;[]`{}"
299 word_break_chars = spaces ++ specials ++ symbols
301 Readline.setBasicWordBreakCharacters word_break_chars
302 Readline.setCompleterWordBreakCharacters word_break_chars
305 startGHCi (runGHCi srcs maybe_expr)
306 GHCiState{ progname = "<interactive>",
314 Readline.resetTerminal Nothing
319 prel_name = GHC.mkModuleName "Prelude"
321 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
322 runGHCi paths maybe_expr = do
323 let read_dot_files = not opt_IgnoreDotGhci
325 when (read_dot_files) $ do
328 exists <- io (doesFileExist file)
330 dir_ok <- io (checkPerms ".")
331 file_ok <- io (checkPerms file)
332 when (dir_ok && file_ok) $ do
333 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
336 Right hdl -> fileLoop hdl False
338 when (read_dot_files) $ do
339 -- Read in $HOME/.ghci
340 either_dir <- io (IO.try (getEnv "HOME"))
344 cwd <- io (getCurrentDirectory)
345 when (dir /= cwd) $ do
346 let file = dir ++ "/.ghci"
347 ok <- io (checkPerms file)
349 either_hdl <- io (IO.try (openFile file ReadMode))
352 Right hdl -> fileLoop hdl False
354 -- Perform a :load for files given on the GHCi command line
355 -- When in -e mode, if the load fails then we want to stop
356 -- immediately rather than going on to evaluate the expression.
357 when (not (null paths)) $ do
358 ok <- ghciHandle (\e -> do showException e; return Failed) $
360 when (isJust maybe_expr && failed ok) $
361 io (exitWith (ExitFailure 1))
363 -- if verbosity is greater than 0, or we are connected to a
364 -- terminal, display the prompt in the interactive loop.
365 is_tty <- io (hIsTerminalDevice stdin)
366 dflags <- getDynFlags
367 let show_prompt = verbosity dflags > 0 || is_tty
372 #if defined(mingw32_HOST_OS)
373 -- The win32 Console API mutates the first character of
374 -- type-ahead when reading from it in a non-buffered manner. Work
375 -- around this by flushing the input buffer of type-ahead characters,
376 -- but only if stdin is available.
377 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
379 Left err | isDoesNotExistError err -> return ()
380 | otherwise -> io (ioError err)
381 Right () -> return ()
383 -- initialise the console if necessary
386 -- enter the interactive loop
387 interactiveLoop is_tty show_prompt
389 -- just evaluate the expression we were given
394 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
397 interactiveLoop is_tty show_prompt =
398 -- Ignore ^C exceptions caught here
399 ghciHandleDyn (\e -> case e of
401 #if defined(mingw32_HOST_OS)
404 interactiveLoop is_tty show_prompt
405 _other -> return ()) $
407 ghciUnblock $ do -- unblock necessary if we recursed from the
408 -- exception handler above.
410 -- read commands from stdin
414 else fileLoop stdin show_prompt
416 fileLoop stdin show_prompt
420 -- NOTE: We only read .ghci files if they are owned by the current user,
421 -- and aren't world writable. Otherwise, we could be accidentally
422 -- running code planted by a malicious third party.
424 -- Furthermore, We only read ./.ghci if . is owned by the current user
425 -- and isn't writable by anyone else. I think this is sufficient: we
426 -- don't need to check .. and ../.. etc. because "." always refers to
427 -- the same directory while a process is running.
429 checkPerms :: String -> IO Bool
431 #ifdef mingw32_HOST_OS
434 Util.handle (\_ -> return False) $ do
435 st <- getFileStatus name
437 if fileOwner st /= me then do
438 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
441 let mode = fileMode st
442 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
443 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
445 putStrLn $ "*** WARNING: " ++ name ++
446 " is writable by someone else, IGNORING!"
451 fileLoop :: Handle -> Bool -> GHCi ()
452 fileLoop hdl show_prompt = do
453 session <- getSession
454 (mod,imports) <- io (GHC.getContext session)
456 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
457 l <- io (IO.try (hGetLine hdl))
459 Left e | isEOFError e -> return ()
460 | InvalidArgument <- etype -> return ()
461 | otherwise -> io (ioError e)
462 where etype = ioeGetErrorType e
463 -- treat InvalidArgument in the same way as EOF:
464 -- this can happen if the user closed stdin, or
465 -- perhaps did getContents which closes stdin at
468 case removeSpaces l of
469 "" -> fileLoop hdl show_prompt
470 l -> do quit <- runCommand l
471 if quit then return () else fileLoop hdl show_prompt
473 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
474 stringLoop [] = return False
475 stringLoop (s:ss) = do
476 case removeSpaces s of
478 l -> do quit <- runCommand l
479 if quit then return True else stringLoop ss
481 mkPrompt toplevs exports prompt
482 = showSDoc $ f prompt
484 f ('%':'s':xs) = perc_s <> f xs
485 f ('%':'%':xs) = char '%' <> f xs
486 f (x:xs) = char x <> f xs
489 perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
490 hsep (map (ppr . GHC.moduleName) exports)
494 readlineLoop :: GHCi ()
496 session <- getSession
497 (mod,imports) <- io (GHC.getContext session)
499 saveSession -- for use by completion
501 l <- io (readline (mkPrompt mod imports (prompt st))
502 `finally` setNonBlockingFD 0)
503 -- readline sometimes puts stdin into blocking mode,
504 -- so we need to put it back for the IO library
509 case removeSpaces l of
514 if quit then return () else readlineLoop
517 runCommand :: String -> GHCi Bool
518 runCommand c = ghciHandle handler (doCommand c)
520 doCommand (':' : command) = specialCommand command
522 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
525 -- This version is for the GHC command-line option -e. The only difference
526 -- from runCommand is that it catches the ExitException exception and
527 -- exits, rather than printing out the exception.
528 runCommandEval c = ghciHandle handleEval (doCommand c)
530 handleEval (ExitException code) = io (exitWith code)
531 handleEval e = do handler e
532 io (exitWith (ExitFailure 1))
534 doCommand (':' : command) = specialCommand command
536 = do nms <- runStmt stmt
538 Nothing -> io (exitWith (ExitFailure 1))
539 -- failure to run the command causes exit(1) for ghc -e.
540 _ -> finishEvalExpr nms
542 -- This is the exception handler for exceptions generated by the
543 -- user's code; it normally just prints out the exception. The
544 -- handler must be recursive, in case showing the exception causes
545 -- more exceptions to be raised.
547 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
548 -- raising another exception. We therefore don't put the recursive
549 -- handler arond the flushing operation, so if stderr is closed
550 -- GHCi will just die gracefully rather than going into an infinite loop.
551 handler :: Exception -> GHCi Bool
552 handler exception = do
554 io installSignalHandlers
555 ghciHandle handler (showException exception >> return False)
557 showException (DynException dyn) =
558 case fromDynamic dyn of
559 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
560 Just Interrupted -> io (putStrLn "Interrupted.")
561 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
562 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
563 Just other_ghc_ex -> io (print other_ghc_ex)
565 showException other_exception
566 = io (putStrLn ("*** Exception: " ++ show other_exception))
568 runStmt :: String -> GHCi (Maybe [Name])
570 | null (filter (not.isSpace) stmt) = return (Just [])
572 = do st <- getGHCiState
573 session <- getSession
574 result <- io $ withProgName (progname st) $ withArgs (args st) $
575 GHC.runStmt session stmt
577 GHC.RunFailed -> return Nothing
578 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
579 GHC.RunOk names -> return (Just names)
581 -- possibly print the type and revert CAFs after evaluating an expression
582 finishEvalExpr mb_names
583 = do b <- isOptionSet ShowType
584 session <- getSession
587 Just names -> when b (mapM_ (showTypeOfName session) names)
590 io installSignalHandlers
591 b <- isOptionSet RevertCAFs
592 io (when b revertCAFs)
595 showTypeOfName :: Session -> Name -> GHCi ()
596 showTypeOfName session n
597 = do maybe_tything <- io (GHC.lookupName session n)
598 case maybe_tything of
600 Just thing -> showTyThing thing
602 showForUser :: SDoc -> GHCi String
604 session <- getSession
605 unqual <- io (GHC.getPrintUnqual session)
606 return $! showSDocForUser unqual doc
608 specialCommand :: String -> GHCi Bool
609 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
610 specialCommand str = do
611 let (cmd,rest) = break isSpace str
612 maybe_cmd <- io (lookupCommand cmd)
614 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
615 ++ shortHelpText) >> return False)
616 Just (_,f,_,_) -> f (dropWhile isSpace rest)
618 lookupCommand :: String -> IO (Maybe Command)
619 lookupCommand str = do
620 cmds <- readIORef commands
621 -- look for exact match first, then the first prefix match
622 case [ c | c <- cmds, str == cmdName c ] of
623 c:_ -> return (Just c)
624 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
626 c:_ -> return (Just c)
628 -----------------------------------------------------------------------------
629 -- To flush buffers for the *interpreted* computation we need
630 -- to refer to *its* stdout/stderr handles
632 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
633 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
635 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
636 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
637 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
639 initInterpBuffering :: Session -> IO ()
640 initInterpBuffering session
641 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
644 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
645 other -> panic "interactiveUI:setBuffering"
647 maybe_hval <- GHC.compileExpr session flush_cmd
649 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
650 _ -> panic "interactiveUI:flush"
652 turnOffBuffering -- Turn it off right now
657 flushInterpBuffers :: GHCi ()
659 = io $ do Monad.join (readIORef flush_interp)
662 turnOffBuffering :: IO ()
664 = do Monad.join (readIORef turn_off_buffering)
667 -----------------------------------------------------------------------------
670 help :: String -> GHCi ()
671 help _ = io (putStr helpText)
673 info :: String -> GHCi ()
674 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
675 info s = do { let names = words s
676 ; session <- getSession
677 ; dflags <- getDynFlags
678 ; let exts = dopt Opt_GlasgowExts dflags
679 ; mapM_ (infoThing exts session) names }
681 infoThing exts session str = io $ do
682 names <- GHC.parseName session str
683 let filtered = filterOutChildren names
684 mb_stuffs <- mapM (GHC.getInfo session) filtered
685 unqual <- GHC.getPrintUnqual session
686 putStrLn (showSDocForUser unqual $
687 vcat (intersperse (text "") $
688 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
690 -- Filter out names whose parent is also there Good
691 -- example is '[]', which is both a type and data
692 -- constructor in the same type
693 filterOutChildren :: [Name] -> [Name]
694 filterOutChildren names = filter (not . parent_is_there) names
695 where parent_is_there n
696 | Just p <- GHC.nameParent_maybe n = p `elem` names
699 pprInfo exts (thing, fixity, insts)
700 = pprTyThingInContextLoc exts thing
701 $$ show_fixity fixity
702 $$ vcat (map GHC.pprInstance insts)
705 | fix == GHC.defaultFixity = empty
706 | otherwise = ppr fix <+> ppr (GHC.getName thing)
708 -----------------------------------------------------------------------------
711 runMain :: String -> GHCi ()
713 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
714 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
717 addModule :: [FilePath] -> GHCi ()
719 io (revertCAFs) -- always revert CAFs on load/add.
720 files <- mapM expandPath files
721 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
722 session <- getSession
723 io (mapM_ (GHC.addTarget session) targets)
724 ok <- io (GHC.load session LoadAllTargets)
727 changeDirectory :: String -> GHCi ()
728 changeDirectory dir = do
729 session <- getSession
730 graph <- io (GHC.getModuleGraph session)
731 when (not (null graph)) $
732 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
733 io (GHC.setTargets session [])
734 io (GHC.load session LoadAllTargets)
735 setContextAfterLoad session []
736 io (GHC.workingDirectoryChanged session)
737 dir <- expandPath dir
738 io (setCurrentDirectory dir)
740 defineMacro :: String -> GHCi ()
742 let (macro_name, definition) = break isSpace s
743 cmds <- io (readIORef commands)
745 then throwDyn (CmdLineError "invalid macro name")
747 if (macro_name `elem` map cmdName cmds)
748 then throwDyn (CmdLineError
749 ("command '" ++ macro_name ++ "' is already defined"))
752 -- give the expression a type signature, so we can be sure we're getting
753 -- something of the right type.
754 let new_expr = '(' : definition ++ ") :: String -> IO String"
756 -- compile the expression
758 maybe_hv <- io (GHC.compileExpr cms new_expr)
761 Just hv -> io (writeIORef commands --
762 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
764 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
766 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
767 stringLoop (lines str)
769 undefineMacro :: String -> GHCi ()
770 undefineMacro macro_name = do
771 cmds <- io (readIORef commands)
772 if (macro_name `elem` map cmdName builtin_commands)
773 then throwDyn (CmdLineError
774 ("command '" ++ macro_name ++ "' cannot be undefined"))
776 if (macro_name `notElem` map cmdName cmds)
777 then throwDyn (CmdLineError
778 ("command '" ++ macro_name ++ "' not defined"))
780 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
783 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
784 loadModule fs = timeIt (loadModule' fs)
786 loadModule_ :: [FilePath] -> GHCi ()
787 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
789 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
790 loadModule' files = do
791 session <- getSession
794 io (GHC.setTargets session [])
795 io (GHC.load session LoadAllTargets)
798 let (filenames, phases) = unzip files
799 exp_filenames <- mapM expandPath filenames
800 let files' = zip exp_filenames phases
801 targets <- io (mapM (uncurry GHC.guessTarget) files')
803 -- NOTE: we used to do the dependency anal first, so that if it
804 -- fails we didn't throw away the current set of modules. This would
805 -- require some re-working of the GHC interface, so we'll leave it
806 -- as a ToDo for now.
808 io (GHC.setTargets session targets)
809 ok <- io (GHC.load session LoadAllTargets)
813 checkModule :: String -> GHCi ()
815 let modl = GHC.mkModuleName m
816 session <- getSession
817 result <- io (GHC.checkModule session modl)
819 Nothing -> io $ putStrLn "Nothing"
820 Just r -> io $ putStrLn (showSDoc (
821 case checkedModuleInfo r of
822 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
824 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
826 (text "global names: " <+> ppr global) $$
827 (text "local names: " <+> ppr local)
829 afterLoad (successIf (isJust result)) session
831 reloadModule :: String -> GHCi ()
833 io (revertCAFs) -- always revert CAFs on reload.
834 session <- getSession
835 ok <- io (GHC.load session LoadAllTargets)
838 io (revertCAFs) -- always revert CAFs on reload.
839 session <- getSession
840 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
843 afterLoad ok session = do
844 io (revertCAFs) -- always revert CAFs on load.
845 graph <- io (GHC.getModuleGraph session)
846 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
847 setContextAfterLoad session graph'
848 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
849 #if defined(GHCI) && defined(BREAKPOINT)
850 io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
851 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
854 setContextAfterLoad session [] = do
855 prel_mod <- getPrelude
856 io (GHC.setContext session [] [prel_mod])
857 setContextAfterLoad session ms = do
858 -- load a target if one is available, otherwise load the topmost module.
859 targets <- io (GHC.getTargets session)
860 case [ m | Just m <- map (findTarget ms) targets ] of
862 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
863 load_this (last graph')
868 = case filter (`matches` t) ms of
872 summary `matches` Target (TargetModule m) _
873 = GHC.ms_mod_name summary == m
874 summary `matches` Target (TargetFile f _) _
875 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
876 summary `matches` target
879 load_this summary | m <- GHC.ms_mod summary = do
880 b <- io (GHC.moduleIsInterpreted session m)
881 if b then io (GHC.setContext session [m] [])
883 prel_mod <- getPrelude
884 io (GHC.setContext session [] [prel_mod,m])
887 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
888 modulesLoadedMsg ok mods = do
889 dflags <- getDynFlags
890 when (verbosity dflags > 0) $ do
892 | null mods = text "none."
894 punctuate comma (map ppr mods)) <> text "."
897 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
899 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
902 typeOfExpr :: String -> GHCi ()
904 = do cms <- getSession
905 maybe_ty <- io (GHC.exprType cms str)
908 Just ty -> do ty' <- cleanType ty
909 tystr <- showForUser (ppr ty')
910 io (putStrLn (str ++ " :: " ++ tystr))
912 kindOfType :: String -> GHCi ()
914 = do cms <- getSession
915 maybe_ty <- io (GHC.typeKind cms str)
918 Just ty -> do tystr <- showForUser (ppr ty)
919 io (putStrLn (str ++ " :: " ++ tystr))
921 quit :: String -> GHCi Bool
924 shellEscape :: String -> GHCi Bool
925 shellEscape str = io (system str >> return False)
927 -----------------------------------------------------------------------------
928 -- create tags file for currently loaded modules.
930 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
932 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
933 createCTagsFileCmd file = ghciCreateTagsFile CTags file
935 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
936 createETagsFileCmd file = ghciCreateTagsFile ETags file
938 data TagsKind = ETags | CTags
940 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
941 ghciCreateTagsFile kind file = do
942 session <- getSession
943 io $ createTagsFile session kind file
946 -- - remove restriction that all modules must be interpreted
947 -- (problem: we don't know source locations for entities unless
948 -- we compiled the module.
950 -- - extract createTagsFile so it can be used from the command-line
951 -- (probably need to fix first problem before this is useful).
953 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
954 createTagsFile session tagskind tagFile = do
955 graph <- GHC.getModuleGraph session
956 let ms = map GHC.ms_mod graph
958 is_interpreted <- GHC.moduleIsInterpreted session m
959 -- should we just skip these?
960 when (not is_interpreted) $
961 throwDyn (CmdLineError ("module '"
962 ++ GHC.moduleNameString (GHC.moduleName m)
963 ++ "' is not interpreted"))
964 mbModInfo <- GHC.getModuleInfo session m
966 | Just modinfo <- mbModInfo,
967 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
968 | otherwise = GHC.alwaysQualify
971 Just modInfo -> return $! listTags unqual modInfo
974 mtags <- mapM tagModule ms
975 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
977 Left e -> hPutStrLn stderr $ ioeGetErrorString e
980 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
981 listTags unqual modInfo =
982 [ tagInfo unqual name loc
983 | name <- GHC.modInfoExports modInfo
984 , let loc = nameSrcLoc name
988 type TagInfo = (String -- tag name
991 ,Int -- column number
994 -- get tag info, for later translation into Vim or Emacs style
995 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
996 tagInfo unqual name loc
997 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
998 , showSDocForUser unqual $ ftext (srcLocFile loc)
1003 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
1004 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
1005 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
1006 IO.try (writeFile file tags)
1007 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
1008 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
1009 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
1010 tagGroups <- mapM tagFileGroup groups
1011 IO.try (writeFile file $ concat tagGroups)
1013 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
1014 tagFileGroup group@((_,fileName,_,_):_) = do
1015 file <- readFile fileName -- need to get additional info from sources..
1016 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
1017 sortedGroup = sortLe byLine group
1018 tags = unlines $ perFile sortedGroup 1 0 $ lines file
1019 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
1020 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
1021 perFile (tagInfo:tags) (count+1) (pos+length line) lines
1022 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
1023 showETag tagInfo line pos : perFile tags count pos lines
1024 perFile tags count pos lines = []
1026 -- simple ctags format, for Vim et al
1027 showTag :: TagInfo -> String
1028 showTag (tag,file,lineNo,colNo)
1029 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
1031 -- etags format, for Emacs/XEmacs
1032 showETag :: TagInfo -> String -> Int -> String
1033 showETag (tag,file,lineNo,colNo) line charPos
1034 = take colNo line ++ tag
1036 ++ "\x01" ++ show lineNo
1037 ++ "," ++ show charPos
1039 -----------------------------------------------------------------------------
1040 -- Browsing a module's contents
1042 browseCmd :: String -> GHCi ()
1045 ['*':m] | looksLikeModuleName m -> browseModule m False
1046 [m] | looksLikeModuleName m -> browseModule m True
1047 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1049 browseModule m exports_only = do
1051 modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
1052 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1053 when (not is_interpreted && not exports_only) $
1054 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1056 -- Temporarily set the context to the module we're interested in,
1057 -- just so we can get an appropriate PrintUnqualified
1058 (as,bs) <- io (GHC.getContext s)
1059 prel_mod <- getPrelude
1060 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1061 else GHC.setContext s [modl] [])
1062 unqual <- io (GHC.getPrintUnqual s)
1063 io (GHC.setContext s as bs)
1065 mb_mod_info <- io $ GHC.getModuleInfo s modl
1067 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1070 | exports_only = GHC.modInfoExports mod_info
1071 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1073 filtered = filterOutChildren names
1075 things <- io $ mapM (GHC.lookupName s) filtered
1077 dflags <- getDynFlags
1078 let exts = dopt Opt_GlasgowExts dflags
1079 io (putStrLn (showSDocForUser unqual (
1080 vcat (map (pprTyThingInContext exts) (catMaybes things))
1082 -- ToDo: modInfoInstances currently throws an exception for
1083 -- package modules. When it works, we can do this:
1084 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1086 -----------------------------------------------------------------------------
1087 -- Setting the module context
1090 | all sensible mods = fn mods
1091 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1093 (fn, mods) = case str of
1094 '+':stuff -> (addToContext, words stuff)
1095 '-':stuff -> (removeFromContext, words stuff)
1096 stuff -> (newContext, words stuff)
1098 sensible ('*':m) = looksLikeModuleName m
1099 sensible m = looksLikeModuleName m
1101 separate :: Session -> [String] -> [Module] -> [Module]
1102 -> GHCi ([Module],[Module])
1103 separate session [] as bs = return (as,bs)
1104 separate session (('*':str):ms) as bs = do
1105 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1106 b <- io $ GHC.moduleIsInterpreted session m
1107 if b then separate session ms (m:as) bs
1108 else throwDyn (CmdLineError ("module '"
1109 ++ GHC.moduleNameString (GHC.moduleName m)
1110 ++ "' is not interpreted"))
1111 separate session (str:ms) as bs = do
1112 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1113 separate session ms as (m:bs)
1115 newContext :: [String] -> GHCi ()
1116 newContext strs = do
1118 (as,bs) <- separate s strs [] []
1119 prel_mod <- getPrelude
1120 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1121 io $ GHC.setContext s as bs'
1124 addToContext :: [String] -> GHCi ()
1125 addToContext strs = do
1127 (as,bs) <- io $ GHC.getContext s
1129 (new_as,new_bs) <- separate s strs [] []
1131 let as_to_add = new_as \\ (as ++ bs)
1132 bs_to_add = new_bs \\ (as ++ bs)
1134 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1137 removeFromContext :: [String] -> GHCi ()
1138 removeFromContext strs = do
1140 (as,bs) <- io $ GHC.getContext s
1142 (as_to_remove,bs_to_remove) <- separate s strs [] []
1144 let as' = as \\ (as_to_remove ++ bs_to_remove)
1145 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1147 io $ GHC.setContext s as' bs'
1149 ----------------------------------------------------------------------------
1152 -- set options in the interpreter. Syntax is exactly the same as the
1153 -- ghc command line, except that certain options aren't available (-C,
1156 -- This is pretty fragile: most options won't work as expected. ToDo:
1157 -- figure out which ones & disallow them.
1159 setCmd :: String -> GHCi ()
1161 = do st <- getGHCiState
1162 let opts = options st
1163 io $ putStrLn (showSDoc (
1164 text "options currently set: " <>
1167 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1171 ("args":args) -> setArgs args
1172 ("prog":prog) -> setProg prog
1173 ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
1174 wds -> setOptions wds
1178 setGHCiState st{ args = args }
1182 setGHCiState st{ progname = prog }
1184 io (hPutStrLn stderr "syntax: :set prog <progname>")
1186 setPrompt value = do
1189 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1190 else setGHCiState st{ prompt = remQuotes value }
1192 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1196 do -- first, deal with the GHCi opts (+s, +t, etc.)
1197 let (plus_opts, minus_opts) = partition isPlus wds
1198 mapM_ setOpt plus_opts
1200 -- then, dynamic flags
1201 dflags <- getDynFlags
1202 let pkg_flags = packageFlags dflags
1203 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1205 if (not (null leftovers))
1206 then throwDyn (CmdLineError ("unrecognised flags: " ++
1210 new_pkgs <- setDynFlags dflags'
1212 -- if the package flags changed, we should reset the context
1213 -- and link the new packages.
1214 dflags <- getDynFlags
1215 when (packageFlags dflags /= pkg_flags) $ do
1216 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1217 session <- getSession
1218 io (GHC.setTargets session [])
1219 io (GHC.load session LoadAllTargets)
1220 io (linkPackages dflags new_pkgs)
1221 setContextAfterLoad session []
1225 unsetOptions :: String -> GHCi ()
1227 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1228 let opts = words str
1229 (minus_opts, rest1) = partition isMinus opts
1230 (plus_opts, rest2) = partition isPlus rest1
1232 if (not (null rest2))
1233 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1236 mapM_ unsetOpt plus_opts
1238 -- can't do GHC flags for now
1239 if (not (null minus_opts))
1240 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1243 isMinus ('-':s) = True
1246 isPlus ('+':s) = True
1250 = case strToGHCiOpt str of
1251 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1252 Just o -> setOption o
1255 = case strToGHCiOpt str of
1256 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1257 Just o -> unsetOption o
1259 strToGHCiOpt :: String -> (Maybe GHCiOption)
1260 strToGHCiOpt "s" = Just ShowTiming
1261 strToGHCiOpt "t" = Just ShowType
1262 strToGHCiOpt "r" = Just RevertCAFs
1263 strToGHCiOpt _ = Nothing
1265 optToStr :: GHCiOption -> String
1266 optToStr ShowTiming = "s"
1267 optToStr ShowType = "t"
1268 optToStr RevertCAFs = "r"
1270 -- ---------------------------------------------------------------------------
1275 ["modules" ] -> showModules
1276 ["bindings"] -> showBindings
1277 ["linker"] -> io showLinkerState
1278 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1281 session <- getSession
1282 let show_one ms = do m <- io (GHC.showModule session ms)
1284 graph <- io (GHC.getModuleGraph session)
1285 mapM_ show_one graph
1289 unqual <- io (GHC.getPrintUnqual s)
1290 bindings <- io (GHC.getBindings s)
1291 mapM_ showTyThing bindings
1294 showTyThing (AnId id) = do
1295 ty' <- cleanType (GHC.idType id)
1296 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1298 showTyThing _ = return ()
1300 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1301 cleanType :: Type -> GHCi Type
1303 dflags <- getDynFlags
1304 if dopt Opt_GlasgowExts dflags
1306 else return $! GHC.dropForAlls ty
1308 -- -----------------------------------------------------------------------------
1311 completeNone :: String -> IO [String]
1312 completeNone w = return []
1315 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1316 completeWord w start end = do
1317 line <- Readline.getLineBuffer
1319 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1321 | Just c <- is_cmd line -> do
1322 maybe_cmd <- lookupCommand c
1323 let (n,w') = selectWord (words' 0 line)
1325 Nothing -> return Nothing
1326 Just (_,_,False,complete) -> wrapCompleter complete w
1327 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1328 return (map (drop n) rets)
1329 in wrapCompleter complete' w'
1331 --printf "complete %s, start = %d, end = %d\n" w start end
1332 wrapCompleter completeIdentifier w
1333 where words' _ [] = []
1334 words' n str = let (w,r) = break isSpace str
1335 (s,r') = span isSpace r
1336 in (n,w):words' (n+length w+length s) r'
1337 -- In a Haskell expression we want to parse 'a-b' as three words
1338 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1339 -- only be a single word.
1340 selectWord [] = (0,w)
1341 selectWord ((offset,x):xs)
1342 | offset+length x >= start = (start-offset,take (end-offset) x)
1343 | otherwise = selectWord xs
1346 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1347 | otherwise = Nothing
1350 cmds <- readIORef commands
1351 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1353 completeMacro w = do
1354 cmds <- readIORef commands
1355 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1356 return (filter (w `isPrefixOf`) cmds')
1358 completeIdentifier w = do
1360 rdrs <- GHC.getRdrNamesInScope s
1361 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1363 completeModule w = do
1365 dflags <- GHC.getSessionDynFlags s
1366 let pkg_mods = allExposedModules dflags
1367 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1369 completeHomeModule w = do
1371 g <- GHC.getModuleGraph s
1372 let home_mods = map GHC.ms_mod_name g
1373 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1375 completeSetOptions w = do
1376 return (filter (w `isPrefixOf`) options)
1377 where options = "args":"prog":allFlags
1379 completeFilename = Readline.filenameCompletionFunction
1381 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1383 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1384 unionComplete f1 f2 w = do
1389 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1390 wrapCompleter fun w = do
1393 [] -> return Nothing
1394 [x] -> return (Just (x,[]))
1395 xs -> case getCommonPrefix xs of
1396 "" -> return (Just ("",xs))
1397 pref -> return (Just (pref,xs))
1399 getCommonPrefix :: [String] -> String
1400 getCommonPrefix [] = ""
1401 getCommonPrefix (s:ss) = foldl common s ss
1402 where common s "" = s
1404 common (c:cs) (d:ds)
1405 | c == d = c : common cs ds
1408 allExposedModules :: DynFlags -> [ModuleName]
1409 allExposedModules dflags
1410 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1412 pkg_db = pkgIdMap (pkgState dflags)
1414 completeCmd = completeNone
1415 completeMacro = completeNone
1416 completeIdentifier = completeNone
1417 completeModule = completeNone
1418 completeHomeModule = completeNone
1419 completeSetOptions = completeNone
1420 completeFilename = completeNone
1421 completeHomeModuleOrFile=completeNone
1424 -----------------------------------------------------------------------------
1427 data GHCiState = GHCiState
1432 session :: GHC.Session,
1433 options :: [GHCiOption],
1438 = ShowTiming -- show time/allocs after evaluation
1439 | ShowType -- show the type of expressions
1440 | RevertCAFs -- revert CAFs after every evaluation
1443 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1445 startGHCi :: GHCi a -> GHCiState -> IO a
1446 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1448 instance Monad GHCi where
1449 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1450 return a = GHCi $ \s -> return a
1452 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1453 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1454 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1456 getGHCiState = GHCi $ \r -> readIORef r
1457 setGHCiState s = GHCi $ \r -> writeIORef r s
1459 -- for convenience...
1460 getSession = getGHCiState >>= return . session
1461 getPrelude = getGHCiState >>= return . prelude
1463 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
1464 no_saved_sess = error "no saved_ses"
1465 saveSession = getSession >>= io . writeIORef saved_sess
1466 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
1467 restoreSession = readIORef saved_sess
1471 io (GHC.getSessionDynFlags s)
1472 setDynFlags dflags = do
1474 io (GHC.setSessionDynFlags s dflags)
1476 isOptionSet :: GHCiOption -> GHCi Bool
1478 = do st <- getGHCiState
1479 return (opt `elem` options st)
1481 setOption :: GHCiOption -> GHCi ()
1483 = do st <- getGHCiState
1484 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1486 unsetOption :: GHCiOption -> GHCi ()
1488 = do st <- getGHCiState
1489 setGHCiState (st{ options = filter (/= opt) (options st) })
1491 io :: IO a -> GHCi a
1492 io m = GHCi { unGHCi = \s -> m >>= return }
1494 -----------------------------------------------------------------------------
1495 -- recursive exception handlers
1497 -- Don't forget to unblock async exceptions in the handler, or if we're
1498 -- in an exception loop (eg. let a = error a in a) the ^C exception
1499 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1501 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1502 ghciHandle h (GHCi m) = GHCi $ \s ->
1503 Exception.catch (m s)
1504 (\e -> unGHCi (ghciUnblock (h e)) s)
1506 ghciUnblock :: GHCi a -> GHCi a
1507 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1509 -----------------------------------------------------------------------------
1510 -- timing & statistics
1512 timeIt :: GHCi a -> GHCi a
1514 = do b <- isOptionSet ShowTiming
1517 else do allocs1 <- io $ getAllocations
1518 time1 <- io $ getCPUTime
1520 allocs2 <- io $ getAllocations
1521 time2 <- io $ getCPUTime
1522 io $ printTimes (fromIntegral (allocs2 - allocs1))
1526 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1527 -- defined in ghc/rts/Stats.c
1529 printTimes :: Integer -> Integer -> IO ()
1530 printTimes allocs psecs
1531 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1532 secs_str = showFFloat (Just 2) secs
1533 putStrLn (showSDoc (
1534 parens (text (secs_str "") <+> text "secs" <> comma <+>
1535 text (show allocs) <+> text "bytes")))
1537 -----------------------------------------------------------------------------
1544 -- Have to turn off buffering again, because we just
1545 -- reverted stdout, stderr & stdin to their defaults.
1547 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1548 -- Make it "safe", just in case
1550 -- ----------------------------------------------------------------------------
1553 expandPath :: String -> GHCi String
1555 case dropWhile isSpace path of
1557 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1558 return (tilde ++ '/':d)
1562 -- ----------------------------------------------------------------------------
1563 -- Windows console setup
1565 setUpConsole :: IO ()
1567 #ifdef mingw32_HOST_OS
1568 -- On Windows we need to set a known code page, otherwise the characters
1569 -- we read from the console will be be in some strange encoding, and
1570 -- similarly for characters we write to the console.
1572 -- At the moment, GHCi pretends all input is Latin-1. In the
1573 -- future we should support UTF-8, but for now we set the code pages
1576 -- It seems you have to set the font in the console window to
1577 -- a Unicode font in order for output to work properly,
1578 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1579 -- (see MSDN for SetConsoleOutputCP()).
1581 setConsoleCP 28591 -- ISO Latin-1
1582 setConsoleOutputCP 28591 -- ISO Latin-1