1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
12 #include "HsVersions.h"
20 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
21 Module, ModuleName, TyThing(..), Phase,
22 BreakIndex, SrcSpan, Resume, SingleStep )
32 import HscTypes ( implicitTyThings )
33 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
34 import Outputable hiding (printForUser, printForUserPartWay)
35 import Module -- for ModuleEnv
39 -- Other random utilities
41 import BasicTypes hiding (isTopLevel)
42 import Panic hiding (showException)
48 import Maybes ( orElse )
52 #ifndef mingw32_HOST_OS
53 import System.Posix hiding (getEnv)
55 import GHC.ConsoleHandler ( flushConsole )
56 import qualified System.Win32
60 import Control.Concurrent ( yield ) -- Used in readline loop
61 import System.Console.Readline as Readline
66 import Control.Exception as Exception
67 -- import Control.Concurrent
69 import qualified Data.ByteString.Char8 as BS
73 import System.Environment
74 import System.Exit ( exitWith, ExitCode(..) )
75 import System.Directory
77 import System.IO.Error as IO
81 import Control.Monad as Monad
84 import Foreign.C ( withCStringLen )
85 import GHC.Exts ( unsafeCoerce# )
86 import GHC.IOBase ( IOErrorType(InvalidArgument) )
88 import Data.IORef ( IORef, readIORef, writeIORef )
91 import System.Posix.Internals ( setNonBlockingFD )
94 -----------------------------------------------------------------------------
96 ghciWelcomeMsg :: String
97 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
98 ": http://www.haskell.org/ghc/ :? for help"
100 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
102 cmdName :: Command -> String
103 cmdName (n,_,_,_) = n
105 macros_ref :: IORef [Command]
106 GLOBAL_VAR(macros_ref, [], [Command])
108 builtin_commands :: [Command]
110 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
111 ("?", keepGoing help, False, completeNone),
112 ("add", keepGoingPaths addModule, False, completeFilename),
113 ("abandon", keepGoing abandonCmd, False, completeNone),
114 ("break", keepGoing breakCmd, False, completeIdentifier),
115 ("back", keepGoing backCmd, False, completeNone),
116 ("browse", keepGoing (browseCmd False), False, completeModule),
117 ("browse!", keepGoing (browseCmd True), False, completeModule),
118 ("cd", keepGoing changeDirectory, False, completeFilename),
119 ("check", keepGoing checkModule, False, completeHomeModule),
120 ("continue", keepGoing continueCmd, False, completeNone),
121 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
122 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
123 ("def", keepGoing (defineMacro False), False, completeIdentifier),
124 ("def!", keepGoing (defineMacro True), False, completeIdentifier),
125 ("delete", keepGoing deleteCmd, False, completeNone),
126 ("e", keepGoing editFile, False, completeFilename),
127 ("edit", keepGoing editFile, False, completeFilename),
128 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
129 ("force", keepGoing forceCmd, False, completeIdentifier),
130 ("forward", keepGoing forwardCmd, False, completeNone),
131 ("help", keepGoing help, False, completeNone),
132 ("history", keepGoing historyCmd, False, completeNone),
133 ("info", keepGoing info, False, completeIdentifier),
134 ("kind", keepGoing kindOfType, False, completeIdentifier),
135 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
136 ("list", keepGoing listCmd, False, completeNone),
137 ("module", keepGoing setContext, False, completeModule),
138 ("main", keepGoing runMain, False, completeIdentifier),
139 ("print", keepGoing printCmd, False, completeIdentifier),
140 ("quit", quit, False, completeNone),
141 ("reload", keepGoing reloadModule, False, completeNone),
142 ("set", keepGoing setCmd, True, completeSetOptions),
143 ("show", keepGoing showCmd, False, completeNone),
144 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
145 ("step", keepGoing stepCmd, False, completeIdentifier),
146 ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
147 ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
148 ("type", keepGoing typeOfExpr, False, completeIdentifier),
149 ("trace", keepGoing traceCmd, False, completeIdentifier),
150 ("undef", keepGoing undefineMacro, False, completeMacro),
151 ("unset", keepGoing unsetOptions, True, completeSetOptions)
154 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
155 keepGoing a str = a str >> return False
157 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
158 keepGoingPaths a str = a (toArgs str) >> return False
160 shortHelpText :: String
161 shortHelpText = "use :? for help.\n"
165 " Commands available from the prompt:\n" ++
167 " <statement> evaluate/run <statement>\n" ++
168 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
169 " :add <filename> ... add module(s) to the current target set\n" ++
170 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
171 " (!: more details; *: all top-level names)\n" ++
172 " :cd <dir> change directory to <dir>\n" ++
173 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
174 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
175 " :def <cmd> <expr> define a command :<cmd>\n" ++
176 " :edit <file> edit file\n" ++
177 " :edit edit last module\n" ++
178 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
179 " :help, :? display this list of commands\n" ++
180 " :info [<name> ...] display information about the given names\n" ++
181 " :kind <type> show the kind of <type>\n" ++
182 " :load <filename> ... load module(s) and their dependents\n" ++
183 " :main [<arguments> ...] run the main function with the given arguments\n" ++
184 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
185 " :quit exit GHCi\n" ++
186 " :reload reload the current module set\n" ++
187 " :type <expr> show the type of <expr>\n" ++
188 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
189 " :!<command> run the shell command <command>\n" ++
191 " -- Commands for debugging:\n" ++
193 " :abandon at a breakpoint, abandon current computation\n" ++
194 " :back go back in the history (after :trace)\n" ++
195 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
196 " :break <name> set a breakpoint on the specified function\n" ++
197 " :continue resume after a breakpoint\n" ++
198 " :delete <number> delete the specified breakpoint\n" ++
199 " :delete * delete all breakpoints\n" ++
200 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
201 " :forward go forward in the history (after :back)\n" ++
202 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
203 " :print [<name> ...] prints a value without forcing its computation\n" ++
204 " :sprint [<name> ...] simplifed version of :print\n" ++
205 " :step single-step after stopping at a breakpoint\n"++
206 " :step <expr> single-step into <expr>\n"++
207 " :steplocal single-step restricted to the current top level decl.\n"++
208 " :stepmodule single-step restricted to the current module\n"++
209 " :trace trace after stopping at a breakpoint\n"++
210 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
213 " -- Commands for changing settings:\n" ++
215 " :set <option> ... set options\n" ++
216 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
217 " :set prog <progname> set the value returned by System.getProgName\n" ++
218 " :set prompt <prompt> set the prompt used in GHCi\n" ++
219 " :set editor <cmd> set the command used for :edit\n" ++
220 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
221 " :unset <option> ... unset options\n" ++
223 " Options for ':set' and ':unset':\n" ++
225 " +r revert top-level expressions after each evaluation\n" ++
226 " +s print timing/memory stats after each evaluation\n" ++
227 " +t print type after evaluation\n" ++
228 " -<flags> most GHC command line flags can also be set here\n" ++
229 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
230 " for GHCi-specific flags, see User's Guide,\n"++
231 " Flag reference, Interactive-mode options\n" ++
233 " -- Commands for displaying information:\n" ++
235 " :show bindings show the current bindings made at the prompt\n" ++
236 " :show breaks show the active breakpoints\n" ++
237 " :show context show the breakpoint context\n" ++
238 " :show modules show the currently loaded modules\n" ++
239 " :show packages show the currently active package flags\n" ++
240 " :show languages show the currently active language flags\n" ++
241 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
244 findEditor :: IO String
249 win <- System.Win32.getWindowsDirectory
250 return (win `joinFileName` "notepad.exe")
255 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
256 interactiveUI session srcs maybe_expr = do
257 -- HACK! If we happen to get into an infinite loop (eg the user
258 -- types 'let x=x in x' at the prompt), then the thread will block
259 -- on a blackhole, and become unreachable during GC. The GC will
260 -- detect that it is unreachable and send it the NonTermination
261 -- exception. However, since the thread is unreachable, everything
262 -- it refers to might be finalized, including the standard Handles.
263 -- This sounds like a bug, but we don't have a good solution right
269 -- Initialise buffering for the *interpreted* I/O system
270 initInterpBuffering session
272 when (isNothing maybe_expr) $ do
273 -- Only for GHCi (not runghc and ghc -e):
275 -- Turn buffering off for the compiled program's stdout/stderr
277 -- Turn buffering off for GHCi's stdout
279 hSetBuffering stdout NoBuffering
280 -- We don't want the cmd line to buffer any input that might be
281 -- intended for the program, so unbuffer stdin.
282 hSetBuffering stdin NoBuffering
284 -- initial context is just the Prelude
285 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
287 GHC.setContext session [] [prel_mod]
291 Readline.setAttemptedCompletionFunction (Just completeWord)
292 --Readline.parseAndBind "set show-all-if-ambiguous 1"
294 let symbols = "!#$%&*+/<=>?@\\^|-~"
295 specials = "(),;[]`{}"
297 word_break_chars = spaces ++ specials ++ symbols
299 Readline.setBasicWordBreakCharacters word_break_chars
300 Readline.setCompleterWordBreakCharacters word_break_chars
303 default_editor <- findEditor
305 startGHCi (runGHCi srcs maybe_expr)
306 GHCiState{ progname = "<interactive>",
310 editor = default_editor,
316 tickarrays = emptyModuleEnv,
318 remembered_ctx = Nothing
322 Readline.resetTerminal Nothing
327 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
328 runGHCi paths maybe_expr = do
329 let read_dot_files = not opt_IgnoreDotGhci
331 when (read_dot_files) $ do
334 exists <- io (doesFileExist file)
336 dir_ok <- io (checkPerms ".")
337 file_ok <- io (checkPerms file)
338 when (dir_ok && file_ok) $ do
339 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
342 Right hdl -> runCommands (fileLoop hdl False False)
344 when (read_dot_files) $ do
345 -- Read in $HOME/.ghci
346 either_dir <- io (IO.try getHomeDirectory)
350 cwd <- io (getCurrentDirectory)
351 when (dir /= cwd) $ do
352 let file = dir ++ "/.ghci"
353 ok <- io (checkPerms file)
355 either_hdl <- io (IO.try (openFile file ReadMode))
358 Right hdl -> runCommands (fileLoop hdl False False)
360 -- Perform a :load for files given on the GHCi command line
361 -- When in -e mode, if the load fails then we want to stop
362 -- immediately rather than going on to evaluate the expression.
363 when (not (null paths)) $ do
364 ok <- ghciHandle (\e -> do showException e; return Failed) $
366 when (isJust maybe_expr && failed ok) $
367 io (exitWith (ExitFailure 1))
369 -- if verbosity is greater than 0, or we are connected to a
370 -- terminal, display the prompt in the interactive loop.
371 is_tty <- io (hIsTerminalDevice stdin)
372 dflags <- getDynFlags
373 let show_prompt = verbosity dflags > 0 || is_tty
378 #if defined(mingw32_HOST_OS)
379 -- The win32 Console API mutates the first character of
380 -- type-ahead when reading from it in a non-buffered manner. Work
381 -- around this by flushing the input buffer of type-ahead characters,
382 -- but only if stdin is available.
383 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
385 Left err | isDoesNotExistError err -> return ()
386 | otherwise -> io (ioError err)
387 Right () -> return ()
389 -- enter the interactive loop
390 interactiveLoop is_tty show_prompt
392 -- just evaluate the expression we were given
397 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
400 interactiveLoop :: Bool -> Bool -> GHCi ()
401 interactiveLoop is_tty show_prompt =
402 -- Ignore ^C exceptions caught here
403 ghciHandleDyn (\e -> case e of
405 #if defined(mingw32_HOST_OS)
408 interactiveLoop is_tty show_prompt
409 _other -> return ()) $
411 ghciUnblock $ do -- unblock necessary if we recursed from the
412 -- exception handler above.
414 -- read commands from stdin
417 then runCommands readlineLoop
418 else runCommands (fileLoop stdin show_prompt is_tty)
420 runCommands (fileLoop stdin show_prompt is_tty)
424 -- NOTE: We only read .ghci files if they are owned by the current user,
425 -- and aren't world writable. Otherwise, we could be accidentally
426 -- running code planted by a malicious third party.
428 -- Furthermore, We only read ./.ghci if . is owned by the current user
429 -- and isn't writable by anyone else. I think this is sufficient: we
430 -- don't need to check .. and ../.. etc. because "." always refers to
431 -- the same directory while a process is running.
433 checkPerms :: String -> IO Bool
434 #ifdef mingw32_HOST_OS
439 Util.handle (\_ -> return False) $ do
440 st <- getFileStatus name
442 if fileOwner st /= me then do
443 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
446 let mode = fileMode st
447 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
448 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
450 putStrLn $ "*** WARNING: " ++ name ++
451 " is writable by someone else, IGNORING!"
456 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
457 fileLoop hdl show_prompt is_tty = do
458 when show_prompt $ do
461 l <- io (IO.try (hGetLine hdl))
463 Left e | isEOFError e -> return Nothing
464 | InvalidArgument <- etype -> return Nothing
465 | otherwise -> io (ioError e)
466 where etype = ioeGetErrorType e
467 -- treat InvalidArgument in the same way as EOF:
468 -- this can happen if the user closed stdin, or
469 -- perhaps did getContents which closes stdin at
472 str <- io $ consoleInputToUnicode is_tty l
475 #ifdef mingw32_HOST_OS
476 -- Convert the console input into Unicode according to the current code page.
477 -- The Windows console stores Unicode characters directly, so this is a
478 -- rather roundabout way of doing things... oh well.
479 -- See #782, #1483, #1649
480 consoleInputToUnicode :: Bool -> String -> IO String
481 consoleInputToUnicode is_tty str
483 cp <- System.Win32.getConsoleCP
484 System.Win32.stringToUnicode cp str
486 decodeStringAsUTF8 str
488 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
490 consoleInputToUnicode :: Bool -> String -> IO String
491 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
494 decodeStringAsUTF8 :: String -> IO String
495 decodeStringAsUTF8 str =
496 withCStringLen str $ \(cstr,len) ->
497 utf8DecodeString (castPtr cstr :: Ptr Word8) len
499 mkPrompt :: GHCi String
501 session <- getSession
502 (toplevs,exports) <- io (GHC.getContext session)
503 resumes <- io $ GHC.getResumeContext session
504 -- st <- getGHCiState
510 let ix = GHC.resumeHistoryIx r
512 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
514 let hist = GHC.resumeHistory r !! (ix-1)
515 span <- io$ GHC.getHistorySpan session hist
516 return (brackets (ppr (negate ix) <> char ':'
517 <+> ppr span) <> space)
519 dots | _:rs <- resumes, not (null rs) = text "... "
526 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
527 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
528 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
529 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
530 hsep (map (ppr . GHC.moduleName) exports)
532 deflt_prompt = dots <> context_bit <> modules_bit
534 f ('%':'s':xs) = deflt_prompt <> f xs
535 f ('%':'%':xs) = char '%' <> f xs
536 f (x:xs) = char x <> f xs
540 return (showSDoc (f (prompt st)))
544 readlineLoop :: GHCi (Maybe String)
547 saveSession -- for use by completion
549 l <- io (readline prompt `finally` setNonBlockingFD 0)
550 -- readline sometimes puts stdin into blocking mode,
551 -- so we need to put it back for the IO library
554 Nothing -> return Nothing
557 str <- io $ consoleInputToUnicode True l
561 queryQueue :: GHCi (Maybe String)
566 c:cs -> do setGHCiState st{ cmdqueue = cs }
569 runCommands :: GHCi (Maybe String) -> GHCi ()
570 runCommands getCmd = do
571 mb_cmd <- noSpace queryQueue
572 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
576 b <- ghciHandle handler (doCommand c)
577 if b then return () else runCommands getCmd
579 noSpace q = q >>= maybe (return Nothing)
580 (\c->case removeSpaces c of
582 ":{" -> multiLineCmd q
583 c -> return (Just c) )
587 setGHCiState st{ prompt = "%s| " }
588 mb_cmd <- collectCommand q ""
589 getGHCiState >>= \st->setGHCiState st{ prompt = p }
591 -- we can't use removeSpaces for the sublines here, so
592 -- multiline commands are somewhat more brittle against
593 -- fileformat errors (such as \r in dos input on unix),
594 -- we get rid of any extra spaces for the ":}" test;
595 -- we also avoid silent failure if ":}" is not found;
596 -- and since there is no (?) valid occurrence of \r (as
597 -- opposed to its String representation, "\r") inside a
598 -- ghci command, we replace any such with ' ' (argh:-(
599 collectCommand q c = q >>=
600 maybe (io (ioError collectError))
601 (\l->if removeSpaces l == ":}"
602 then return (Just $ removeSpaces c)
603 else collectCommand q (c++map normSpace l))
604 where normSpace '\r' = ' '
606 -- QUESTION: is userError the one to use here?
607 collectError = userError "unterminated multiline command :{ .. :}"
608 doCommand (':' : cmd) = specialCommand cmd
609 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
612 enqueueCommands :: [String] -> GHCi ()
613 enqueueCommands cmds = do
615 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
618 -- This version is for the GHC command-line option -e. The only difference
619 -- from runCommand is that it catches the ExitException exception and
620 -- exits, rather than printing out the exception.
621 runCommandEval :: String -> GHCi Bool
622 runCommandEval c = ghciHandle handleEval (doCommand c)
624 handleEval (ExitException code) = io (exitWith code)
625 handleEval e = do handler e
626 io (exitWith (ExitFailure 1))
628 doCommand (':' : command) = specialCommand command
630 = do r <- runStmt stmt GHC.RunToCompletion
632 False -> io (exitWith (ExitFailure 1))
633 -- failure to run the command causes exit(1) for ghc -e.
636 runStmt :: String -> SingleStep -> GHCi Bool
638 | null (filter (not.isSpace) stmt) = return False
639 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
641 = do st <- getGHCiState
642 session <- getSession
643 result <- io $ withProgName (progname st) $ withArgs (args st) $
644 GHC.runStmt session stmt step
645 afterRunStmt (const True) result
648 --afterRunStmt :: GHC.RunResult -> GHCi Bool
649 -- False <=> the statement failed to compile
650 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
651 afterRunStmt _ (GHC.RunException e) = throw e
652 afterRunStmt step_here run_result = do
653 session <- getSession
654 resumes <- io $ GHC.getResumeContext session
656 GHC.RunOk names -> do
657 show_types <- isOptionSet ShowType
658 when show_types $ printTypeOfNames session names
659 GHC.RunBreak _ names mb_info
660 | isNothing mb_info ||
661 step_here (GHC.resumeSpan $ head resumes) -> do
662 printForUser $ ptext SLIT("Stopped at") <+>
663 ppr (GHC.resumeSpan $ head resumes)
664 -- printTypeOfNames session names
665 let namesSorted = sortBy compareNames names
666 tythings <- catMaybes `liftM`
667 io (mapM (GHC.lookupName session) namesSorted)
668 docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
669 printForUserPartWay docs
670 maybe (return ()) runBreakCmd mb_info
671 -- run the command set with ":set stop <cmd>"
673 enqueueCommands [stop st]
675 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
676 afterRunStmt step_here >> return ()
680 io installSignalHandlers
681 b <- isOptionSet RevertCAFs
682 io (when b revertCAFs)
684 return (case run_result of GHC.RunOk _ -> True; _ -> False)
686 runBreakCmd :: GHC.BreakInfo -> GHCi ()
687 runBreakCmd info = do
688 let mod = GHC.breakInfo_module info
689 nm = GHC.breakInfo_number info
691 case [ loc | (_,loc) <- breaks st,
692 breakModule loc == mod, breakTick loc == nm ] of
694 loc:_ | null cmd -> return ()
695 | otherwise -> do enqueueCommands [cmd]; return ()
696 where cmd = onBreakCmd loc
698 printTypeOfNames :: Session -> [Name] -> GHCi ()
699 printTypeOfNames session names
700 = mapM_ (printTypeOfName session) $ sortBy compareNames names
702 compareNames :: Name -> Name -> Ordering
703 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
704 where compareWith n = (getOccString n, getSrcSpan n)
706 printTypeOfName :: Session -> Name -> GHCi ()
707 printTypeOfName session n
708 = do maybe_tything <- io (GHC.lookupName session n)
709 case maybe_tything of
711 Just thing -> printTyThing thing
716 specialCommand :: String -> GHCi Bool
717 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
718 specialCommand str = do
719 let (cmd,rest) = break isSpace str
720 maybe_cmd <- io (lookupCommand cmd)
722 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
723 ++ shortHelpText) >> return False)
724 Just (_,f,_,_) -> f (dropWhile isSpace rest)
726 lookupCommand :: String -> IO (Maybe Command)
727 lookupCommand str = do
728 macros <- readIORef macros_ref
729 let cmds = builtin_commands ++ macros
730 -- look for exact match first, then the first prefix match
731 case [ c | c <- cmds, str == cmdName c ] of
732 c:_ -> return (Just c)
733 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
735 c:_ -> return (Just c)
738 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
739 getCurrentBreakSpan = do
740 session <- getSession
741 resumes <- io $ GHC.getResumeContext session
745 let ix = GHC.resumeHistoryIx r
747 then return (Just (GHC.resumeSpan r))
749 let hist = GHC.resumeHistory r !! (ix-1)
750 span <- io $ GHC.getHistorySpan session hist
753 getCurrentBreakModule :: GHCi (Maybe Module)
754 getCurrentBreakModule = do
755 session <- getSession
756 resumes <- io $ GHC.getResumeContext session
760 let ix = GHC.resumeHistoryIx r
762 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
764 let hist = GHC.resumeHistory r !! (ix-1)
765 return $ Just $ GHC.getHistoryModule hist
767 -----------------------------------------------------------------------------
770 noArgs :: GHCi () -> String -> GHCi ()
772 noArgs _ _ = io $ putStrLn "This command takes no arguments"
774 help :: String -> GHCi ()
775 help _ = io (putStr helpText)
777 info :: String -> GHCi ()
778 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
779 info s = do { let names = words s
780 ; session <- getSession
781 ; dflags <- getDynFlags
782 ; let pefas = dopt Opt_PrintExplicitForalls dflags
783 ; mapM_ (infoThing pefas session) names }
785 infoThing pefas session str = io $ do
786 names <- GHC.parseName session str
787 mb_stuffs <- mapM (GHC.getInfo session) names
788 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
789 unqual <- GHC.getPrintUnqual session
790 putStrLn (showSDocForUser unqual $
791 vcat (intersperse (text "") $
792 map (pprInfo pefas) filtered))
794 -- Filter out names whose parent is also there Good
795 -- example is '[]', which is both a type and data
796 -- constructor in the same type
797 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
798 filterOutChildren get_thing xs
799 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
801 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
803 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
804 pprInfo pefas (thing, fixity, insts)
805 = pprTyThingInContextLoc pefas thing
806 $$ show_fixity fixity
807 $$ vcat (map GHC.pprInstance insts)
810 | fix == GHC.defaultFixity = empty
811 | otherwise = ppr fix <+> ppr (GHC.getName thing)
813 runMain :: String -> GHCi ()
815 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
816 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
818 addModule :: [FilePath] -> GHCi ()
820 io (revertCAFs) -- always revert CAFs on load/add.
821 files <- mapM expandPath files
822 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
823 session <- getSession
824 io (mapM_ (GHC.addTarget session) targets)
825 prev_context <- io $ GHC.getContext session
826 ok <- io (GHC.load session LoadAllTargets)
827 afterLoad ok session False prev_context
829 changeDirectory :: String -> GHCi ()
830 changeDirectory dir = do
831 session <- getSession
832 graph <- io (GHC.getModuleGraph session)
833 when (not (null graph)) $
834 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
835 prev_context <- io $ GHC.getContext session
836 io (GHC.setTargets session [])
837 io (GHC.load session LoadAllTargets)
838 setContextAfterLoad session prev_context []
839 io (GHC.workingDirectoryChanged session)
840 dir <- expandPath dir
841 io (setCurrentDirectory dir)
843 editFile :: String -> GHCi ()
845 do file <- if null str then chooseEditFile else return str
849 $ throwDyn (CmdLineError "editor not set, use :set editor")
850 io $ system (cmd ++ ' ':file)
853 -- The user didn't specify a file so we pick one for them.
854 -- Our strategy is to pick the first module that failed to load,
855 -- or otherwise the first target.
857 -- XXX: Can we figure out what happened if the depndecy analysis fails
858 -- (e.g., because the porgrammeer mistyped the name of a module)?
859 -- XXX: Can we figure out the location of an error to pass to the editor?
860 -- XXX: if we could figure out the list of errors that occured during the
861 -- last load/reaload, then we could start the editor focused on the first
863 chooseEditFile :: GHCi String
865 do session <- getSession
866 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
868 graph <- io (GHC.getModuleGraph session)
869 failed_graph <- filterM hasFailed graph
870 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
872 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
875 case pick (order failed_graph) of
876 Just file -> return file
878 do targets <- io (GHC.getTargets session)
879 case msum (map fromTarget targets) of
880 Just file -> return file
881 Nothing -> throwDyn (CmdLineError "No files to edit.")
883 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
884 fromTarget _ = Nothing -- when would we get a module target?
886 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
887 defineMacro overwrite s = do
888 let (macro_name, definition) = break isSpace s
889 macros <- io (readIORef macros_ref)
890 let defined = map cmdName macros
893 then io $ putStrLn "no macros defined"
894 else io $ putStr ("the following macros are defined:\n" ++
897 if (not overwrite && macro_name `elem` defined)
898 then throwDyn (CmdLineError
899 ("macro '" ++ macro_name ++ "' is already defined"))
902 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
904 -- give the expression a type signature, so we can be sure we're getting
905 -- something of the right type.
906 let new_expr = '(' : definition ++ ") :: String -> IO String"
908 -- compile the expression
910 maybe_hv <- io (GHC.compileExpr cms new_expr)
913 Just hv -> io (writeIORef macros_ref --
914 (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
916 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
918 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
919 enqueueCommands (lines str)
922 undefineMacro :: String -> GHCi ()
923 undefineMacro str = mapM_ undef (words str)
924 where undef macro_name = do
925 cmds <- io (readIORef macros_ref)
926 if (macro_name `notElem` map cmdName cmds)
927 then throwDyn (CmdLineError
928 ("macro '" ++ macro_name ++ "' is not defined"))
930 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
932 cmdCmd :: String -> GHCi ()
934 let expr = '(' : str ++ ") :: IO String"
935 session <- getSession
936 maybe_hv <- io (GHC.compileExpr session expr)
940 cmds <- io $ (unsafeCoerce# hv :: IO String)
941 enqueueCommands (lines cmds)
944 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
945 loadModule fs = timeIt (loadModule' fs)
947 loadModule_ :: [FilePath] -> GHCi ()
948 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
950 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
951 loadModule' files = do
952 session <- getSession
953 prev_context <- io $ GHC.getContext session
956 discardActiveBreakPoints
957 io (GHC.setTargets session [])
958 io (GHC.load session LoadAllTargets)
961 let (filenames, phases) = unzip files
962 exp_filenames <- mapM expandPath filenames
963 let files' = zip exp_filenames phases
964 targets <- io (mapM (uncurry GHC.guessTarget) files')
966 -- NOTE: we used to do the dependency anal first, so that if it
967 -- fails we didn't throw away the current set of modules. This would
968 -- require some re-working of the GHC interface, so we'll leave it
969 -- as a ToDo for now.
971 io (GHC.setTargets session targets)
972 doLoad session False prev_context LoadAllTargets
974 checkModule :: String -> GHCi ()
976 let modl = GHC.mkModuleName m
977 session <- getSession
978 prev_context <- io $ GHC.getContext session
979 result <- io (GHC.checkModule session modl False)
981 Nothing -> io $ putStrLn "Nothing"
982 Just r -> io $ putStrLn (showSDoc (
983 case GHC.checkedModuleInfo r of
984 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
986 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
988 (text "global names: " <+> ppr global) $$
989 (text "local names: " <+> ppr local)
991 afterLoad (successIf (isJust result)) session False prev_context
993 reloadModule :: String -> GHCi ()
995 session <- getSession
996 prev_context <- io $ GHC.getContext session
997 doLoad session True prev_context $
998 if null m then LoadAllTargets
999 else LoadUpTo (GHC.mkModuleName m)
1002 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1003 doLoad session retain_context prev_context howmuch = do
1004 -- turn off breakpoints before we load: we can't turn them off later, because
1005 -- the ModBreaks will have gone away.
1006 discardActiveBreakPoints
1007 ok <- io (GHC.load session howmuch)
1008 afterLoad ok session retain_context prev_context
1011 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1012 afterLoad ok session retain_context prev_context = do
1013 io (revertCAFs) -- always revert CAFs on load.
1015 loaded_mod_summaries <- getLoadedModules session
1016 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1017 loaded_mod_names = map GHC.moduleName loaded_mods
1018 modulesLoadedMsg ok loaded_mod_names
1021 if not retain_context
1023 setGHCiState st{ remembered_ctx = Nothing }
1024 setContextAfterLoad session prev_context loaded_mod_summaries
1026 -- figure out which modules we can keep in the context, which we
1027 -- have to put back, and which we have to remember because they
1028 -- are (temporarily) unavailable. See ghci.prog009, #1873, #1360
1029 let (as,bs) = prev_context
1030 as1 = filter isHomeModule as -- package modules are kept anyway
1031 bs1 = filter isHomeModule bs
1032 (as_ok, as_bad) = partition (`elem` loaded_mods) as1
1033 (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1
1034 (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st)
1035 (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as
1036 (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs
1037 as' = nub (as_ok++rem_as_ok)
1038 bs' = nub (bs_ok++rem_bs_ok)
1039 rem_as' = nub (rem_as_bad ++ as_bad)
1040 rem_bs' = nub (rem_bs_bad ++ bs_bad)
1042 -- Put back into the context any modules that we previously had
1043 -- to drop because they weren't available (rem_as_ok, rem_bs_ok).
1044 setContextKeepingPackageModules session prev_context (as',bs')
1046 -- If compilation failed, remember any modules that we are unable
1047 -- to load, so that we can put them back in the context in the future.
1049 Succeeded -> setGHCiState st{ remembered_ctx = Nothing }
1050 Failed -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') }
1054 setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi ()
1055 setContextAfterLoad session prev [] = do
1056 prel_mod <- getPrelude
1057 setContextKeepingPackageModules session prev ([], [prel_mod])
1058 setContextAfterLoad session prev ms = do
1059 -- load a target if one is available, otherwise load the topmost module.
1060 targets <- io (GHC.getTargets session)
1061 case [ m | Just m <- map (findTarget ms) targets ] of
1063 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1064 load_this (last graph')
1069 = case filter (`matches` t) ms of
1073 summary `matches` Target (TargetModule m) _
1074 = GHC.ms_mod_name summary == m
1075 summary `matches` Target (TargetFile f _) _
1076 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1080 load_this summary | m <- GHC.ms_mod summary = do
1081 b <- io (GHC.moduleIsInterpreted session m)
1082 if b then setContextKeepingPackageModules session prev ([m], [])
1084 prel_mod <- getPrelude
1085 setContextKeepingPackageModules session prev ([],[prel_mod,m])
1087 -- | Keep any package modules (except Prelude) when changing the context.
1088 setContextKeepingPackageModules
1090 -> ([Module],[Module]) -- previous context
1091 -> ([Module],[Module]) -- new context
1093 setContextKeepingPackageModules session prev_context (as,bs) = do
1094 let (_,bs0) = prev_context
1095 prel_mod <- getPrelude
1096 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1097 let bs1 = if null as then nub (prel_mod : bs) else bs
1098 io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1100 isHomeModule :: Module -> Bool
1101 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1103 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1104 modulesLoadedMsg ok mods = do
1105 dflags <- getDynFlags
1106 when (verbosity dflags > 0) $ do
1108 | null mods = text "none."
1109 | otherwise = hsep (
1110 punctuate comma (map ppr mods)) <> text "."
1113 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1115 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1118 typeOfExpr :: String -> GHCi ()
1120 = do cms <- getSession
1121 maybe_ty <- io (GHC.exprType cms str)
1123 Nothing -> return ()
1124 Just ty -> do dflags <- getDynFlags
1125 let pefas = dopt Opt_PrintExplicitForalls dflags
1126 printForUser $ text str <+> dcolon
1127 <+> pprTypeForUser pefas ty
1129 kindOfType :: String -> GHCi ()
1131 = do cms <- getSession
1132 maybe_ty <- io (GHC.typeKind cms str)
1134 Nothing -> return ()
1135 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1137 quit :: String -> GHCi Bool
1138 quit _ = return True
1140 shellEscape :: String -> GHCi Bool
1141 shellEscape str = io (system str >> return False)
1143 -----------------------------------------------------------------------------
1144 -- Browsing a module's contents
1146 browseCmd :: Bool -> String -> GHCi ()
1149 ['*':s] | looksLikeModuleName s -> do
1150 m <- wantInterpretedModule s
1151 browseModule bang m False
1152 [s] | looksLikeModuleName s -> do
1154 browseModule bang m True
1157 (as,bs) <- io $ GHC.getContext s
1158 -- Guess which module the user wants to browse. Pick
1159 -- modules that are interpreted first. The most
1160 -- recently-added module occurs last, it seems.
1162 (as@(_:_), _) -> browseModule bang (last as) True
1163 ([], bs@(_:_)) -> browseModule bang (last bs) True
1164 ([], []) -> throwDyn (CmdLineError ":browse: no current module")
1165 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1167 -- without bang, show items in context of their parents and omit children
1168 -- with bang, show class methods and data constructors separately, and
1169 -- indicate import modules, to aid qualifying unqualified names
1170 -- with sorted, sort items alphabetically
1171 browseModule :: Bool -> Module -> Bool -> GHCi ()
1172 browseModule bang modl exports_only = do
1174 -- :browse! reports qualifiers wrt current context
1175 current_unqual <- io (GHC.getPrintUnqual s)
1176 -- Temporarily set the context to the module we're interested in,
1177 -- just so we can get an appropriate PrintUnqualified
1178 (as,bs) <- io (GHC.getContext s)
1179 prel_mod <- getPrelude
1180 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1181 else GHC.setContext s [modl] [])
1182 target_unqual <- io (GHC.getPrintUnqual s)
1183 io (GHC.setContext s as bs)
1185 let unqual = if bang then current_unqual else target_unqual
1187 mb_mod_info <- io $ GHC.getModuleInfo s modl
1189 Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1190 GHC.moduleNameString (GHC.moduleName modl)))
1192 dflags <- getDynFlags
1194 | exports_only = GHC.modInfoExports mod_info
1195 | otherwise = GHC.modInfoTopLevelScope mod_info
1198 -- sort alphabetically name, but putting
1199 -- locally-defined identifiers first.
1200 -- We would like to improve this; see #1799.
1201 sorted_names = loc_sort local ++ occ_sort external
1203 (local,external) = partition ((==modl) . nameModule) names
1204 occ_sort = sortBy (compare `on` nameOccName)
1205 -- try to sort by src location. If the first name in
1206 -- our list has a good source location, then they all should.
1208 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1209 = sortBy (compare `on` nameSrcSpan) names
1213 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1214 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1216 rdr_env <- io $ GHC.getGRE s
1218 let pefas = dopt Opt_PrintExplicitForalls dflags
1219 things | bang = catMaybes mb_things
1220 | otherwise = filtered_things
1221 pretty | bang = pprTyThing
1222 | otherwise = pprTyThingInContext
1224 labels [] = text "-- not currently imported"
1225 labels l = text $ intercalate "\n" $ map qualifier l
1226 qualifier = maybe "-- defined locally"
1227 (("-- imported via "++) . intercalate ", "
1228 . map GHC.moduleNameString)
1229 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1230 modNames = map (importInfo . GHC.getName) things
1232 -- annotate groups of imports with their import modules
1233 -- the default ordering is somewhat arbitrary, so we group
1234 -- by header and sort groups; the names themselves should
1235 -- really come in order of source appearance.. (trac #1799)
1236 annotate mts = concatMap (\(m,ts)->labels m:ts)
1237 $ sortBy cmpQualifiers $ group mts
1238 where cmpQualifiers =
1239 compare `on` (map (fmap (map moduleNameFS)) . fst)
1241 group mts@((m,_):_) = (m,map snd g) : group ng
1242 where (g,ng) = partition ((==m).fst) mts
1244 let prettyThings = map (pretty pefas) things
1245 prettyThings' | bang = annotate $ zip modNames prettyThings
1246 | otherwise = prettyThings
1247 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1248 -- ToDo: modInfoInstances currently throws an exception for
1249 -- package modules. When it works, we can do this:
1250 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1252 -----------------------------------------------------------------------------
1253 -- Setting the module context
1255 setContext :: String -> GHCi ()
1257 | all sensible mods = fn mods
1258 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1260 (fn, mods) = case str of
1261 '+':stuff -> (addToContext, words stuff)
1262 '-':stuff -> (removeFromContext, words stuff)
1263 stuff -> (newContext, words stuff)
1265 sensible ('*':m) = looksLikeModuleName m
1266 sensible m = looksLikeModuleName m
1268 separate :: Session -> [String] -> [Module] -> [Module]
1269 -> GHCi ([Module],[Module])
1270 separate _ [] as bs = return (as,bs)
1271 separate session (('*':str):ms) as bs = do
1272 m <- wantInterpretedModule str
1273 separate session ms (m:as) bs
1274 separate session (str:ms) as bs = do
1275 m <- lookupModule str
1276 separate session ms as (m:bs)
1278 newContext :: [String] -> GHCi ()
1279 newContext strs = do
1281 (as,bs) <- separate s strs [] []
1282 prel_mod <- getPrelude
1283 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1284 io $ GHC.setContext s as bs'
1287 addToContext :: [String] -> GHCi ()
1288 addToContext strs = do
1290 (as,bs) <- io $ GHC.getContext s
1292 (new_as,new_bs) <- separate s strs [] []
1294 let as_to_add = new_as \\ (as ++ bs)
1295 bs_to_add = new_bs \\ (as ++ bs)
1297 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1300 removeFromContext :: [String] -> GHCi ()
1301 removeFromContext strs = do
1303 (as,bs) <- io $ GHC.getContext s
1305 (as_to_remove,bs_to_remove) <- separate s strs [] []
1307 let as' = as \\ (as_to_remove ++ bs_to_remove)
1308 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1310 io $ GHC.setContext s as' bs'
1312 ----------------------------------------------------------------------------
1315 -- set options in the interpreter. Syntax is exactly the same as the
1316 -- ghc command line, except that certain options aren't available (-C,
1319 -- This is pretty fragile: most options won't work as expected. ToDo:
1320 -- figure out which ones & disallow them.
1322 setCmd :: String -> GHCi ()
1324 = do st <- getGHCiState
1325 let opts = options st
1326 io $ putStrLn (showSDoc (
1327 text "options currently set: " <>
1330 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1332 dflags <- getDynFlags
1333 io $ putStrLn (showSDoc (
1334 vcat (text "GHCi-specific dynamic flag settings:"
1335 :map (flagSetting dflags) ghciFlags)
1337 io $ putStrLn (showSDoc (
1338 vcat (text "other dynamic, non-language, flag settings:"
1339 :map (flagSetting dflags) nonLanguageDynFlags)
1341 where flagSetting dflags (str,f)
1342 | dopt f dflags = text " " <> text "-f" <> text str
1343 | otherwise = text " " <> text "-fno-" <> text str
1344 (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
1346 nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1348 flags = [Opt_PrintExplicitForalls
1349 ,Opt_PrintBindResult
1350 ,Opt_BreakOnException
1352 ,Opt_PrintEvldWithShow
1355 = case toArgs str of
1356 ("args":args) -> setArgs args
1357 ("prog":prog) -> setProg prog
1358 ("prompt":_) -> setPrompt (after 6)
1359 ("editor":_) -> setEditor (after 6)
1360 ("stop":_) -> setStop (after 4)
1361 wds -> setOptions wds
1362 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1364 setArgs, setProg, setOptions :: [String] -> GHCi ()
1365 setEditor, setStop, setPrompt :: String -> GHCi ()
1369 setGHCiState st{ args = args }
1373 setGHCiState st{ progname = prog }
1375 io (hPutStrLn stderr "syntax: :set prog <progname>")
1379 setGHCiState st{ editor = cmd }
1381 setStop str@(c:_) | isDigit c
1382 = do let (nm_str,rest) = break (not.isDigit) str
1385 let old_breaks = breaks st
1386 if all ((/= nm) . fst) old_breaks
1387 then printForUser (text "Breakpoint" <+> ppr nm <+>
1388 text "does not exist")
1390 let new_breaks = map fn old_breaks
1391 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1392 | otherwise = (i,loc)
1393 setGHCiState st{ breaks = new_breaks }
1396 setGHCiState st{ stop = cmd }
1398 setPrompt value = do
1401 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1402 else setGHCiState st{ prompt = remQuotes value }
1404 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1408 do -- first, deal with the GHCi opts (+s, +t, etc.)
1409 let (plus_opts, minus_opts) = partitionWith isPlus wds
1410 mapM_ setOpt plus_opts
1411 -- then, dynamic flags
1412 newDynFlags minus_opts
1414 newDynFlags :: [String] -> GHCi ()
1415 newDynFlags minus_opts = do
1416 dflags <- getDynFlags
1417 let pkg_flags = packageFlags dflags
1418 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1420 if (not (null leftovers))
1421 then throwDyn (CmdLineError ("unrecognised flags: " ++
1425 new_pkgs <- setDynFlags dflags'
1427 -- if the package flags changed, we should reset the context
1428 -- and link the new packages.
1429 dflags <- getDynFlags
1430 when (packageFlags dflags /= pkg_flags) $ do
1431 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1432 session <- getSession
1433 io (GHC.setTargets session [])
1434 io (GHC.load session LoadAllTargets)
1435 io (linkPackages dflags new_pkgs)
1436 -- package flags changed, we can't re-use any of the old context
1437 setContextAfterLoad session ([],[]) []
1441 unsetOptions :: String -> GHCi ()
1443 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1444 let opts = words str
1445 (minus_opts, rest1) = partition isMinus opts
1446 (plus_opts, rest2) = partitionWith isPlus rest1
1448 if (not (null rest2))
1449 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1452 mapM_ unsetOpt plus_opts
1454 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1455 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1457 no_flags <- mapM no_flag minus_opts
1458 newDynFlags no_flags
1460 isMinus :: String -> Bool
1461 isMinus ('-':_) = True
1464 isPlus :: String -> Either String String
1465 isPlus ('+':opt) = Left opt
1466 isPlus other = Right other
1468 setOpt, unsetOpt :: String -> GHCi ()
1471 = case strToGHCiOpt str of
1472 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1473 Just o -> setOption o
1476 = case strToGHCiOpt str of
1477 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1478 Just o -> unsetOption o
1480 strToGHCiOpt :: String -> (Maybe GHCiOption)
1481 strToGHCiOpt "s" = Just ShowTiming
1482 strToGHCiOpt "t" = Just ShowType
1483 strToGHCiOpt "r" = Just RevertCAFs
1484 strToGHCiOpt _ = Nothing
1486 optToStr :: GHCiOption -> String
1487 optToStr ShowTiming = "s"
1488 optToStr ShowType = "t"
1489 optToStr RevertCAFs = "r"
1491 -- ---------------------------------------------------------------------------
1494 showCmd :: String -> GHCi ()
1498 ["args"] -> io $ putStrLn (show (args st))
1499 ["prog"] -> io $ putStrLn (show (progname st))
1500 ["prompt"] -> io $ putStrLn (show (prompt st))
1501 ["editor"] -> io $ putStrLn (show (editor st))
1502 ["stop"] -> io $ putStrLn (show (stop st))
1503 ["modules" ] -> showModules
1504 ["bindings"] -> showBindings
1505 ["linker"] -> io showLinkerState
1506 ["breaks"] -> showBkptTable
1507 ["context"] -> showContext
1508 ["packages"] -> showPackages
1509 ["languages"] -> showLanguages
1510 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1512 showModules :: GHCi ()
1514 session <- getSession
1515 loaded_mods <- getLoadedModules session
1516 -- we want *loaded* modules only, see #1734
1517 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1518 mapM_ show_one loaded_mods
1520 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1521 getLoadedModules session = do
1522 graph <- io (GHC.getModuleGraph session)
1523 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1525 showBindings :: GHCi ()
1528 bindings <- io (GHC.getBindings s)
1529 docs <- io$ pprTypeAndContents s
1530 [ id | AnId id <- sortBy compareTyThings bindings]
1531 printForUserPartWay docs
1533 compareTyThings :: TyThing -> TyThing -> Ordering
1534 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1536 printTyThing :: TyThing -> GHCi ()
1537 printTyThing tyth = do dflags <- getDynFlags
1538 let pefas = dopt Opt_PrintExplicitForalls dflags
1539 printForUser (pprTyThing pefas tyth)
1541 showBkptTable :: GHCi ()
1544 printForUser $ prettyLocations (breaks st)
1546 showContext :: GHCi ()
1548 session <- getSession
1549 resumes <- io $ GHC.getResumeContext session
1550 printForUser $ vcat (map pp_resume (reverse resumes))
1553 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1554 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1556 showPackages :: GHCi ()
1558 pkg_flags <- fmap packageFlags getDynFlags
1559 io $ putStrLn $ showSDoc $ vcat $
1560 text ("active package flags:"++if null pkg_flags then " none" else "")
1561 : map showFlag pkg_flags
1562 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1563 io $ putStrLn $ showSDoc $ vcat $
1564 text "packages currently loaded:"
1565 : map (nest 2 . text . packageIdString) pkg_ids
1566 where showFlag (ExposePackage p) = text $ " -package " ++ p
1567 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1568 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1570 showLanguages :: GHCi ()
1572 dflags <- getDynFlags
1573 io $ putStrLn $ showSDoc $ vcat $
1574 text "active language flags:" :
1575 [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1577 -- -----------------------------------------------------------------------------
1580 completeNone :: String -> IO [String]
1581 completeNone _w = return []
1583 completeMacro, completeIdentifier, completeModule,
1584 completeHomeModule, completeSetOptions, completeFilename,
1585 completeHomeModuleOrFile
1586 :: String -> IO [String]
1589 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1590 completeWord w start end = do
1591 line <- Readline.getLineBuffer
1592 let line_words = words (dropWhile isSpace line)
1594 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1596 | ((':':c) : _) <- line_words -> do
1597 maybe_cmd <- lookupCommand c
1598 let (n,w') = selectWord (words' 0 line)
1600 Nothing -> return Nothing
1601 Just (_,_,False,complete) -> wrapCompleter complete w
1602 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1603 return (map (drop n) rets)
1604 in wrapCompleter complete' w'
1605 | ("import" : _) <- line_words ->
1606 wrapCompleter completeModule w
1608 --printf "complete %s, start = %d, end = %d\n" w start end
1609 wrapCompleter completeIdentifier w
1610 where words' _ [] = []
1611 words' n str = let (w,r) = break isSpace str
1612 (s,r') = span isSpace r
1613 in (n,w):words' (n+length w+length s) r'
1614 -- In a Haskell expression we want to parse 'a-b' as three words
1615 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1616 -- only be a single word.
1617 selectWord [] = (0,w)
1618 selectWord ((offset,x):xs)
1619 | offset+length x >= start = (start-offset,take (end-offset) x)
1620 | otherwise = selectWord xs
1622 completeCmd :: String -> IO [String]
1624 cmds <- readIORef macros_ref
1625 return (filter (w `isPrefixOf`) (map (':':)
1626 (map cmdName (builtin_commands ++ cmds))))
1628 completeMacro w = do
1629 cmds <- readIORef macros_ref
1630 return (filter (w `isPrefixOf`) (map cmdName cmds))
1632 completeIdentifier w = do
1634 rdrs <- GHC.getRdrNamesInScope s
1635 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1637 completeModule w = do
1639 dflags <- GHC.getSessionDynFlags s
1640 let pkg_mods = allExposedModules dflags
1641 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1643 completeHomeModule w = do
1645 g <- GHC.getModuleGraph s
1646 let home_mods = map GHC.ms_mod_name g
1647 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1649 completeSetOptions w = do
1650 return (filter (w `isPrefixOf`) options)
1651 where options = "args":"prog":allFlags
1653 completeFilename = Readline.filenameCompletionFunction
1655 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1657 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1658 unionComplete f1 f2 w = do
1663 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1664 wrapCompleter fun w = do
1667 [] -> return Nothing
1668 [x] -> return (Just (x,[]))
1669 xs -> case getCommonPrefix xs of
1670 "" -> return (Just ("",xs))
1671 pref -> return (Just (pref,xs))
1673 getCommonPrefix :: [String] -> String
1674 getCommonPrefix [] = ""
1675 getCommonPrefix (s:ss) = foldl common s ss
1676 where common _s "" = ""
1678 common (c:cs) (d:ds)
1679 | c == d = c : common cs ds
1682 allExposedModules :: DynFlags -> [ModuleName]
1683 allExposedModules dflags
1684 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1686 pkg_db = pkgIdMap (pkgState dflags)
1688 completeMacro = completeNone
1689 completeIdentifier = completeNone
1690 completeModule = completeNone
1691 completeHomeModule = completeNone
1692 completeSetOptions = completeNone
1693 completeFilename = completeNone
1694 completeHomeModuleOrFile=completeNone
1697 -- ---------------------------------------------------------------------------
1698 -- User code exception handling
1700 -- This is the exception handler for exceptions generated by the
1701 -- user's code and exceptions coming from children sessions;
1702 -- it normally just prints out the exception. The
1703 -- handler must be recursive, in case showing the exception causes
1704 -- more exceptions to be raised.
1706 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1707 -- raising another exception. We therefore don't put the recursive
1708 -- handler arond the flushing operation, so if stderr is closed
1709 -- GHCi will just die gracefully rather than going into an infinite loop.
1710 handler :: Exception -> GHCi Bool
1712 handler exception = do
1714 io installSignalHandlers
1715 ghciHandle handler (showException exception >> return False)
1717 showException :: Exception -> GHCi ()
1718 showException (DynException dyn) =
1719 case fromDynamic dyn of
1720 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1721 Just Interrupted -> io (putStrLn "Interrupted.")
1722 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1723 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1724 Just other_ghc_ex -> io (print other_ghc_ex)
1726 showException other_exception
1727 = io (putStrLn ("*** Exception: " ++ show other_exception))
1729 -----------------------------------------------------------------------------
1730 -- recursive exception handlers
1732 -- Don't forget to unblock async exceptions in the handler, or if we're
1733 -- in an exception loop (eg. let a = error a in a) the ^C exception
1734 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1736 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1737 ghciHandle h (GHCi m) = GHCi $ \s ->
1738 Exception.catch (m s)
1739 (\e -> unGHCi (ghciUnblock (h e)) s)
1741 ghciUnblock :: GHCi a -> GHCi a
1742 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1745 -- ----------------------------------------------------------------------------
1748 expandPath :: String -> GHCi String
1750 case dropWhile isSpace path of
1752 tilde <- io getHomeDirectory -- will fail if HOME not defined
1753 return (tilde ++ '/':d)
1757 wantInterpretedModule :: String -> GHCi Module
1758 wantInterpretedModule str = do
1759 session <- getSession
1760 modl <- lookupModule str
1761 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1762 when (not is_interpreted) $
1763 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1766 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1767 -> (Name -> GHCi ())
1769 wantNameFromInterpretedModule noCanDo str and_then = do
1770 session <- getSession
1771 names <- io $ GHC.parseName session str
1775 let modl = GHC.nameModule n
1776 if not (GHC.isExternalName n)
1777 then noCanDo n $ ppr n <>
1778 text " is not defined in an interpreted module"
1780 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1781 if not is_interpreted
1782 then noCanDo n $ text "module " <> ppr modl <>
1783 text " is not interpreted"
1786 -- -----------------------------------------------------------------------------
1787 -- commands for debugger
1789 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1790 sprintCmd = pprintCommand False False
1791 printCmd = pprintCommand True False
1792 forceCmd = pprintCommand False True
1794 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1795 pprintCommand bind force str = do
1796 session <- getSession
1797 io $ pprintClosureCommand session bind force str
1799 stepCmd :: String -> GHCi ()
1800 stepCmd [] = doContinue (const True) GHC.SingleStep
1801 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1803 stepLocalCmd :: String -> GHCi ()
1804 stepLocalCmd [] = do
1805 mb_span <- getCurrentBreakSpan
1807 Nothing -> stepCmd []
1809 Just mod <- getCurrentBreakModule
1810 current_toplevel_decl <- enclosingTickSpan mod loc
1811 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1813 stepLocalCmd expression = stepCmd expression
1815 stepModuleCmd :: String -> GHCi ()
1816 stepModuleCmd [] = do
1817 mb_span <- getCurrentBreakSpan
1819 Nothing -> stepCmd []
1821 Just span <- getCurrentBreakSpan
1822 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1823 doContinue f GHC.SingleStep
1825 stepModuleCmd expression = stepCmd expression
1827 -- | Returns the span of the largest tick containing the srcspan given
1828 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1829 enclosingTickSpan mod src = do
1830 ticks <- getTickArray mod
1831 let line = srcSpanStartLine src
1832 ASSERT (inRange (bounds ticks) line) do
1833 let enclosing_spans = [ span | (_,span) <- ticks ! line
1834 , srcSpanEnd span >= srcSpanEnd src]
1835 return . head . sortBy leftmost_largest $ enclosing_spans
1837 traceCmd :: String -> GHCi ()
1838 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1839 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1841 continueCmd :: String -> GHCi ()
1842 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1844 -- doContinue :: SingleStep -> GHCi ()
1845 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1846 doContinue pred step = do
1847 session <- getSession
1848 runResult <- io $ GHC.resume session step
1849 afterRunStmt pred runResult
1852 abandonCmd :: String -> GHCi ()
1853 abandonCmd = noArgs $ do
1855 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1856 when (not b) $ io $ putStrLn "There is no computation running."
1859 deleteCmd :: String -> GHCi ()
1860 deleteCmd argLine = do
1861 deleteSwitch $ words argLine
1863 deleteSwitch :: [String] -> GHCi ()
1865 io $ putStrLn "The delete command requires at least one argument."
1866 -- delete all break points
1867 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1868 deleteSwitch idents = do
1869 mapM_ deleteOneBreak idents
1871 deleteOneBreak :: String -> GHCi ()
1873 | all isDigit str = deleteBreak (read str)
1874 | otherwise = return ()
1876 historyCmd :: String -> GHCi ()
1878 | null arg = history 20
1879 | all isDigit arg = history (read arg)
1880 | otherwise = io $ putStrLn "Syntax: :history [num]"
1884 resumes <- io $ GHC.getResumeContext s
1886 [] -> io $ putStrLn "Not stopped at a breakpoint"
1888 let hist = GHC.resumeHistory r
1889 (took,rest) = splitAt num hist
1890 spans <- mapM (io . GHC.getHistorySpan s) took
1891 let nums = map (printf "-%-3d:") [(1::Int)..]
1892 let names = map GHC.historyEnclosingDecl took
1893 printForUser (vcat(zipWith3
1894 (\x y z -> x <+> y <+> z)
1896 (map (bold . ppr) names)
1897 (map (parens . ppr) spans)))
1898 io $ putStrLn $ if null rest then "<end of history>" else "..."
1900 bold :: SDoc -> SDoc
1901 bold c | do_bold = text start_bold <> c <> text end_bold
1904 backCmd :: String -> GHCi ()
1905 backCmd = noArgs $ do
1907 (names, _, span) <- io $ GHC.back s
1908 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1909 printTypeOfNames s names
1910 -- run the command set with ":set stop <cmd>"
1912 enqueueCommands [stop st]
1914 forwardCmd :: String -> GHCi ()
1915 forwardCmd = noArgs $ do
1917 (names, ix, span) <- io $ GHC.forward s
1918 printForUser $ (if (ix == 0)
1919 then ptext SLIT("Stopped at")
1920 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1921 printTypeOfNames s names
1922 -- run the command set with ":set stop <cmd>"
1924 enqueueCommands [stop st]
1926 -- handle the "break" command
1927 breakCmd :: String -> GHCi ()
1928 breakCmd argLine = do
1929 session <- getSession
1930 breakSwitch session $ words argLine
1932 breakSwitch :: Session -> [String] -> GHCi ()
1933 breakSwitch _session [] = do
1934 io $ putStrLn "The break command requires at least one argument."
1935 breakSwitch session (arg1:rest)
1936 | looksLikeModuleName arg1 = do
1937 mod <- wantInterpretedModule arg1
1938 breakByModule mod rest
1939 | all isDigit arg1 = do
1940 (toplevel, _) <- io $ GHC.getContext session
1942 (mod : _) -> breakByModuleLine mod (read arg1) rest
1944 io $ putStrLn "Cannot find default module for breakpoint."
1945 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1946 | otherwise = do -- try parsing it as an identifier
1947 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1948 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1949 if GHC.isGoodSrcLoc loc
1950 then findBreakAndSet (GHC.nameModule name) $
1951 findBreakByCoord (Just (GHC.srcLocFile loc))
1952 (GHC.srcLocLine loc,
1954 else noCanDo name $ text "can't find its location: " <> ppr loc
1956 noCanDo n why = printForUser $
1957 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1959 breakByModule :: Module -> [String] -> GHCi ()
1960 breakByModule mod (arg1:rest)
1961 | all isDigit arg1 = do -- looks like a line number
1962 breakByModuleLine mod (read arg1) rest
1966 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1967 breakByModuleLine mod line args
1968 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1969 | [col] <- args, all isDigit col =
1970 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1971 | otherwise = breakSyntax
1974 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1976 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1977 findBreakAndSet mod lookupTickTree = do
1978 tickArray <- getTickArray mod
1979 (breakArray, _) <- getModBreak mod
1980 case lookupTickTree tickArray of
1981 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1982 Just (tick, span) -> do
1983 success <- io $ setBreakFlag True breakArray tick
1987 recordBreak $ BreakLocation
1994 text "Breakpoint " <> ppr nm <>
1996 then text " was already set at " <> ppr span
1997 else text " activated at " <> ppr span
1999 printForUser $ text "Breakpoint could not be activated at"
2002 -- When a line number is specified, the current policy for choosing
2003 -- the best breakpoint is this:
2004 -- - the leftmost complete subexpression on the specified line, or
2005 -- - the leftmost subexpression starting on the specified line, or
2006 -- - the rightmost subexpression enclosing the specified line
2008 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2009 findBreakByLine line arr
2010 | not (inRange (bounds arr) line) = Nothing
2012 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2013 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2014 listToMaybe (sortBy (rightmost `on` snd) ticks)
2018 starts_here = [ tick | tick@(_,span) <- ticks,
2019 GHC.srcSpanStartLine span == line ]
2021 (complete,incomplete) = partition ends_here starts_here
2022 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2024 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2025 -> Maybe (BreakIndex,SrcSpan)
2026 findBreakByCoord mb_file (line, col) arr
2027 | not (inRange (bounds arr) line) = Nothing
2029 listToMaybe (sortBy (rightmost `on` snd) contains ++
2030 sortBy (leftmost_smallest `on` snd) after_here)
2034 -- the ticks that span this coordinate
2035 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2036 is_correct_file span ]
2038 is_correct_file span
2039 | Just f <- mb_file = GHC.srcSpanFile span == f
2042 after_here = [ tick | tick@(_,span) <- ticks,
2043 GHC.srcSpanStartLine span == line,
2044 GHC.srcSpanStartCol span >= col ]
2046 -- For now, use ANSI bold on terminals that we know support it.
2047 -- Otherwise, we add a line of carets under the active expression instead.
2048 -- In particular, on Windows and when running the testsuite (which sets
2049 -- TERM to vt100 for other reasons) we get carets.
2050 -- We really ought to use a proper termcap/terminfo library.
2052 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2053 where mTerm = System.Environment.getEnv "TERM"
2054 `Exception.catch` \_ -> return "TERM not set"
2056 start_bold :: String
2057 start_bold = "\ESC[1m"
2059 end_bold = "\ESC[0m"
2061 listCmd :: String -> GHCi ()
2063 mb_span <- getCurrentBreakSpan
2065 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
2066 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
2067 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
2068 listCmd str = list2 (words str)
2070 list2 :: [String] -> GHCi ()
2071 list2 [arg] | all isDigit arg = do
2072 session <- getSession
2073 (toplevel, _) <- io $ GHC.getContext session
2075 [] -> io $ putStrLn "No module to list"
2076 (mod : _) -> listModuleLine mod (read arg)
2077 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2078 mod <- wantInterpretedModule arg1
2079 listModuleLine mod (read arg2)
2081 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2082 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2083 if GHC.isGoodSrcLoc loc
2085 tickArray <- getTickArray (GHC.nameModule name)
2086 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2087 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2090 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2091 Just (_,span) -> io $ listAround span False
2093 noCanDo name $ text "can't find its location: " <>
2096 noCanDo n why = printForUser $
2097 text "cannot list source code for " <> ppr n <> text ": " <> why
2099 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2101 listModuleLine :: Module -> Int -> GHCi ()
2102 listModuleLine modl line = do
2103 session <- getSession
2104 graph <- io (GHC.getModuleGraph session)
2105 let this = filter ((== modl) . GHC.ms_mod) graph
2107 [] -> panic "listModuleLine"
2109 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2110 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2111 io $ listAround (GHC.srcLocSpan loc) False
2113 -- | list a section of a source file around a particular SrcSpan.
2114 -- If the highlight flag is True, also highlight the span using
2115 -- start_bold/end_bold.
2116 listAround :: SrcSpan -> Bool -> IO ()
2117 listAround span do_highlight = do
2118 contents <- BS.readFile (unpackFS file)
2120 lines = BS.split '\n' contents
2121 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2122 drop (line1 - 1 - pad_before) $ lines
2123 fst_line = max 1 (line1 - pad_before)
2124 line_nos = [ fst_line .. ]
2126 highlighted | do_highlight = zipWith highlight line_nos these_lines
2127 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2129 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2130 prefixed = zipWith ($) highlighted bs_line_nos
2132 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2134 file = GHC.srcSpanFile span
2135 line1 = GHC.srcSpanStartLine span
2136 col1 = GHC.srcSpanStartCol span
2137 line2 = GHC.srcSpanEndLine span
2138 col2 = GHC.srcSpanEndCol span
2140 pad_before | line1 == 1 = 0
2144 highlight | do_bold = highlight_bold
2145 | otherwise = highlight_carets
2147 highlight_bold no line prefix
2148 | no == line1 && no == line2
2149 = let (a,r) = BS.splitAt col1 line
2150 (b,c) = BS.splitAt (col2-col1) r
2152 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2154 = let (a,b) = BS.splitAt col1 line in
2155 BS.concat [prefix, a, BS.pack start_bold, b]
2157 = let (a,b) = BS.splitAt col2 line in
2158 BS.concat [prefix, a, BS.pack end_bold, b]
2159 | otherwise = BS.concat [prefix, line]
2161 highlight_carets no line prefix
2162 | no == line1 && no == line2
2163 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2164 BS.replicate (col2-col1) '^']
2166 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2169 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2171 | otherwise = BS.concat [prefix, line]
2173 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2174 nl = BS.singleton '\n'
2176 -- --------------------------------------------------------------------------
2179 getTickArray :: Module -> GHCi TickArray
2180 getTickArray modl = do
2182 let arrmap = tickarrays st
2183 case lookupModuleEnv arrmap modl of
2184 Just arr -> return arr
2186 (_breakArray, ticks) <- getModBreak modl
2187 let arr = mkTickArray (assocs ticks)
2188 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2191 discardTickArrays :: GHCi ()
2192 discardTickArrays = do
2194 setGHCiState st{tickarrays = emptyModuleEnv}
2196 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2198 = accumArray (flip (:)) [] (1, max_line)
2199 [ (line, (nm,span)) | (nm,span) <- ticks,
2200 line <- srcSpanLines span ]
2202 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2203 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2204 GHC.srcSpanEndLine span ]
2206 lookupModule :: String -> GHCi Module
2207 lookupModule modName
2208 = do session <- getSession
2209 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2211 -- don't reset the counter back to zero?
2212 discardActiveBreakPoints :: GHCi ()
2213 discardActiveBreakPoints = do
2215 mapM (turnOffBreak.snd) (breaks st)
2216 setGHCiState $ st { breaks = [] }
2218 deleteBreak :: Int -> GHCi ()
2219 deleteBreak identity = do
2221 let oldLocations = breaks st
2222 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2224 then printForUser (text "Breakpoint" <+> ppr identity <+>
2225 text "does not exist")
2227 mapM (turnOffBreak.snd) this
2228 setGHCiState $ st { breaks = rest }
2230 turnOffBreak :: BreakLocation -> GHCi Bool
2231 turnOffBreak loc = do
2232 (arr, _) <- getModBreak (breakModule loc)
2233 io $ setBreakFlag False arr (breakTick loc)
2235 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2236 getModBreak mod = do
2237 session <- getSession
2238 Just mod_info <- io $ GHC.getModuleInfo session mod
2239 let modBreaks = GHC.modInfoModBreaks mod_info
2240 let array = GHC.modBreaks_flags modBreaks
2241 let ticks = GHC.modBreaks_locs modBreaks
2242 return (array, ticks)
2244 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2245 setBreakFlag toggle array index
2246 | toggle = GHC.setBreakOn array index
2247 | otherwise = GHC.setBreakOff array index