1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
16 #if defined(GHCI) && defined(BREAKPOINT)
17 import GHC.Exts ( Int(..), Ptr(..), int2Addr# )
18 import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
19 import System.IO.Unsafe ( unsafePerformIO )
20 import Var ( Id, globaliseId, idName, idType )
21 import HscTypes ( Session(..), InteractiveContext(..), HscEnv(..)
22 , extendTypeEnvWithIds )
23 import RdrName ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv )
24 import NameEnv ( delListFromNameEnv )
25 import TcType ( tidyTopType )
26 import qualified Id ( setIdType )
27 import IdInfo ( GlobalIdDetails(..) )
28 import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker )
29 import PrelNames ( breakpointJumpName, breakpointCondJumpName )
34 import GHC ( Session, dopt, DynFlag(..), Target(..),
35 TargetId(..), DynFlags(..),
36 pprModule, Type, Module, ModuleName, SuccessFlag(..),
37 TyThing(..), Name, LoadHowMuch(..), Phase,
38 GhcException(..), showGhcException,
39 CheckedModule(..), SrcLoc )
40 import DynFlags ( allFlags )
41 import Packages ( PackageState(..) )
42 import PackageConfig ( InstalledPackageInfo(..) )
43 import UniqFM ( eltsUFM )
47 -- for createtags (should these come via GHC?)
48 import Name ( nameSrcLoc, nameModule, nameOccName )
49 import OccName ( pprOccName )
50 import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
52 -- Other random utilities
53 import Digraph ( flattenSCCs )
54 import BasicTypes ( failed, successIf )
55 import Panic ( panic, installSignalHandlers )
57 import StaticFlags ( opt_IgnoreDotGhci )
58 import Linker ( showLinkerState )
59 import Util ( removeSpaces, handle, global, toArgs,
60 looksLikeModuleName, prefixMatch, sortLe )
62 #ifndef mingw32_HOST_OS
64 #if __GLASGOW_HASKELL__ > 504
68 import GHC.ConsoleHandler ( flushConsole )
69 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
73 import Control.Concurrent ( yield ) -- Used in readline loop
74 import System.Console.Readline as Readline
79 import Control.Exception as Exception
81 -- import Control.Concurrent
85 import Data.Int ( Int64 )
86 import Data.Maybe ( isJust, fromMaybe, catMaybes )
89 import System.Environment
90 import System.Exit ( exitWith, ExitCode(..) )
91 import System.Directory
93 import System.IO.Error as IO
95 import Control.Monad as Monad
96 import Foreign.StablePtr ( newStablePtr )
98 import GHC.Exts ( unsafeCoerce# )
99 import GHC.IOBase ( IOErrorType(InvalidArgument) )
101 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
103 import System.Posix.Internals ( setNonBlockingFD )
105 -----------------------------------------------------------------------------
109 " / _ \\ /\\ /\\/ __(_)\n"++
110 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
111 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
112 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
114 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
115 cmdName (n,_,_,_) = n
117 GLOBAL_VAR(commands, builtin_commands, [Command])
119 builtin_commands :: [Command]
121 ("add", keepGoingPaths addModule, False, completeFilename),
122 ("browse", keepGoing browseCmd, False, completeModule),
123 ("cd", keepGoing changeDirectory, False, completeFilename),
124 ("def", keepGoing defineMacro, False, completeIdentifier),
125 ("help", keepGoing help, False, completeNone),
126 ("?", keepGoing help, False, completeNone),
127 ("info", keepGoing info, False, completeIdentifier),
128 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
129 ("module", keepGoing setContext, False, completeModule),
130 ("main", keepGoing runMain, False, completeIdentifier),
131 ("reload", keepGoing reloadModule, False, completeNone),
132 ("check", keepGoing checkModule, False, completeHomeModule),
133 ("set", keepGoing setCmd, True, completeSetOptions),
134 ("show", keepGoing showCmd, False, completeNone),
135 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
136 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
137 ("type", keepGoing typeOfExpr, False, completeIdentifier),
138 ("kind", keepGoing kindOfType, False, completeIdentifier),
139 ("unset", keepGoing unsetOptions, True, completeSetOptions),
140 ("undef", keepGoing undefineMacro, False, completeMacro),
141 ("quit", quit, False, completeNone)
144 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
145 keepGoing a str = a str >> return False
147 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
148 keepGoingPaths a str = a (toArgs str) >> return False
150 shortHelpText = "use :? for help.\n"
152 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
154 " Commands available from the prompt:\n" ++
156 " <stmt> evaluate/run <stmt>\n" ++
157 " :add <filename> ... add module(s) to the current target set\n" ++
158 " :browse [*]<module> display the names defined by <module>\n" ++
159 " :cd <dir> change directory to <dir>\n" ++
160 " :def <cmd> <expr> define a command :<cmd>\n" ++
161 " :help, :? display this list of commands\n" ++
162 " :info [<name> ...] display information about the given names\n" ++
163 " :load <filename> ... load module(s) and their dependents\n" ++
164 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
165 " :main [<arguments> ...] run the main function with the given arguments\n" ++
166 " :reload reload the current module set\n" ++
168 " :set <option> ... set options\n" ++
169 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
170 " :set prog <progname> set the value returned by System.getProgName\n" ++
171 " :set prompt <prompt> set the prompt used in GHCi\n" ++
173 " :show modules show the currently loaded modules\n" ++
174 " :show bindings show the current bindings made at the prompt\n" ++
176 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
177 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
178 " :type <expr> show the type of <expr>\n" ++
179 " :kind <type> show the kind of <type>\n" ++
180 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
181 " :unset <option> ... unset options\n" ++
182 " :quit exit GHCi\n" ++
183 " :!<command> run the shell command <command>\n" ++
185 " Options for ':set' and ':unset':\n" ++
187 " +r revert top-level expressions after each evaluation\n" ++
188 " +s print timing/memory stats after each evaluation\n" ++
189 " +t print type after evaluation\n" ++
190 " -<flags> most GHC command line flags can also be set here\n" ++
191 " (eg. -v2, -fglasgow-exts, etc.)\n"
194 #if defined(GHCI) && defined(BREAKPOINT)
195 globaliseAndTidy :: Id -> Id
197 -- Give the Id a Global Name, and tidy its type
198 = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
200 tidy_type = tidyTopType (idType id)
203 printScopeMsg :: Session -> String -> [Id] -> IO ()
204 printScopeMsg session location ids
205 = GHC.getPrintUnqual session >>= \unqual ->
206 printForUser stdout unqual $
207 text "Local bindings in scope:" $$
208 nest 2 (pprWithCommas showId ids)
209 where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
211 jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
212 jumpCondFunction session ptr hValues location True b = b
213 jumpCondFunction session ptr hValues location False b
214 = jumpFunction session ptr hValues location b
216 jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
217 jumpFunction session@(Session ref) (I# idsPtr) hValues location b
219 do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
220 let names = map idName ids
221 ASSERT (length names == length hValues) return ()
222 printScopeMsg session location ids
223 hsc_env <- readIORef ref
225 let ictxt = hsc_IC hsc_env
226 global_ids = map globaliseAndTidy ids
227 rn_env = ic_rn_local_env ictxt
228 type_env = ic_type_env ictxt
229 bound_names = map idName global_ids
230 new_rn_env = extendLocalRdrEnv rn_env bound_names
231 -- Remove any shadowed bindings from the type_env;
232 -- they are inaccessible but might, I suppose, cause
233 -- a space leak if we leave them there
234 shadowed = [ n | name <- bound_names,
235 let rdr_name = mkRdrUnqual (nameOccName name),
236 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
237 filtered_type_env = delListFromNameEnv type_env shadowed
238 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
239 new_ic = ictxt { ic_rn_local_env = new_rn_env,
240 ic_type_env = new_type_env }
241 writeIORef ref (hsc_env { hsc_IC = new_ic })
242 is_tty <- hIsTerminalDevice stdin
243 prel_mod <- GHC.findModule session prel_name Nothing
244 withExtendedLinkEnv (zip names hValues) $
245 startGHCi (interactiveLoop is_tty True)
246 GHCiState{ progname = "<interactive>",
248 prompt = location++"> ",
252 writeIORef ref hsc_env
253 putStrLn $ "Returning to normal execution..."
257 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
258 interactiveUI session srcs maybe_expr = do
259 #if defined(GHCI) && defined(BREAKPOINT)
260 initDynLinker =<< GHC.getSessionDynFlags session
261 extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
262 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
264 -- HACK! If we happen to get into an infinite loop (eg the user
265 -- types 'let x=x in x' at the prompt), then the thread will block
266 -- on a blackhole, and become unreachable during GC. The GC will
267 -- detect that it is unreachable and send it the NonTermination
268 -- exception. However, since the thread is unreachable, everything
269 -- it refers to might be finalized, including the standard Handles.
270 -- This sounds like a bug, but we don't have a good solution right
277 hSetBuffering stdout NoBuffering
279 -- Initialise buffering for the *interpreted* I/O system
280 initInterpBuffering session
282 -- We don't want the cmd line to buffer any input that might be
283 -- intended for the program, so unbuffer stdin.
284 hSetBuffering stdin NoBuffering
286 -- initial context is just the Prelude
287 prel_mod <- GHC.findModule session prel_name Nothing
288 GHC.setContext session [] [prel_mod]
292 Readline.setAttemptedCompletionFunction (Just completeWord)
293 --Readline.parseAndBind "set show-all-if-ambiguous 1"
295 let symbols = "!#$%&*+/<=>?@\\^|-~"
296 specials = "(),;[]`{}"
298 word_break_chars = spaces ++ specials ++ symbols
300 Readline.setBasicWordBreakCharacters word_break_chars
301 Readline.setCompleterWordBreakCharacters word_break_chars
304 startGHCi (runGHCi srcs maybe_expr)
305 GHCiState{ progname = "<interactive>",
313 Readline.resetTerminal Nothing
318 prel_name = GHC.mkModuleName "Prelude"
320 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
321 runGHCi paths maybe_expr = do
322 let read_dot_files = not opt_IgnoreDotGhci
324 when (read_dot_files) $ do
327 exists <- io (doesFileExist file)
329 dir_ok <- io (checkPerms ".")
330 file_ok <- io (checkPerms file)
331 when (dir_ok && file_ok) $ do
332 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
335 Right hdl -> fileLoop hdl False
337 when (read_dot_files) $ do
338 -- Read in $HOME/.ghci
339 either_dir <- io (IO.try (getEnv "HOME"))
343 cwd <- io (getCurrentDirectory)
344 when (dir /= cwd) $ do
345 let file = dir ++ "/.ghci"
346 ok <- io (checkPerms file)
348 either_hdl <- io (IO.try (openFile file ReadMode))
351 Right hdl -> fileLoop hdl False
353 -- Perform a :load for files given on the GHCi command line
354 -- When in -e mode, if the load fails then we want to stop
355 -- immediately rather than going on to evaluate the expression.
356 when (not (null paths)) $ do
357 ok <- ghciHandle (\e -> do showException e; return Failed) $
359 when (isJust maybe_expr && failed ok) $
360 io (exitWith (ExitFailure 1))
362 -- if verbosity is greater than 0, or we are connected to a
363 -- terminal, display the prompt in the interactive loop.
364 is_tty <- io (hIsTerminalDevice stdin)
365 dflags <- getDynFlags
366 let show_prompt = verbosity dflags > 0 || is_tty
371 #if defined(mingw32_HOST_OS)
372 -- The win32 Console API mutates the first character of
373 -- type-ahead when reading from it in a non-buffered manner. Work
374 -- around this by flushing the input buffer of type-ahead characters,
375 -- but only if stdin is available.
376 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
378 Left err | isDoesNotExistError err -> return ()
379 | otherwise -> io (ioError err)
380 Right () -> return ()
382 -- initialise the console if necessary
385 -- enter the interactive loop
386 interactiveLoop is_tty show_prompt
388 -- just evaluate the expression we were given
393 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
396 interactiveLoop is_tty show_prompt =
397 -- Ignore ^C exceptions caught here
398 ghciHandleDyn (\e -> case e of
400 #if defined(mingw32_HOST_OS)
403 interactiveLoop is_tty show_prompt
404 _other -> return ()) $
406 ghciUnblock $ do -- unblock necessary if we recursed from the
407 -- exception handler above.
409 -- read commands from stdin
413 else fileLoop stdin show_prompt
415 fileLoop stdin show_prompt
419 -- NOTE: We only read .ghci files if they are owned by the current user,
420 -- and aren't world writable. Otherwise, we could be accidentally
421 -- running code planted by a malicious third party.
423 -- Furthermore, We only read ./.ghci if . is owned by the current user
424 -- and isn't writable by anyone else. I think this is sufficient: we
425 -- don't need to check .. and ../.. etc. because "." always refers to
426 -- the same directory while a process is running.
428 checkPerms :: String -> IO Bool
430 #ifdef mingw32_HOST_OS
433 Util.handle (\_ -> return False) $ do
434 st <- getFileStatus name
436 if fileOwner st /= me then do
437 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
440 let mode = fileMode st
441 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
442 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
444 putStrLn $ "*** WARNING: " ++ name ++
445 " is writable by someone else, IGNORING!"
450 fileLoop :: Handle -> Bool -> GHCi ()
451 fileLoop hdl show_prompt = do
452 session <- getSession
453 (mod,imports) <- io (GHC.getContext session)
455 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
456 l <- io (IO.try (hGetLine hdl))
458 Left e | isEOFError e -> return ()
459 | InvalidArgument <- etype -> return ()
460 | otherwise -> io (ioError e)
461 where etype = ioeGetErrorType e
462 -- treat InvalidArgument in the same way as EOF:
463 -- this can happen if the user closed stdin, or
464 -- perhaps did getContents which closes stdin at
467 case removeSpaces l of
468 "" -> fileLoop hdl show_prompt
469 l -> do quit <- runCommand l
470 if quit then return () else fileLoop hdl show_prompt
472 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
473 stringLoop [] = return False
474 stringLoop (s:ss) = do
475 case removeSpaces s of
477 l -> do quit <- runCommand l
478 if quit then return True else stringLoop ss
480 mkPrompt toplevs exports prompt
481 = showSDoc $ f prompt
483 f ('%':'s':xs) = perc_s <> f xs
484 f ('%':'%':xs) = char '%' <> f xs
485 f (x:xs) = char x <> f xs
488 perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+>
489 hsep (map pprModule exports)
493 readlineLoop :: GHCi ()
495 session <- getSession
496 (mod,imports) <- io (GHC.getContext session)
498 saveSession -- for use by completion
500 l <- io (readline (mkPrompt mod imports (prompt st))
501 `finally` setNonBlockingFD 0)
502 -- readline sometimes puts stdin into blocking mode,
503 -- so we need to put it back for the IO library
508 case removeSpaces l of
513 if quit then return () else readlineLoop
516 runCommand :: String -> GHCi Bool
517 runCommand c = ghciHandle handler (doCommand c)
519 doCommand (':' : command) = specialCommand command
521 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
524 -- This version is for the GHC command-line option -e. The only difference
525 -- from runCommand is that it catches the ExitException exception and
526 -- exits, rather than printing out the exception.
527 runCommandEval c = ghciHandle handleEval (doCommand c)
529 handleEval (ExitException code) = io (exitWith code)
530 handleEval e = do handler e
531 io (exitWith (ExitFailure 1))
533 doCommand (':' : command) = specialCommand command
535 = do nms <- runStmt stmt
537 Nothing -> io (exitWith (ExitFailure 1))
538 -- failure to run the command causes exit(1) for ghc -e.
539 _ -> finishEvalExpr nms
541 -- This is the exception handler for exceptions generated by the
542 -- user's code; it normally just prints out the exception. The
543 -- handler must be recursive, in case showing the exception causes
544 -- more exceptions to be raised.
546 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
547 -- raising another exception. We therefore don't put the recursive
548 -- handler arond the flushing operation, so if stderr is closed
549 -- GHCi will just die gracefully rather than going into an infinite loop.
550 handler :: Exception -> GHCi Bool
551 handler exception = do
553 io installSignalHandlers
554 ghciHandle handler (showException exception >> return False)
556 showException (DynException dyn) =
557 case fromDynamic dyn of
558 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
559 Just Interrupted -> io (putStrLn "Interrupted.")
560 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
561 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
562 Just other_ghc_ex -> io (print other_ghc_ex)
564 showException other_exception
565 = io (putStrLn ("*** Exception: " ++ show other_exception))
567 runStmt :: String -> GHCi (Maybe [Name])
569 | null (filter (not.isSpace) stmt) = return (Just [])
571 = do st <- getGHCiState
572 session <- getSession
573 result <- io $ withProgName (progname st) $ withArgs (args st) $
574 GHC.runStmt session stmt
576 GHC.RunFailed -> return Nothing
577 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
578 GHC.RunOk names -> return (Just names)
580 -- possibly print the type and revert CAFs after evaluating an expression
581 finishEvalExpr mb_names
582 = do b <- isOptionSet ShowType
583 session <- getSession
586 Just names -> when b (mapM_ (showTypeOfName session) names)
589 io installSignalHandlers
590 b <- isOptionSet RevertCAFs
591 io (when b revertCAFs)
594 showTypeOfName :: Session -> Name -> GHCi ()
595 showTypeOfName session n
596 = do maybe_tything <- io (GHC.lookupName session n)
597 case maybe_tything of
599 Just thing -> showTyThing thing
601 showForUser :: SDoc -> GHCi String
603 session <- getSession
604 unqual <- io (GHC.getPrintUnqual session)
605 return $! showSDocForUser unqual doc
607 specialCommand :: String -> GHCi Bool
608 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
609 specialCommand str = do
610 let (cmd,rest) = break isSpace str
611 maybe_cmd <- io (lookupCommand cmd)
613 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
614 ++ shortHelpText) >> return False)
615 Just (_,f,_,_) -> f (dropWhile isSpace rest)
617 lookupCommand :: String -> IO (Maybe Command)
618 lookupCommand str = do
619 cmds <- readIORef commands
620 -- look for exact match first, then the first prefix match
621 case [ c | c <- cmds, str == cmdName c ] of
622 c:_ -> return (Just c)
623 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
625 c:_ -> return (Just c)
627 -----------------------------------------------------------------------------
628 -- To flush buffers for the *interpreted* computation we need
629 -- to refer to *its* stdout/stderr handles
631 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
632 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
634 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
635 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
636 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
638 initInterpBuffering :: Session -> IO ()
639 initInterpBuffering session
640 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
643 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
644 other -> panic "interactiveUI:setBuffering"
646 maybe_hval <- GHC.compileExpr session flush_cmd
648 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
649 _ -> panic "interactiveUI:flush"
651 turnOffBuffering -- Turn it off right now
656 flushInterpBuffers :: GHCi ()
658 = io $ do Monad.join (readIORef flush_interp)
661 turnOffBuffering :: IO ()
663 = do Monad.join (readIORef turn_off_buffering)
666 -----------------------------------------------------------------------------
669 help :: String -> GHCi ()
670 help _ = io (putStr helpText)
672 info :: String -> GHCi ()
673 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
674 info s = do { let names = words s
675 ; session <- getSession
676 ; dflags <- getDynFlags
677 ; let exts = dopt Opt_GlasgowExts dflags
678 ; mapM_ (infoThing exts session) names }
680 infoThing exts session str = io $ do
681 names <- GHC.parseName session str
682 let filtered = filterOutChildren names
683 mb_stuffs <- mapM (GHC.getInfo session) filtered
684 unqual <- GHC.getPrintUnqual session
685 putStrLn (showSDocForUser unqual $
686 vcat (intersperse (text "") $
687 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
689 -- Filter out names whose parent is also there Good
690 -- example is '[]', which is both a type and data
691 -- constructor in the same type
692 filterOutChildren :: [Name] -> [Name]
693 filterOutChildren names = filter (not . parent_is_there) names
694 where parent_is_there n
695 | Just p <- GHC.nameParent_maybe n = p `elem` names
698 pprInfo exts (thing, fixity, insts)
699 = pprTyThingInContextLoc exts thing
700 $$ show_fixity fixity
701 $$ vcat (map GHC.pprInstance insts)
704 | fix == GHC.defaultFixity = empty
705 | otherwise = ppr fix <+> ppr (GHC.getName thing)
707 -----------------------------------------------------------------------------
710 runMain :: String -> GHCi ()
712 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
713 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
716 addModule :: [FilePath] -> GHCi ()
718 io (revertCAFs) -- always revert CAFs on load/add.
719 files <- mapM expandPath files
720 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
721 session <- getSession
722 io (mapM_ (GHC.addTarget session) targets)
723 ok <- io (GHC.load session LoadAllTargets)
726 changeDirectory :: String -> GHCi ()
727 changeDirectory dir = do
728 session <- getSession
729 graph <- io (GHC.getModuleGraph session)
730 when (not (null graph)) $
731 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
732 io (GHC.setTargets session [])
733 io (GHC.load session LoadAllTargets)
734 setContextAfterLoad session []
735 io (GHC.workingDirectoryChanged session)
736 dir <- expandPath dir
737 io (setCurrentDirectory dir)
739 defineMacro :: String -> GHCi ()
741 let (macro_name, definition) = break isSpace s
742 cmds <- io (readIORef commands)
744 then throwDyn (CmdLineError "invalid macro name")
746 if (macro_name `elem` map cmdName cmds)
747 then throwDyn (CmdLineError
748 ("command '" ++ macro_name ++ "' is already defined"))
751 -- give the expression a type signature, so we can be sure we're getting
752 -- something of the right type.
753 let new_expr = '(' : definition ++ ") :: String -> IO String"
755 -- compile the expression
757 maybe_hv <- io (GHC.compileExpr cms new_expr)
760 Just hv -> io (writeIORef commands --
761 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
763 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
765 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
766 stringLoop (lines str)
768 undefineMacro :: String -> GHCi ()
769 undefineMacro macro_name = do
770 cmds <- io (readIORef commands)
771 if (macro_name `elem` map cmdName builtin_commands)
772 then throwDyn (CmdLineError
773 ("command '" ++ macro_name ++ "' cannot be undefined"))
775 if (macro_name `notElem` map cmdName cmds)
776 then throwDyn (CmdLineError
777 ("command '" ++ macro_name ++ "' not defined"))
779 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
782 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
783 loadModule fs = timeIt (loadModule' fs)
785 loadModule_ :: [FilePath] -> GHCi ()
786 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
788 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
789 loadModule' files = do
790 session <- getSession
793 io (GHC.setTargets session [])
794 io (GHC.load session LoadAllTargets)
797 let (filenames, phases) = unzip files
798 exp_filenames <- mapM expandPath filenames
799 let files' = zip exp_filenames phases
800 targets <- io (mapM (uncurry GHC.guessTarget) files')
802 -- NOTE: we used to do the dependency anal first, so that if it
803 -- fails we didn't throw away the current set of modules. This would
804 -- require some re-working of the GHC interface, so we'll leave it
805 -- as a ToDo for now.
807 io (GHC.setTargets session targets)
808 ok <- io (GHC.load session LoadAllTargets)
812 checkModule :: String -> GHCi ()
814 let modl = GHC.mkModuleName m
815 session <- getSession
816 result <- io (GHC.checkModule session modl)
818 Nothing -> io $ putStrLn "Nothing"
819 Just r -> io $ putStrLn (showSDoc (
820 case checkedModuleInfo r of
821 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
823 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
825 (text "global names: " <+> ppr global) $$
826 (text "local names: " <+> ppr local)
828 afterLoad (successIf (isJust result)) session
830 reloadModule :: String -> GHCi ()
832 io (revertCAFs) -- always revert CAFs on reload.
833 session <- getSession
834 ok <- io (GHC.load session LoadAllTargets)
837 io (revertCAFs) -- always revert CAFs on reload.
838 session <- getSession
839 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
842 afterLoad ok session = do
843 io (revertCAFs) -- always revert CAFs on load.
844 graph <- io (GHC.getModuleGraph session)
845 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
846 setContextAfterLoad session graph'
847 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
848 #if defined(GHCI) && defined(BREAKPOINT)
849 io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
850 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
853 setContextAfterLoad session [] = do
854 prel_mod <- getPrelude
855 io (GHC.setContext session [] [prel_mod])
856 setContextAfterLoad session ms = do
857 -- load a target if one is available, otherwise load the topmost module.
858 targets <- io (GHC.getTargets session)
859 case [ m | Just m <- map (findTarget ms) targets ] of
861 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
862 load_this (last graph')
867 = case filter (`matches` t) ms of
871 summary `matches` Target (TargetModule m) _
872 = GHC.ms_mod_name summary == m
873 summary `matches` Target (TargetFile f _) _
874 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
875 summary `matches` target
878 load_this summary | m <- GHC.ms_mod summary = do
879 b <- io (GHC.moduleIsInterpreted session m)
880 if b then io (GHC.setContext session [m] [])
882 prel_mod <- getPrelude
883 io (GHC.setContext session [] [prel_mod,m])
886 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
887 modulesLoadedMsg ok mods = do
888 dflags <- getDynFlags
889 when (verbosity dflags > 0) $ do
891 | null mods = text "none."
893 punctuate comma (map ppr mods)) <> text "."
896 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
898 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
901 typeOfExpr :: String -> GHCi ()
903 = do cms <- getSession
904 maybe_ty <- io (GHC.exprType cms str)
907 Just ty -> do ty' <- cleanType ty
908 tystr <- showForUser (ppr ty')
909 io (putStrLn (str ++ " :: " ++ tystr))
911 kindOfType :: String -> GHCi ()
913 = do cms <- getSession
914 maybe_ty <- io (GHC.typeKind cms str)
917 Just ty -> do tystr <- showForUser (ppr ty)
918 io (putStrLn (str ++ " :: " ++ tystr))
920 quit :: String -> GHCi Bool
923 shellEscape :: String -> GHCi Bool
924 shellEscape str = io (system str >> return False)
926 -----------------------------------------------------------------------------
927 -- create tags file for currently loaded modules.
929 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
931 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
932 createCTagsFileCmd file = ghciCreateTagsFile CTags file
934 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
935 createETagsFileCmd file = ghciCreateTagsFile ETags file
937 data TagsKind = ETags | CTags
939 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
940 ghciCreateTagsFile kind file = do
941 session <- getSession
942 io $ createTagsFile session kind file
945 -- - remove restriction that all modules must be interpreted
946 -- (problem: we don't know source locations for entities unless
947 -- we compiled the module.
949 -- - extract createTagsFile so it can be used from the command-line
950 -- (probably need to fix first problem before this is useful).
952 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
953 createTagsFile session tagskind tagFile = do
954 graph <- GHC.getModuleGraph session
955 let ms = map GHC.ms_mod graph
957 is_interpreted <- GHC.moduleIsInterpreted session m
958 -- should we just skip these?
959 when (not is_interpreted) $
960 throwDyn (CmdLineError ("module '"
961 ++ GHC.moduleNameString (GHC.moduleName m)
962 ++ "' is not interpreted"))
963 mbModInfo <- GHC.getModuleInfo session m
965 | Just modinfo <- mbModInfo,
966 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
967 | otherwise = GHC.alwaysQualify
970 Just modInfo -> return $! listTags unqual modInfo
973 mtags <- mapM tagModule ms
974 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
976 Left e -> hPutStrLn stderr $ ioeGetErrorString e
979 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
980 listTags unqual modInfo =
981 [ tagInfo unqual name loc
982 | name <- GHC.modInfoExports modInfo
983 , let loc = nameSrcLoc name
987 type TagInfo = (String -- tag name
990 ,Int -- column number
993 -- get tag info, for later translation into Vim or Emacs style
994 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
995 tagInfo unqual name loc
996 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
997 , showSDocForUser unqual $ ftext (srcLocFile loc)
1002 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
1003 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
1004 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
1005 IO.try (writeFile file tags)
1006 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
1007 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
1008 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
1009 tagGroups <- mapM tagFileGroup groups
1010 IO.try (writeFile file $ concat tagGroups)
1012 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
1013 tagFileGroup group@((_,fileName,_,_):_) = do
1014 file <- readFile fileName -- need to get additional info from sources..
1015 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
1016 sortedGroup = sortLe byLine group
1017 tags = unlines $ perFile sortedGroup 1 0 $ lines file
1018 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
1019 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
1020 perFile (tagInfo:tags) (count+1) (pos+length line) lines
1021 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
1022 showETag tagInfo line pos : perFile tags count pos lines
1023 perFile tags count pos lines = []
1025 -- simple ctags format, for Vim et al
1026 showTag :: TagInfo -> String
1027 showTag (tag,file,lineNo,colNo)
1028 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
1030 -- etags format, for Emacs/XEmacs
1031 showETag :: TagInfo -> String -> Int -> String
1032 showETag (tag,file,lineNo,colNo) line charPos
1033 = take colNo line ++ tag
1035 ++ "\x01" ++ show lineNo
1036 ++ "," ++ show charPos
1038 -----------------------------------------------------------------------------
1039 -- Browsing a module's contents
1041 browseCmd :: String -> GHCi ()
1044 ['*':m] | looksLikeModuleName m -> browseModule m False
1045 [m] | looksLikeModuleName m -> browseModule m True
1046 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1048 browseModule m exports_only = do
1050 modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
1051 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1052 when (not is_interpreted && not exports_only) $
1053 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1055 -- Temporarily set the context to the module we're interested in,
1056 -- just so we can get an appropriate PrintUnqualified
1057 (as,bs) <- io (GHC.getContext s)
1058 prel_mod <- getPrelude
1059 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1060 else GHC.setContext s [modl] [])
1061 unqual <- io (GHC.getPrintUnqual s)
1062 io (GHC.setContext s as bs)
1064 mb_mod_info <- io $ GHC.getModuleInfo s modl
1066 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1069 | exports_only = GHC.modInfoExports mod_info
1070 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1072 filtered = filterOutChildren names
1074 things <- io $ mapM (GHC.lookupName s) filtered
1076 dflags <- getDynFlags
1077 let exts = dopt Opt_GlasgowExts dflags
1078 io (putStrLn (showSDocForUser unqual (
1079 vcat (map (pprTyThingInContext exts) (catMaybes things))
1081 -- ToDo: modInfoInstances currently throws an exception for
1082 -- package modules. When it works, we can do this:
1083 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1085 -----------------------------------------------------------------------------
1086 -- Setting the module context
1089 | all sensible mods = fn mods
1090 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1092 (fn, mods) = case str of
1093 '+':stuff -> (addToContext, words stuff)
1094 '-':stuff -> (removeFromContext, words stuff)
1095 stuff -> (newContext, words stuff)
1097 sensible ('*':m) = looksLikeModuleName m
1098 sensible m = looksLikeModuleName m
1100 separate :: Session -> [String] -> [Module] -> [Module]
1101 -> GHCi ([Module],[Module])
1102 separate session [] as bs = return (as,bs)
1103 separate session (('*':str):ms) as bs = do
1104 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1105 b <- io $ GHC.moduleIsInterpreted session m
1106 if b then separate session ms (m:as) bs
1107 else throwDyn (CmdLineError ("module '"
1108 ++ GHC.moduleNameString (GHC.moduleName m)
1109 ++ "' is not interpreted"))
1110 separate session (str:ms) as bs = do
1111 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1112 separate session ms as (m:bs)
1114 newContext :: [String] -> GHCi ()
1115 newContext strs = do
1117 (as,bs) <- separate s strs [] []
1118 prel_mod <- getPrelude
1119 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1120 io $ GHC.setContext s as bs'
1123 addToContext :: [String] -> GHCi ()
1124 addToContext strs = do
1126 (as,bs) <- io $ GHC.getContext s
1128 (new_as,new_bs) <- separate s strs [] []
1130 let as_to_add = new_as \\ (as ++ bs)
1131 bs_to_add = new_bs \\ (as ++ bs)
1133 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1136 removeFromContext :: [String] -> GHCi ()
1137 removeFromContext strs = do
1139 (as,bs) <- io $ GHC.getContext s
1141 (as_to_remove,bs_to_remove) <- separate s strs [] []
1143 let as' = as \\ (as_to_remove ++ bs_to_remove)
1144 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1146 io $ GHC.setContext s as' bs'
1148 ----------------------------------------------------------------------------
1151 -- set options in the interpreter. Syntax is exactly the same as the
1152 -- ghc command line, except that certain options aren't available (-C,
1155 -- This is pretty fragile: most options won't work as expected. ToDo:
1156 -- figure out which ones & disallow them.
1158 setCmd :: String -> GHCi ()
1160 = do st <- getGHCiState
1161 let opts = options st
1162 io $ putStrLn (showSDoc (
1163 text "options currently set: " <>
1166 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1170 ("args":args) -> setArgs args
1171 ("prog":prog) -> setProg prog
1172 ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
1173 wds -> setOptions wds
1177 setGHCiState st{ args = args }
1181 setGHCiState st{ progname = prog }
1183 io (hPutStrLn stderr "syntax: :set prog <progname>")
1185 setPrompt value = do
1188 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1189 else setGHCiState st{ prompt = remQuotes value }
1191 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1195 do -- first, deal with the GHCi opts (+s, +t, etc.)
1196 let (plus_opts, minus_opts) = partition isPlus wds
1197 mapM_ setOpt plus_opts
1199 -- then, dynamic flags
1200 dflags <- getDynFlags
1201 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1204 -- update things if the users wants more packages
1206 let new_packages = pkgs_after \\ pkgs_before
1207 when (not (null new_packages)) $
1208 newPackages new_packages
1211 if (not (null leftovers))
1212 then throwDyn (CmdLineError ("unrecognised flags: " ++
1217 unsetOptions :: String -> GHCi ()
1219 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1220 let opts = words str
1221 (minus_opts, rest1) = partition isMinus opts
1222 (plus_opts, rest2) = partition isPlus rest1
1224 if (not (null rest2))
1225 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1228 mapM_ unsetOpt plus_opts
1230 -- can't do GHC flags for now
1231 if (not (null minus_opts))
1232 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1235 isMinus ('-':s) = True
1238 isPlus ('+':s) = True
1242 = case strToGHCiOpt str of
1243 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1244 Just o -> setOption o
1247 = case strToGHCiOpt str of
1248 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1249 Just o -> unsetOption o
1251 strToGHCiOpt :: String -> (Maybe GHCiOption)
1252 strToGHCiOpt "s" = Just ShowTiming
1253 strToGHCiOpt "t" = Just ShowType
1254 strToGHCiOpt "r" = Just RevertCAFs
1255 strToGHCiOpt _ = Nothing
1257 optToStr :: GHCiOption -> String
1258 optToStr ShowTiming = "s"
1259 optToStr ShowType = "t"
1260 optToStr RevertCAFs = "r"
1263 newPackages new_pkgs = do -- The new packages are already in v_Packages
1264 session <- getSession
1265 io (GHC.setTargets session [])
1266 io (GHC.load session Nothing)
1267 dflags <- getDynFlags
1268 io (linkPackages dflags new_pkgs)
1269 setContextAfterLoad []
1272 -- ---------------------------------------------------------------------------
1277 ["modules" ] -> showModules
1278 ["bindings"] -> showBindings
1279 ["linker"] -> io showLinkerState
1280 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1283 session <- getSession
1284 let show_one ms = do m <- io (GHC.showModule session ms)
1286 graph <- io (GHC.getModuleGraph session)
1287 mapM_ show_one graph
1291 unqual <- io (GHC.getPrintUnqual s)
1292 bindings <- io (GHC.getBindings s)
1293 mapM_ showTyThing bindings
1296 showTyThing (AnId id) = do
1297 ty' <- cleanType (GHC.idType id)
1298 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1300 showTyThing _ = return ()
1302 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1303 cleanType :: Type -> GHCi Type
1305 dflags <- getDynFlags
1306 if dopt Opt_GlasgowExts dflags
1308 else return $! GHC.dropForAlls ty
1310 -- -----------------------------------------------------------------------------
1313 completeNone :: String -> IO [String]
1314 completeNone w = return []
1317 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1318 completeWord w start end = do
1319 line <- Readline.getLineBuffer
1321 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1323 | Just c <- is_cmd line -> do
1324 maybe_cmd <- lookupCommand c
1325 let (n,w') = selectWord (words' 0 line)
1327 Nothing -> return Nothing
1328 Just (_,_,False,complete) -> wrapCompleter complete w
1329 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1330 return (map (drop n) rets)
1331 in wrapCompleter complete' w'
1333 --printf "complete %s, start = %d, end = %d\n" w start end
1334 wrapCompleter completeIdentifier w
1335 where words' _ [] = []
1336 words' n str = let (w,r) = break isSpace str
1337 (s,r') = span isSpace r
1338 in (n,w):words' (n+length w+length s) r'
1339 -- In a Haskell expression we want to parse 'a-b' as three words
1340 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1341 -- only be a single word.
1342 selectWord [] = (0,w)
1343 selectWord ((offset,x):xs)
1344 | offset+length x >= start = (start-offset,take (end-offset) x)
1345 | otherwise = selectWord xs
1348 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1349 | otherwise = Nothing
1352 cmds <- readIORef commands
1353 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1355 completeMacro w = do
1356 cmds <- readIORef commands
1357 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1358 return (filter (w `isPrefixOf`) cmds')
1360 completeIdentifier w = do
1362 rdrs <- GHC.getRdrNamesInScope s
1363 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1365 completeModule w = do
1367 dflags <- GHC.getSessionDynFlags s
1368 let pkg_mods = allExposedModules dflags
1369 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1371 completeHomeModule w = do
1373 g <- GHC.getModuleGraph s
1374 let home_mods = map GHC.ms_mod_name g
1375 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1377 completeSetOptions w = do
1378 return (filter (w `isPrefixOf`) options)
1379 where options = "args":"prog":allFlags
1381 completeFilename = Readline.filenameCompletionFunction
1383 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1385 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1386 unionComplete f1 f2 w = do
1391 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1392 wrapCompleter fun w = do
1395 [] -> return Nothing
1396 [x] -> return (Just (x,[]))
1397 xs -> case getCommonPrefix xs of
1398 "" -> return (Just ("",xs))
1399 pref -> return (Just (pref,xs))
1401 getCommonPrefix :: [String] -> String
1402 getCommonPrefix [] = ""
1403 getCommonPrefix (s:ss) = foldl common s ss
1404 where common s "" = s
1406 common (c:cs) (d:ds)
1407 | c == d = c : common cs ds
1410 allExposedModules :: DynFlags -> [ModuleName]
1411 allExposedModules dflags
1412 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1414 pkg_db = pkgIdMap (pkgState dflags)
1416 completeCmd = completeNone
1417 completeMacro = completeNone
1418 completeIdentifier = completeNone
1419 completeModule = completeNone
1420 completeHomeModule = completeNone
1421 completeSetOptions = completeNone
1422 completeFilename = completeNone
1423 completeHomeModuleOrFile=completeNone
1426 -----------------------------------------------------------------------------
1429 data GHCiState = GHCiState
1434 session :: GHC.Session,
1435 options :: [GHCiOption],
1440 = ShowTiming -- show time/allocs after evaluation
1441 | ShowType -- show the type of expressions
1442 | RevertCAFs -- revert CAFs after every evaluation
1445 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1447 startGHCi :: GHCi a -> GHCiState -> IO a
1448 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1450 instance Monad GHCi where
1451 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1452 return a = GHCi $ \s -> return a
1454 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1455 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1456 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1458 getGHCiState = GHCi $ \r -> readIORef r
1459 setGHCiState s = GHCi $ \r -> writeIORef r s
1461 -- for convenience...
1462 getSession = getGHCiState >>= return . session
1463 getPrelude = getGHCiState >>= return . prelude
1465 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
1466 no_saved_sess = error "no saved_ses"
1467 saveSession = getSession >>= io . writeIORef saved_sess
1468 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
1469 restoreSession = readIORef saved_sess
1473 io (GHC.getSessionDynFlags s)
1474 setDynFlags dflags = do
1476 io (GHC.setSessionDynFlags s dflags)
1478 isOptionSet :: GHCiOption -> GHCi Bool
1480 = do st <- getGHCiState
1481 return (opt `elem` options st)
1483 setOption :: GHCiOption -> GHCi ()
1485 = do st <- getGHCiState
1486 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1488 unsetOption :: GHCiOption -> GHCi ()
1490 = do st <- getGHCiState
1491 setGHCiState (st{ options = filter (/= opt) (options st) })
1493 io :: IO a -> GHCi a
1494 io m = GHCi { unGHCi = \s -> m >>= return }
1496 -----------------------------------------------------------------------------
1497 -- recursive exception handlers
1499 -- Don't forget to unblock async exceptions in the handler, or if we're
1500 -- in an exception loop (eg. let a = error a in a) the ^C exception
1501 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1503 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1504 ghciHandle h (GHCi m) = GHCi $ \s ->
1505 Exception.catch (m s)
1506 (\e -> unGHCi (ghciUnblock (h e)) s)
1508 ghciUnblock :: GHCi a -> GHCi a
1509 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1511 -----------------------------------------------------------------------------
1512 -- timing & statistics
1514 timeIt :: GHCi a -> GHCi a
1516 = do b <- isOptionSet ShowTiming
1519 else do allocs1 <- io $ getAllocations
1520 time1 <- io $ getCPUTime
1522 allocs2 <- io $ getAllocations
1523 time2 <- io $ getCPUTime
1524 io $ printTimes (fromIntegral (allocs2 - allocs1))
1528 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1529 -- defined in ghc/rts/Stats.c
1531 printTimes :: Integer -> Integer -> IO ()
1532 printTimes allocs psecs
1533 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1534 secs_str = showFFloat (Just 2) secs
1535 putStrLn (showSDoc (
1536 parens (text (secs_str "") <+> text "secs" <> comma <+>
1537 text (show allocs) <+> text "bytes")))
1539 -----------------------------------------------------------------------------
1546 -- Have to turn off buffering again, because we just
1547 -- reverted stdout, stderr & stdin to their defaults.
1549 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1550 -- Make it "safe", just in case
1552 -- ----------------------------------------------------------------------------
1555 expandPath :: String -> GHCi String
1557 case dropWhile isSpace path of
1559 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1560 return (tilde ++ '/':d)
1564 -- ----------------------------------------------------------------------------
1565 -- Windows console setup
1567 setUpConsole :: IO ()
1569 #ifdef mingw32_HOST_OS
1570 -- On Windows we need to set a known code page, otherwise the characters
1571 -- we read from the console will be be in some strange encoding, and
1572 -- similarly for characters we write to the console.
1574 -- At the moment, GHCi pretends all input is Latin-1. In the
1575 -- future we should support UTF-8, but for now we set the code pages
1578 -- It seems you have to set the font in the console window to
1579 -- a Unicode font in order for output to work properly,
1580 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1581 -- (see MSDN for SetConsoleOutputCP()).
1583 setConsoleCP 28591 -- ISO Latin-1
1584 setConsoleOutputCP 28591 -- ISO Latin-1