1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
18 import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..),
19 TargetId(..), DynFlags(..),
20 pprModule, Type, Module, SuccessFlag(..),
21 TyThing(..), Name, LoadHowMuch(..), Phase,
22 GhcException(..), showGhcException,
23 CheckedModule(..), SrcLoc )
24 import DynFlags ( allFlags )
25 import Packages ( PackageState(..) )
26 import PackageConfig ( InstalledPackageInfo(..) )
27 import UniqFM ( eltsUFM )
31 -- for createtags (should these come via GHC?)
32 import Module ( moduleString )
33 import Name ( nameSrcLoc, nameModule, nameOccName )
34 import OccName ( pprOccName )
35 import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
37 -- Other random utilities
38 import Digraph ( flattenSCCs )
39 import BasicTypes ( failed, successIf )
40 import Panic ( panic, installSignalHandlers )
42 import StaticFlags ( opt_IgnoreDotGhci )
43 import Linker ( showLinkerState )
44 import Util ( removeSpaces, handle, global, toArgs,
45 looksLikeModuleName, prefixMatch, sortLe )
47 #ifndef mingw32_HOST_OS
49 #if __GLASGOW_HASKELL__ > 504
53 import GHC.ConsoleHandler ( flushConsole )
57 import Control.Concurrent ( yield ) -- Used in readline loop
58 import System.Console.Readline as Readline
63 import Control.Exception as Exception
65 -- import Control.Concurrent
69 import Data.Int ( Int64 )
70 import Data.Maybe ( isJust, fromMaybe, catMaybes )
73 import System.Environment
74 import System.Exit ( exitWith, ExitCode(..) )
75 import System.Directory
77 import System.IO.Error as IO
79 import Control.Monad as Monad
80 import Foreign.StablePtr ( newStablePtr )
83 import GHC.Exts ( unsafeCoerce# )
84 import GHC.IOBase ( IOErrorType(InvalidArgument) )
86 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
88 import System.Posix.Internals ( setNonBlockingFD )
90 -----------------------------------------------------------------------------
94 " / _ \\ /\\ /\\/ __(_)\n"++
95 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
96 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
97 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
99 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
100 cmdName (n,_,_,_) = n
102 GLOBAL_VAR(commands, builtin_commands, [Command])
104 builtin_commands :: [Command]
106 ("add", keepGoingPaths addModule, False, completeFilename),
107 ("browse", keepGoing browseCmd, False, completeModule),
108 ("cd", keepGoing changeDirectory, False, completeFilename),
109 ("def", keepGoing defineMacro, False, completeIdentifier),
110 ("help", keepGoing help, False, completeNone),
111 ("?", keepGoing help, False, completeNone),
112 ("info", keepGoing info, False, completeIdentifier),
113 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
114 ("module", keepGoing setContext, False, completeModule),
115 ("main", keepGoing runMain, False, completeIdentifier),
116 ("reload", keepGoing reloadModule, False, completeNone),
117 ("check", keepGoing checkModule, False, completeHomeModule),
118 ("set", keepGoing setCmd, True, completeSetOptions),
119 ("show", keepGoing showCmd, False, completeNone),
120 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
121 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
122 ("type", keepGoing typeOfExpr, False, completeIdentifier),
123 ("kind", keepGoing kindOfType, False, completeIdentifier),
124 ("unset", keepGoing unsetOptions, True, completeSetOptions),
125 ("undef", keepGoing undefineMacro, False, completeMacro),
126 ("quit", quit, False, completeNone)
129 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
130 keepGoing a str = a str >> return False
132 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
133 keepGoingPaths a str = a (toArgs str) >> return False
135 shortHelpText = "use :? for help.\n"
137 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
139 " Commands available from the prompt:\n" ++
141 " <stmt> evaluate/run <stmt>\n" ++
142 " :add <filename> ... add module(s) to the current target set\n" ++
143 " :browse [*]<module> display the names defined by <module>\n" ++
144 " :cd <dir> change directory to <dir>\n" ++
145 " :def <cmd> <expr> define a command :<cmd>\n" ++
146 " :help, :? display this list of commands\n" ++
147 " :info [<name> ...] display information about the given names\n" ++
148 " :load <filename> ... load module(s) and their dependents\n" ++
149 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
150 " :main [<arguments> ...] run the main function with the given arguments\n" ++
151 " :reload reload the current module set\n" ++
153 " :set <option> ... set options\n" ++
154 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
155 " :set prog <progname> set the value returned by System.getProgName\n" ++
157 " :show modules show the currently loaded modules\n" ++
158 " :show bindings show the current bindings made at the prompt\n" ++
160 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
161 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
162 " :type <expr> show the type of <expr>\n" ++
163 " :kind <type> show the kind of <type>\n" ++
164 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
165 " :unset <option> ... unset options\n" ++
166 " :quit exit GHCi\n" ++
167 " :!<command> run the shell command <command>\n" ++
169 " Options for ':set' and ':unset':\n" ++
171 " +r revert top-level expressions after each evaluation\n" ++
172 " +s print timing/memory stats after each evaluation\n" ++
173 " +t print type after evaluation\n" ++
174 " -<flags> most GHC command line flags can also be set here\n" ++
175 " (eg. -v2, -fglasgow-exts, etc.)\n"
178 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
179 interactiveUI session srcs maybe_expr = do
181 -- HACK! If we happen to get into an infinite loop (eg the user
182 -- types 'let x=x in x' at the prompt), then the thread will block
183 -- on a blackhole, and become unreachable during GC. The GC will
184 -- detect that it is unreachable and send it the NonTermination
185 -- exception. However, since the thread is unreachable, everything
186 -- it refers to might be finalized, including the standard Handles.
187 -- This sounds like a bug, but we don't have a good solution right
194 hSetBuffering stdout NoBuffering
196 -- Initialise buffering for the *interpreted* I/O system
197 initInterpBuffering session
199 -- We don't want the cmd line to buffer any input that might be
200 -- intended for the program, so unbuffer stdin.
201 hSetBuffering stdin NoBuffering
203 -- initial context is just the Prelude
204 GHC.setContext session [] [prelude_mod]
208 Readline.setAttemptedCompletionFunction (Just completeWord)
209 --Readline.parseAndBind "set show-all-if-ambiguous 1"
211 let symbols = "!#$%&*+/<=>?@\\^|-~"
212 specials = "(),;[]`{}"
214 word_break_chars = spaces ++ specials ++ symbols
216 Readline.setBasicWordBreakCharacters word_break_chars
217 Readline.setCompleterWordBreakCharacters word_break_chars
220 startGHCi (runGHCi srcs maybe_expr)
221 GHCiState{ progname = "<interactive>",
227 Readline.resetTerminal Nothing
232 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
233 runGHCi paths maybe_expr = do
234 let read_dot_files = not opt_IgnoreDotGhci
236 when (read_dot_files) $ do
239 exists <- io (doesFileExist file)
241 dir_ok <- io (checkPerms ".")
242 file_ok <- io (checkPerms file)
243 when (dir_ok && file_ok) $ do
244 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
247 Right hdl -> fileLoop hdl False
249 when (read_dot_files) $ do
250 -- Read in $HOME/.ghci
251 either_dir <- io (IO.try (getEnv "HOME"))
255 cwd <- io (getCurrentDirectory)
256 when (dir /= cwd) $ do
257 let file = dir ++ "/.ghci"
258 ok <- io (checkPerms file)
260 either_hdl <- io (IO.try (openFile file ReadMode))
263 Right hdl -> fileLoop hdl False
265 -- Perform a :load for files given on the GHCi command line
266 -- When in -e mode, if the load fails then we want to stop
267 -- immediately rather than going on to evaluate the expression.
268 when (not (null paths)) $ do
269 ok <- ghciHandle (\e -> do showException e; return Failed) $
271 when (isJust maybe_expr && failed ok) $
272 io (exitWith (ExitFailure 1))
274 -- if verbosity is greater than 0, or we are connected to a
275 -- terminal, display the prompt in the interactive loop.
276 is_tty <- io (hIsTerminalDevice stdin)
277 dflags <- getDynFlags
278 let show_prompt = verbosity dflags > 0 || is_tty
282 #if defined(mingw32_HOST_OS)
284 -- The win32 Console API mutates the first character of
285 -- type-ahead when reading from it in a non-buffered manner. Work
286 -- around this by flushing the input buffer of type-ahead characters,
287 -- but only if stdin is available.
288 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
290 Left err | isDoesNotExistError err -> return ()
291 | otherwise -> io (ioError err)
292 Right () -> return ()
294 -- enter the interactive loop
295 interactiveLoop is_tty show_prompt
297 -- just evaluate the expression we were given
302 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
305 interactiveLoop is_tty show_prompt =
306 -- Ignore ^C exceptions caught here
307 ghciHandleDyn (\e -> case e of
309 #if defined(mingw32_HOST_OS)
312 interactiveLoop is_tty show_prompt
313 _other -> return ()) $
315 ghciUnblock $ do -- unblock necessary if we recursed from the
316 -- exception handler above.
318 -- read commands from stdin
322 else fileLoop stdin show_prompt
324 fileLoop stdin show_prompt
328 -- NOTE: We only read .ghci files if they are owned by the current user,
329 -- and aren't world writable. Otherwise, we could be accidentally
330 -- running code planted by a malicious third party.
332 -- Furthermore, We only read ./.ghci if . is owned by the current user
333 -- and isn't writable by anyone else. I think this is sufficient: we
334 -- don't need to check .. and ../.. etc. because "." always refers to
335 -- the same directory while a process is running.
337 checkPerms :: String -> IO Bool
339 #ifdef mingw32_HOST_OS
342 Util.handle (\_ -> return False) $ do
343 st <- getFileStatus name
345 if fileOwner st /= me then do
346 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
349 let mode = fileMode st
350 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
351 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
353 putStrLn $ "*** WARNING: " ++ name ++
354 " is writable by someone else, IGNORING!"
359 fileLoop :: Handle -> Bool -> GHCi ()
360 fileLoop hdl prompt = do
361 session <- getSession
362 (mod,imports) <- io (GHC.getContext session)
363 when prompt (io (putStr (mkPrompt mod imports)))
364 l <- io (IO.try (hGetLine hdl))
366 Left e | isEOFError e -> return ()
367 | InvalidArgument <- etype -> return ()
368 | otherwise -> io (ioError e)
369 where etype = ioeGetErrorType e
370 -- treat InvalidArgument in the same way as EOF:
371 -- this can happen if the user closed stdin, or
372 -- perhaps did getContents which closes stdin at
375 case removeSpaces l of
376 "" -> fileLoop hdl prompt
377 l -> do quit <- runCommand l
378 if quit then return () else fileLoop hdl prompt
380 stringLoop :: [String] -> GHCi ()
381 stringLoop [] = return ()
382 stringLoop (s:ss) = do
383 case removeSpaces s of
385 l -> do quit <- runCommand l
386 if quit then return () else stringLoop ss
388 mkPrompt toplevs exports
389 = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
390 <+> hsep (map pprModule exports)
394 readlineLoop :: GHCi ()
396 session <- getSession
397 (mod,imports) <- io (GHC.getContext session)
399 saveSession -- for use by completion
400 l <- io (readline (mkPrompt mod imports)
401 `finally` setNonBlockingFD 0)
402 -- readline sometimes puts stdin into blocking mode,
403 -- so we need to put it back for the IO library
408 case removeSpaces l of
413 if quit then return () else readlineLoop
416 runCommand :: String -> GHCi Bool
417 runCommand c = ghciHandle handler (doCommand c)
419 doCommand (':' : command) = specialCommand command
421 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
424 -- This version is for the GHC command-line option -e. The only difference
425 -- from runCommand is that it catches the ExitException exception and
426 -- exits, rather than printing out the exception.
427 runCommandEval c = ghciHandle handleEval (doCommand c)
429 handleEval (ExitException code) = io (exitWith code)
430 handleEval e = do showException e
431 io (exitWith (ExitFailure 1))
433 doCommand (':' : command) = specialCommand command
435 = do nms <- runStmt stmt
437 Nothing -> io (exitWith (ExitFailure 1))
438 -- failure to run the command causes exit(1) for ghc -e.
439 _ -> finishEvalExpr nms
441 -- This is the exception handler for exceptions generated by the
442 -- user's code; it normally just prints out the exception. The
443 -- handler must be recursive, in case showing the exception causes
444 -- more exceptions to be raised.
446 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
447 -- raising another exception. We therefore don't put the recursive
448 -- handler arond the flushing operation, so if stderr is closed
449 -- GHCi will just die gracefully rather than going into an infinite loop.
450 handler :: Exception -> GHCi Bool
451 handler exception = do
453 io installSignalHandlers
454 ghciHandle handler (showException exception >> return False)
456 showException (DynException dyn) =
457 case fromDynamic dyn of
458 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
459 Just Interrupted -> io (putStrLn "Interrupted.")
460 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
461 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
462 Just other_ghc_ex -> io (print other_ghc_ex)
464 showException other_exception
465 = io (putStrLn ("*** Exception: " ++ show other_exception))
467 runStmt :: String -> GHCi (Maybe [Name])
469 | null (filter (not.isSpace) stmt) = return (Just [])
471 = do st <- getGHCiState
472 session <- getSession
473 result <- io $ withProgName (progname st) $ withArgs (args st) $
474 GHC.runStmt session stmt
476 GHC.RunFailed -> return Nothing
477 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
478 GHC.RunOk names -> return (Just names)
480 -- possibly print the type and revert CAFs after evaluating an expression
481 finishEvalExpr mb_names
482 = do b <- isOptionSet ShowType
483 session <- getSession
486 Just names -> when b (mapM_ (showTypeOfName session) names)
489 io installSignalHandlers
490 b <- isOptionSet RevertCAFs
491 io (when b revertCAFs)
494 showTypeOfName :: Session -> Name -> GHCi ()
495 showTypeOfName session n
496 = do maybe_tything <- io (GHC.lookupName session n)
497 case maybe_tything of
499 Just thing -> showTyThing thing
501 showForUser :: SDoc -> GHCi String
503 session <- getSession
504 unqual <- io (GHC.getPrintUnqual session)
505 return $! showSDocForUser unqual doc
507 specialCommand :: String -> GHCi Bool
508 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
509 specialCommand str = do
510 let (cmd,rest) = break isSpace str
511 maybe_cmd <- io (lookupCommand cmd)
513 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
514 ++ shortHelpText) >> return False)
515 Just (_,f,_,_) -> f (dropWhile isSpace rest)
517 lookupCommand :: String -> IO (Maybe Command)
518 lookupCommand str = do
519 cmds <- readIORef commands
520 -- look for exact match first, then the first prefix match
521 case [ c | c <- cmds, str == cmdName c ] of
522 c:_ -> return (Just c)
523 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
525 c:_ -> return (Just c)
527 -----------------------------------------------------------------------------
528 -- To flush buffers for the *interpreted* computation we need
529 -- to refer to *its* stdout/stderr handles
531 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
532 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
534 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
535 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
536 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
538 initInterpBuffering :: Session -> IO ()
539 initInterpBuffering session
540 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
543 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
544 other -> panic "interactiveUI:setBuffering"
546 maybe_hval <- GHC.compileExpr session flush_cmd
548 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
549 _ -> panic "interactiveUI:flush"
551 turnOffBuffering -- Turn it off right now
556 flushInterpBuffers :: GHCi ()
558 = io $ do Monad.join (readIORef flush_interp)
561 turnOffBuffering :: IO ()
563 = do Monad.join (readIORef turn_off_buffering)
566 -----------------------------------------------------------------------------
569 help :: String -> GHCi ()
570 help _ = io (putStr helpText)
572 info :: String -> GHCi ()
573 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
574 info s = do { let names = words s
575 ; session <- getSession
576 ; dflags <- getDynFlags
577 ; let exts = dopt Opt_GlasgowExts dflags
578 ; mapM_ (infoThing exts session) names }
580 infoThing exts session str = io $ do
581 names <- GHC.parseName session str
582 let filtered = filterOutChildren names
583 mb_stuffs <- mapM (GHC.getInfo session) filtered
584 unqual <- GHC.getPrintUnqual session
585 putStrLn (showSDocForUser unqual $
586 vcat (intersperse (text "") $
587 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
589 -- Filter out names whose parent is also there Good
590 -- example is '[]', which is both a type and data
591 -- constructor in the same type
592 filterOutChildren :: [Name] -> [Name]
593 filterOutChildren names = filter (not . parent_is_there) names
594 where parent_is_there n
595 | Just p <- GHC.nameParent_maybe n = p `elem` names
598 pprInfo exts (thing, fixity, insts)
599 = pprTyThingInContextLoc exts thing
600 $$ show_fixity fixity
601 $$ vcat (map GHC.pprInstance insts)
604 | fix == GHC.defaultFixity = empty
605 | otherwise = ppr fix <+> ppr (GHC.getName thing)
607 -----------------------------------------------------------------------------
610 runMain :: String -> GHCi ()
612 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
613 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
616 addModule :: [FilePath] -> GHCi ()
618 io (revertCAFs) -- always revert CAFs on load/add.
619 files <- mapM expandPath files
620 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
621 session <- getSession
622 io (mapM_ (GHC.addTarget session) targets)
623 ok <- io (GHC.load session LoadAllTargets)
626 changeDirectory :: String -> GHCi ()
627 changeDirectory dir = do
628 session <- getSession
629 graph <- io (GHC.getModuleGraph session)
630 when (not (null graph)) $
631 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
632 io (GHC.setTargets session [])
633 io (GHC.load session LoadAllTargets)
634 setContextAfterLoad session []
635 io (GHC.workingDirectoryChanged session)
636 dir <- expandPath dir
637 io (setCurrentDirectory dir)
639 defineMacro :: String -> GHCi ()
641 let (macro_name, definition) = break isSpace s
642 cmds <- io (readIORef commands)
644 then throwDyn (CmdLineError "invalid macro name")
646 if (macro_name `elem` map cmdName cmds)
647 then throwDyn (CmdLineError
648 ("command '" ++ macro_name ++ "' is already defined"))
651 -- give the expression a type signature, so we can be sure we're getting
652 -- something of the right type.
653 let new_expr = '(' : definition ++ ") :: String -> IO String"
655 -- compile the expression
657 maybe_hv <- io (GHC.compileExpr cms new_expr)
660 Just hv -> io (writeIORef commands --
661 (cmds ++ [(macro_name, keepGoing (runMacro hv), False, completeNone)]))
663 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
665 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
666 stringLoop (lines str)
668 undefineMacro :: String -> GHCi ()
669 undefineMacro macro_name = do
670 cmds <- io (readIORef commands)
671 if (macro_name `elem` map cmdName builtin_commands)
672 then throwDyn (CmdLineError
673 ("command '" ++ macro_name ++ "' cannot be undefined"))
675 if (macro_name `notElem` map cmdName cmds)
676 then throwDyn (CmdLineError
677 ("command '" ++ macro_name ++ "' not defined"))
679 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
682 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
683 loadModule fs = timeIt (loadModule' fs)
685 loadModule_ :: [FilePath] -> GHCi ()
686 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
688 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
689 loadModule' files = do
690 session <- getSession
693 io (GHC.setTargets session [])
694 io (GHC.load session LoadAllTargets)
697 let (filenames, phases) = unzip files
698 exp_filenames <- mapM expandPath filenames
699 let files' = zip exp_filenames phases
700 targets <- io (mapM (uncurry GHC.guessTarget) files')
702 -- NOTE: we used to do the dependency anal first, so that if it
703 -- fails we didn't throw away the current set of modules. This would
704 -- require some re-working of the GHC interface, so we'll leave it
705 -- as a ToDo for now.
707 io (GHC.setTargets session targets)
708 ok <- io (GHC.load session LoadAllTargets)
712 checkModule :: String -> GHCi ()
714 let modl = GHC.mkModule m
715 session <- getSession
716 result <- io (GHC.checkModule session modl)
718 Nothing -> io $ putStrLn "Nothing"
719 Just r -> io $ putStrLn (showSDoc (
720 case checkedModuleInfo r of
721 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
723 (local,global) = partition ((== modl) . GHC.nameModule) scope
725 (text "global names: " <+> ppr global) $$
726 (text "local names: " <+> ppr local)
728 afterLoad (successIf (isJust result)) session
730 reloadModule :: String -> GHCi ()
732 io (revertCAFs) -- always revert CAFs on reload.
733 session <- getSession
734 ok <- io (GHC.load session LoadAllTargets)
737 io (revertCAFs) -- always revert CAFs on reload.
738 session <- getSession
739 ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m)))
742 afterLoad ok session = do
743 io (revertCAFs) -- always revert CAFs on load.
744 graph <- io (GHC.getModuleGraph session)
745 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
746 setContextAfterLoad session graph'
747 modulesLoadedMsg ok (map GHC.ms_mod graph')
749 setContextAfterLoad session [] = do
750 io (GHC.setContext session [] [prelude_mod])
751 setContextAfterLoad session ms = do
752 -- load a target if one is available, otherwise load the topmost module.
753 targets <- io (GHC.getTargets session)
754 case [ m | Just m <- map (findTarget ms) targets ] of
756 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
757 load_this (last graph')
762 = case filter (`matches` t) ms of
766 summary `matches` Target (TargetModule m) _
767 = GHC.ms_mod summary == m
768 summary `matches` Target (TargetFile f _) _
769 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
770 summary `matches` target
773 load_this summary | m <- GHC.ms_mod summary = do
774 b <- io (GHC.moduleIsInterpreted session m)
775 if b then io (GHC.setContext session [m] [])
776 else io (GHC.setContext session [] [prelude_mod,m])
779 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
780 modulesLoadedMsg ok mods = do
781 dflags <- getDynFlags
782 when (verbosity dflags > 0) $ do
784 | null mods = text "none."
786 punctuate comma (map pprModule mods)) <> text "."
789 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
791 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
794 typeOfExpr :: String -> GHCi ()
796 = do cms <- getSession
797 maybe_ty <- io (GHC.exprType cms str)
800 Just ty -> do ty' <- cleanType ty
801 tystr <- showForUser (ppr ty')
802 io (putStrLn (str ++ " :: " ++ tystr))
804 kindOfType :: String -> GHCi ()
806 = do cms <- getSession
807 maybe_ty <- io (GHC.typeKind cms str)
810 Just ty -> do tystr <- showForUser (ppr ty)
811 io (putStrLn (str ++ " :: " ++ tystr))
813 quit :: String -> GHCi Bool
816 shellEscape :: String -> GHCi Bool
817 shellEscape str = io (system str >> return False)
819 -----------------------------------------------------------------------------
820 -- create tags file for currently loaded modules.
822 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
824 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
825 createCTagsFileCmd file = ghciCreateTagsFile CTags file
827 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
828 createETagsFileCmd file = ghciCreateTagsFile ETags file
830 data TagsKind = ETags | CTags
832 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
833 ghciCreateTagsFile kind file = do
834 session <- getSession
835 io $ createTagsFile session kind file
838 -- - remove restriction that all modules must be interpreted
839 -- (problem: we don't know source locations for entities unless
840 -- we compiled the module.
842 -- - extract createTagsFile so it can be used from the command-line
843 -- (probably need to fix first problem before this is useful).
845 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
846 createTagsFile session tagskind tagFile = do
847 graph <- GHC.getModuleGraph session
848 let ms = map GHC.ms_mod graph
850 is_interpreted <- GHC.moduleIsInterpreted session m
851 -- should we just skip these?
852 when (not is_interpreted) $
853 throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
855 mbModInfo <- GHC.getModuleInfo session m
857 | Just modinfo <- mbModInfo,
858 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
859 | otherwise = GHC.alwaysQualify
862 Just modInfo -> return $! listTags unqual modInfo
865 mtags <- mapM tagModule ms
866 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
868 Left e -> hPutStrLn stderr $ ioeGetErrorString e
871 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
872 listTags unqual modInfo =
873 [ tagInfo unqual name loc
874 | name <- GHC.modInfoExports modInfo
875 , let loc = nameSrcLoc name
879 type TagInfo = (String -- tag name
882 ,Int -- column number
885 -- get tag info, for later translation into Vim or Emacs style
886 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
887 tagInfo unqual name loc
888 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
889 , showSDocForUser unqual $ ftext (srcLocFile loc)
894 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
895 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
896 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
897 IO.try (writeFile file tags)
898 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
899 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
900 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
901 tagGroups <- mapM tagFileGroup groups
902 IO.try (writeFile file $ concat tagGroups)
904 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
905 tagFileGroup group@((_,fileName,_,_):_) = do
906 file <- readFile fileName -- need to get additional info from sources..
907 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
908 sortedGroup = sortLe byLine group
909 tags = unlines $ perFile sortedGroup 1 0 $ lines file
910 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
911 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
912 perFile (tagInfo:tags) (count+1) (pos+length line) lines
913 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
914 showETag tagInfo line pos : perFile tags count pos lines
915 perFile tags count pos lines = []
917 -- simple ctags format, for Vim et al
918 showTag :: TagInfo -> String
919 showTag (tag,file,lineNo,colNo)
920 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
922 -- etags format, for Emacs/XEmacs
923 showETag :: TagInfo -> String -> Int -> String
924 showETag (tag,file,lineNo,colNo) line charPos
925 = take colNo line ++ tag
927 ++ "\x01" ++ show lineNo
928 ++ "," ++ show charPos
930 -----------------------------------------------------------------------------
931 -- Browsing a module's contents
933 browseCmd :: String -> GHCi ()
936 ['*':m] | looksLikeModuleName m -> browseModule m False
937 [m] | looksLikeModuleName m -> browseModule m True
938 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
940 browseModule m exports_only = do
943 let modl = GHC.mkModule m
944 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
945 when (not is_interpreted && not exports_only) $
946 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
948 -- Temporarily set the context to the module we're interested in,
949 -- just so we can get an appropriate PrintUnqualified
950 (as,bs) <- io (GHC.getContext s)
951 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
952 else GHC.setContext s [modl] [])
953 unqual <- io (GHC.getPrintUnqual s)
954 io (GHC.setContext s as bs)
956 mb_mod_info <- io $ GHC.getModuleInfo s modl
958 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
961 | exports_only = GHC.modInfoExports mod_info
962 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
964 filtered = filterOutChildren names
966 things <- io $ mapM (GHC.lookupName s) filtered
968 dflags <- getDynFlags
969 let exts = dopt Opt_GlasgowExts dflags
970 io (putStrLn (showSDocForUser unqual (
971 vcat (map (pprTyThingInContext exts) (catMaybes things))
973 -- ToDo: modInfoInstances currently throws an exception for
974 -- package modules. When it works, we can do this:
975 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
977 -----------------------------------------------------------------------------
978 -- Setting the module context
981 | all sensible mods = fn mods
982 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
984 (fn, mods) = case str of
985 '+':stuff -> (addToContext, words stuff)
986 '-':stuff -> (removeFromContext, words stuff)
987 stuff -> (newContext, words stuff)
989 sensible ('*':m) = looksLikeModuleName m
990 sensible m = looksLikeModuleName m
993 session <- getSession
994 (as,bs) <- separate session mods [] []
995 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
996 io (GHC.setContext session as bs')
998 separate :: Session -> [String] -> [Module] -> [Module]
999 -> GHCi ([Module],[Module])
1000 separate session [] as bs = return (as,bs)
1001 separate session (('*':m):ms) as bs = do
1002 let modl = GHC.mkModule m
1003 b <- io (GHC.moduleIsInterpreted session modl)
1004 if b then separate session ms (modl:as) bs
1005 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1006 separate session (m:ms) as bs = separate session ms as (GHC.mkModule m:bs)
1008 prelude_mod = GHC.mkModule "Prelude"
1011 addToContext mods = do
1013 (as,bs) <- io (GHC.getContext cms)
1015 (as',bs') <- separate cms mods [] []
1017 let as_to_add = as' \\ (as ++ bs)
1018 bs_to_add = bs' \\ (as ++ bs)
1020 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
1023 removeFromContext mods = do
1025 (as,bs) <- io (GHC.getContext cms)
1027 (as_to_remove,bs_to_remove) <- separate cms mods [] []
1029 let as' = as \\ (as_to_remove ++ bs_to_remove)
1030 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1032 io (GHC.setContext cms as' bs')
1034 ----------------------------------------------------------------------------
1037 -- set options in the interpreter. Syntax is exactly the same as the
1038 -- ghc command line, except that certain options aren't available (-C,
1041 -- This is pretty fragile: most options won't work as expected. ToDo:
1042 -- figure out which ones & disallow them.
1044 setCmd :: String -> GHCi ()
1046 = do st <- getGHCiState
1047 let opts = options st
1048 io $ putStrLn (showSDoc (
1049 text "options currently set: " <>
1052 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1056 ("args":args) -> setArgs args
1057 ("prog":prog) -> setProg prog
1058 wds -> setOptions wds
1062 setGHCiState st{ args = args }
1066 setGHCiState st{ progname = prog }
1068 io (hPutStrLn stderr "syntax: :set prog <progname>")
1071 do -- first, deal with the GHCi opts (+s, +t, etc.)
1072 let (plus_opts, minus_opts) = partition isPlus wds
1073 mapM_ setOpt plus_opts
1075 -- then, dynamic flags
1076 dflags <- getDynFlags
1077 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1080 -- update things if the users wants more packages
1082 let new_packages = pkgs_after \\ pkgs_before
1083 when (not (null new_packages)) $
1084 newPackages new_packages
1087 if (not (null leftovers))
1088 then throwDyn (CmdLineError ("unrecognised flags: " ++
1093 unsetOptions :: String -> GHCi ()
1095 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1096 let opts = words str
1097 (minus_opts, rest1) = partition isMinus opts
1098 (plus_opts, rest2) = partition isPlus rest1
1100 if (not (null rest2))
1101 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1104 mapM_ unsetOpt plus_opts
1106 -- can't do GHC flags for now
1107 if (not (null minus_opts))
1108 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1111 isMinus ('-':s) = True
1114 isPlus ('+':s) = True
1118 = case strToGHCiOpt str of
1119 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1120 Just o -> setOption o
1123 = case strToGHCiOpt str of
1124 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1125 Just o -> unsetOption o
1127 strToGHCiOpt :: String -> (Maybe GHCiOption)
1128 strToGHCiOpt "s" = Just ShowTiming
1129 strToGHCiOpt "t" = Just ShowType
1130 strToGHCiOpt "r" = Just RevertCAFs
1131 strToGHCiOpt _ = Nothing
1133 optToStr :: GHCiOption -> String
1134 optToStr ShowTiming = "s"
1135 optToStr ShowType = "t"
1136 optToStr RevertCAFs = "r"
1139 newPackages new_pkgs = do -- The new packages are already in v_Packages
1140 session <- getSession
1141 io (GHC.setTargets session [])
1142 io (GHC.load session Nothing)
1143 dflags <- getDynFlags
1144 io (linkPackages dflags new_pkgs)
1145 setContextAfterLoad []
1148 -- ---------------------------------------------------------------------------
1153 ["modules" ] -> showModules
1154 ["bindings"] -> showBindings
1155 ["linker"] -> io showLinkerState
1156 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1159 session <- getSession
1160 let show_one ms = do m <- io (GHC.showModule session ms)
1162 graph <- io (GHC.getModuleGraph session)
1163 mapM_ show_one graph
1167 unqual <- io (GHC.getPrintUnqual s)
1168 bindings <- io (GHC.getBindings s)
1169 mapM_ showTyThing bindings
1172 showTyThing (AnId id) = do
1173 ty' <- cleanType (GHC.idType id)
1174 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1176 showTyThing _ = return ()
1178 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1179 cleanType :: Type -> GHCi Type
1181 dflags <- getDynFlags
1182 if dopt Opt_GlasgowExts dflags
1184 else return $! GHC.dropForAlls ty
1186 -- -----------------------------------------------------------------------------
1190 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1191 completeWord w start end = do
1192 line <- Readline.getLineBuffer
1194 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1196 | Just c <- is_cmd line -> do
1197 maybe_cmd <- lookupCommand c
1198 let (n,w') = selectWord 0 (words line)
1200 Nothing -> return Nothing
1201 Just (_,_,False,complete) -> wrapCompleter complete w
1202 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1203 return (map (drop n) rets)
1204 in wrapCompleter complete' w'
1206 --printf "complete %s, start = %d, end = %d\n" w start end
1207 wrapCompleter completeIdentifier w
1208 where selectWord _ [] = (0,w)
1210 | n+length x >= start = (start-n-1,take (end-n+1) x)
1211 | otherwise = selectWord (n+length x) xs
1214 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1215 | otherwise = Nothing
1217 completeNone w = return []
1220 cmds <- readIORef commands
1221 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1223 completeMacro w = do
1224 cmds <- readIORef commands
1225 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1226 return (filter (w `isPrefixOf`) cmds')
1228 completeIdentifier w = do
1230 rdrs <- GHC.getRdrNamesInScope s
1231 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1233 completeModule w = do
1235 dflags <- GHC.getSessionDynFlags s
1236 let pkg_mods = allExposedModules dflags
1237 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1239 completeHomeModule w = do
1241 g <- GHC.getModuleGraph s
1242 let home_mods = map GHC.ms_mod g
1243 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1245 completeSetOptions w = do
1246 return (filter (w `isPrefixOf`) options)
1247 where options = "args":"prog":allFlags
1249 completeFilename = Readline.filenameCompletionFunction
1251 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1253 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1254 unionComplete f1 f2 w = do
1259 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1260 wrapCompleter fun w = do
1263 [] -> return Nothing
1264 [x] -> return (Just (x,[]))
1265 xs -> case getCommonPrefix xs of
1266 "" -> return (Just ("",xs))
1267 pref -> return (Just (pref,xs))
1269 getCommonPrefix :: [String] -> String
1270 getCommonPrefix [] = ""
1271 getCommonPrefix (s:ss) = foldl common s ss
1272 where common s "" = s
1274 common (c:cs) (d:ds)
1275 | c == d = c : common cs ds
1278 allExposedModules :: DynFlags -> [Module]
1279 allExposedModules dflags
1280 = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1282 pkg_db = pkgIdMap (pkgState dflags)
1285 -----------------------------------------------------------------------------
1288 data GHCiState = GHCiState
1292 session :: GHC.Session,
1293 options :: [GHCiOption]
1297 = ShowTiming -- show time/allocs after evaluation
1298 | ShowType -- show the type of expressions
1299 | RevertCAFs -- revert CAFs after every evaluation
1302 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1304 startGHCi :: GHCi a -> GHCiState -> IO a
1305 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1307 instance Monad GHCi where
1308 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1309 return a = GHCi $ \s -> return a
1311 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1312 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1313 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1315 getGHCiState = GHCi $ \r -> readIORef r
1316 setGHCiState s = GHCi $ \r -> writeIORef r s
1318 -- for convenience...
1319 getSession = getGHCiState >>= return . session
1321 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
1322 no_saved_sess = error "no saved_ses"
1323 saveSession = getSession >>= io . writeIORef saved_sess
1324 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
1325 restoreSession = readIORef saved_sess
1329 io (GHC.getSessionDynFlags s)
1330 setDynFlags dflags = do
1332 io (GHC.setSessionDynFlags s dflags)
1334 isOptionSet :: GHCiOption -> GHCi Bool
1336 = do st <- getGHCiState
1337 return (opt `elem` options st)
1339 setOption :: GHCiOption -> GHCi ()
1341 = do st <- getGHCiState
1342 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1344 unsetOption :: GHCiOption -> GHCi ()
1346 = do st <- getGHCiState
1347 setGHCiState (st{ options = filter (/= opt) (options st) })
1349 io :: IO a -> GHCi a
1350 io m = GHCi { unGHCi = \s -> m >>= return }
1352 -----------------------------------------------------------------------------
1353 -- recursive exception handlers
1355 -- Don't forget to unblock async exceptions in the handler, or if we're
1356 -- in an exception loop (eg. let a = error a in a) the ^C exception
1357 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1359 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1360 ghciHandle h (GHCi m) = GHCi $ \s ->
1361 Exception.catch (m s)
1362 (\e -> unGHCi (ghciUnblock (h e)) s)
1364 ghciUnblock :: GHCi a -> GHCi a
1365 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1367 -----------------------------------------------------------------------------
1368 -- timing & statistics
1370 timeIt :: GHCi a -> GHCi a
1372 = do b <- isOptionSet ShowTiming
1375 else do allocs1 <- io $ getAllocations
1376 time1 <- io $ getCPUTime
1378 allocs2 <- io $ getAllocations
1379 time2 <- io $ getCPUTime
1380 io $ printTimes (fromIntegral (allocs2 - allocs1))
1384 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1385 -- defined in ghc/rts/Stats.c
1387 printTimes :: Integer -> Integer -> IO ()
1388 printTimes allocs psecs
1389 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1390 secs_str = showFFloat (Just 2) secs
1391 putStrLn (showSDoc (
1392 parens (text (secs_str "") <+> text "secs" <> comma <+>
1393 text (show allocs) <+> text "bytes")))
1395 -----------------------------------------------------------------------------
1402 -- Have to turn off buffering again, because we just
1403 -- reverted stdout, stderr & stdin to their defaults.
1405 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1406 -- Make it "safe", just in case
1408 -- -----------------------------------------------------------------------------
1411 expandPath :: String -> GHCi String
1413 case dropWhile isSpace path of
1415 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1416 return (tilde ++ '/':d)