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 cmdName :: Command -> String
101 cmdName (n,_,_,_) = n
103 macros_ref :: IORef [Command]
104 GLOBAL_VAR(macros_ref, [], [Command])
106 builtin_commands :: [Command]
108 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
109 ("?", keepGoing help, False, completeNone),
110 ("add", keepGoingPaths addModule, False, completeFilename),
111 ("abandon", keepGoing abandonCmd, False, completeNone),
112 ("break", keepGoing breakCmd, False, completeIdentifier),
113 ("back", keepGoing backCmd, False, completeNone),
114 ("browse", keepGoing (browseCmd False), False, completeModule),
115 ("browse!", keepGoing (browseCmd True), False, completeModule),
116 ("cd", keepGoing changeDirectory, False, completeFilename),
117 ("check", keepGoing checkModule, False, completeHomeModule),
118 ("continue", keepGoing continueCmd, False, completeNone),
119 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
120 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
121 ("def", keepGoing (defineMacro False), False, completeIdentifier),
122 ("def!", keepGoing (defineMacro True), False, completeIdentifier),
123 ("delete", keepGoing deleteCmd, False, completeNone),
124 ("e", keepGoing editFile, False, completeFilename),
125 ("edit", keepGoing editFile, False, completeFilename),
126 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
127 ("force", keepGoing forceCmd, False, completeIdentifier),
128 ("forward", keepGoing forwardCmd, False, completeNone),
129 ("help", keepGoing help, False, completeNone),
130 ("history", keepGoing historyCmd, False, completeNone),
131 ("info", keepGoing info, False, completeIdentifier),
132 ("kind", keepGoing kindOfType, False, completeIdentifier),
133 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
134 ("list", keepGoing listCmd, False, completeNone),
135 ("module", keepGoing setContext, False, completeModule),
136 ("main", keepGoing runMain, False, completeIdentifier),
137 ("print", keepGoing printCmd, False, completeIdentifier),
138 ("quit", quit, False, completeNone),
139 ("reload", keepGoing reloadModule, False, completeNone),
140 ("set", keepGoing setCmd, True, completeSetOptions),
141 ("show", keepGoing showCmd, False, completeNone),
142 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
143 ("step", keepGoing stepCmd, False, completeIdentifier),
144 ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
145 ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
146 ("type", keepGoing typeOfExpr, False, completeIdentifier),
147 ("trace", keepGoing traceCmd, False, completeIdentifier),
148 ("undef", keepGoing undefineMacro, False, completeMacro),
149 ("unset", keepGoing unsetOptions, True, completeSetOptions)
152 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
153 keepGoing a str = a str >> return False
155 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
156 keepGoingPaths a str = a (toArgs str) >> return False
158 shortHelpText :: String
159 shortHelpText = "use :? for help.\n"
163 " Commands available from the prompt:\n" ++
165 " <statement> evaluate/run <statement>\n" ++
166 " : repeat last command\n" ++
167 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
168 " :add <filename> ... add module(s) to the current target set\n" ++
169 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
170 " (!: more details; *: all top-level names)\n" ++
171 " :cd <dir> change directory to <dir>\n" ++
172 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
173 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
174 " :def <cmd> <expr> define a command :<cmd>\n" ++
175 " :edit <file> edit file\n" ++
176 " :edit edit last module\n" ++
177 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
178 " :help, :? display this list of commands\n" ++
179 " :info [<name> ...] display information about the given names\n" ++
180 " :kind <type> show the kind of <type>\n" ++
181 " :load <filename> ... load module(s) and their dependents\n" ++
182 " :main [<arguments> ...] run the main function with the given arguments\n" ++
183 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
184 " :quit exit GHCi\n" ++
185 " :reload reload the current module set\n" ++
186 " :type <expr> show the type of <expr>\n" ++
187 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
188 " :!<command> run the shell command <command>\n" ++
190 " -- Commands for debugging:\n" ++
192 " :abandon at a breakpoint, abandon current computation\n" ++
193 " :back go back in the history (after :trace)\n" ++
194 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
195 " :break <name> set a breakpoint on the specified function\n" ++
196 " :continue resume after a breakpoint\n" ++
197 " :delete <number> delete the specified breakpoint\n" ++
198 " :delete * delete all breakpoints\n" ++
199 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
200 " :forward go forward in the history (after :back)\n" ++
201 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
202 " :print [<name> ...] prints a value without forcing its computation\n" ++
203 " :sprint [<name> ...] simplifed version of :print\n" ++
204 " :step single-step after stopping at a breakpoint\n"++
205 " :step <expr> single-step into <expr>\n"++
206 " :steplocal single-step restricted to the current top level decl.\n"++
207 " :stepmodule single-step restricted to the current module\n"++
208 " :trace trace after stopping at a breakpoint\n"++
209 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
212 " -- Commands for changing settings:\n" ++
214 " :set <option> ... set options\n" ++
215 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
216 " :set prog <progname> set the value returned by System.getProgName\n" ++
217 " :set prompt <prompt> set the prompt used in GHCi\n" ++
218 " :set editor <cmd> set the command used for :edit\n" ++
219 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
220 " :unset <option> ... unset options\n" ++
222 " Options for ':set' and ':unset':\n" ++
224 " +r revert top-level expressions after each evaluation\n" ++
225 " +s print timing/memory stats after each evaluation\n" ++
226 " +t print type after evaluation\n" ++
227 " -<flags> most GHC command line flags can also be set here\n" ++
228 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
229 " for GHCi-specific flags, see User's Guide,\n"++
230 " Flag reference, Interactive-mode options\n" ++
232 " -- Commands for displaying information:\n" ++
234 " :show bindings show the current bindings made at the prompt\n" ++
235 " :show breaks show the active breakpoints\n" ++
236 " :show context show the breakpoint context\n" ++
237 " :show modules show the currently loaded modules\n" ++
238 " :show packages show the currently active package flags\n" ++
239 " :show languages show the currently active language flags\n" ++
240 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
243 findEditor :: IO String
248 win <- System.Win32.getWindowsDirectory
249 return (win `joinFileName` "notepad.exe")
254 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
255 interactiveUI session srcs maybe_expr = do
256 -- HACK! If we happen to get into an infinite loop (eg the user
257 -- types 'let x=x in x' at the prompt), then the thread will block
258 -- on a blackhole, and become unreachable during GC. The GC will
259 -- detect that it is unreachable and send it the NonTermination
260 -- exception. However, since the thread is unreachable, everything
261 -- it refers to might be finalized, including the standard Handles.
262 -- This sounds like a bug, but we don't have a good solution right
268 -- Initialise buffering for the *interpreted* I/O system
269 initInterpBuffering session
271 when (isNothing maybe_expr) $ do
272 -- Only for GHCi (not runghc and ghc -e):
274 -- Turn buffering off for the compiled program's stdout/stderr
276 -- Turn buffering off for GHCi's stdout
278 hSetBuffering stdout NoBuffering
279 -- We don't want the cmd line to buffer any input that might be
280 -- intended for the program, so unbuffer stdin.
281 hSetBuffering stdin NoBuffering
283 -- initial context is just the Prelude
284 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
286 GHC.setContext session [] [prel_mod]
290 Readline.setAttemptedCompletionFunction (Just completeWord)
291 --Readline.parseAndBind "set show-all-if-ambiguous 1"
293 let symbols = "!#$%&*+/<=>?@\\^|-~"
294 specials = "(),;[]`{}"
296 word_break_chars = spaces ++ specials ++ symbols
298 Readline.setBasicWordBreakCharacters word_break_chars
299 Readline.setCompleterWordBreakCharacters word_break_chars
302 default_editor <- findEditor
304 startGHCi (runGHCi srcs maybe_expr)
305 GHCiState{ progname = "<interactive>",
309 editor = default_editor,
315 tickarrays = emptyModuleEnv,
316 last_command = Nothing,
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
714 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
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 <- lookupCommand cmd
722 GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
724 do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
728 do io $ hPutStr stdout ("there is no last command to perform\n"
732 lookupCommand :: String -> GHCi (MaybeCommand)
733 lookupCommand "" = do
735 case last_command st of
736 Just c -> return $ GotCommand c
737 Nothing -> return NoLastCommand
738 lookupCommand str = do
739 mc <- io $ lookupCommand' str
741 setGHCiState st{ last_command = mc }
743 Just c -> GotCommand c
744 Nothing -> BadCommand
746 lookupCommand' :: String -> IO (Maybe Command)
747 lookupCommand' str = do
748 macros <- readIORef macros_ref
749 let cmds = builtin_commands ++ macros
750 -- look for exact match first, then the first prefix match
751 return $ case [ c | c <- cmds, str == cmdName c ] of
753 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
757 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
758 getCurrentBreakSpan = do
759 session <- getSession
760 resumes <- io $ GHC.getResumeContext session
764 let ix = GHC.resumeHistoryIx r
766 then return (Just (GHC.resumeSpan r))
768 let hist = GHC.resumeHistory r !! (ix-1)
769 span <- io $ GHC.getHistorySpan session hist
772 getCurrentBreakModule :: GHCi (Maybe Module)
773 getCurrentBreakModule = do
774 session <- getSession
775 resumes <- io $ GHC.getResumeContext session
779 let ix = GHC.resumeHistoryIx r
781 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
783 let hist = GHC.resumeHistory r !! (ix-1)
784 return $ Just $ GHC.getHistoryModule hist
786 -----------------------------------------------------------------------------
789 noArgs :: GHCi () -> String -> GHCi ()
791 noArgs _ _ = io $ putStrLn "This command takes no arguments"
793 help :: String -> GHCi ()
794 help _ = io (putStr helpText)
796 info :: String -> GHCi ()
797 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
798 info s = do { let names = words s
799 ; session <- getSession
800 ; dflags <- getDynFlags
801 ; let pefas = dopt Opt_PrintExplicitForalls dflags
802 ; mapM_ (infoThing pefas session) names }
804 infoThing pefas session str = io $ do
805 names <- GHC.parseName session str
806 mb_stuffs <- mapM (GHC.getInfo session) names
807 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
808 unqual <- GHC.getPrintUnqual session
809 putStrLn (showSDocForUser unqual $
810 vcat (intersperse (text "") $
811 map (pprInfo pefas) filtered))
813 -- Filter out names whose parent is also there Good
814 -- example is '[]', which is both a type and data
815 -- constructor in the same type
816 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
817 filterOutChildren get_thing xs
818 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
820 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
822 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
823 pprInfo pefas (thing, fixity, insts)
824 = pprTyThingInContextLoc pefas thing
825 $$ show_fixity fixity
826 $$ vcat (map GHC.pprInstance insts)
829 | fix == GHC.defaultFixity = empty
830 | otherwise = ppr fix <+> ppr (GHC.getName thing)
832 runMain :: String -> GHCi ()
834 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
835 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
837 addModule :: [FilePath] -> GHCi ()
839 io (revertCAFs) -- always revert CAFs on load/add.
840 files <- mapM expandPath files
841 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
842 session <- getSession
843 io (mapM_ (GHC.addTarget session) targets)
844 prev_context <- io $ GHC.getContext session
845 ok <- io (GHC.load session LoadAllTargets)
846 afterLoad ok session False prev_context
848 changeDirectory :: String -> GHCi ()
849 changeDirectory dir = do
850 session <- getSession
851 graph <- io (GHC.getModuleGraph session)
852 when (not (null graph)) $
853 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
854 prev_context <- io $ GHC.getContext session
855 io (GHC.setTargets session [])
856 io (GHC.load session LoadAllTargets)
857 setContextAfterLoad session prev_context []
858 io (GHC.workingDirectoryChanged session)
859 dir <- expandPath dir
860 io (setCurrentDirectory dir)
862 editFile :: String -> GHCi ()
864 do file <- if null str then chooseEditFile else return str
868 $ throwDyn (CmdLineError "editor not set, use :set editor")
869 io $ system (cmd ++ ' ':file)
872 -- The user didn't specify a file so we pick one for them.
873 -- Our strategy is to pick the first module that failed to load,
874 -- or otherwise the first target.
876 -- XXX: Can we figure out what happened if the depndecy analysis fails
877 -- (e.g., because the porgrammeer mistyped the name of a module)?
878 -- XXX: Can we figure out the location of an error to pass to the editor?
879 -- XXX: if we could figure out the list of errors that occured during the
880 -- last load/reaload, then we could start the editor focused on the first
882 chooseEditFile :: GHCi String
884 do session <- getSession
885 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
887 graph <- io (GHC.getModuleGraph session)
888 failed_graph <- filterM hasFailed graph
889 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
891 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
894 case pick (order failed_graph) of
895 Just file -> return file
897 do targets <- io (GHC.getTargets session)
898 case msum (map fromTarget targets) of
899 Just file -> return file
900 Nothing -> throwDyn (CmdLineError "No files to edit.")
902 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
903 fromTarget _ = Nothing -- when would we get a module target?
905 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
906 defineMacro overwrite s = do
907 let (macro_name, definition) = break isSpace s
908 macros <- io (readIORef macros_ref)
909 let defined = map cmdName macros
912 then io $ putStrLn "no macros defined"
913 else io $ putStr ("the following macros are defined:\n" ++
916 if (not overwrite && macro_name `elem` defined)
917 then throwDyn (CmdLineError
918 ("macro '" ++ macro_name ++ "' is already defined"))
921 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
923 -- give the expression a type signature, so we can be sure we're getting
924 -- something of the right type.
925 let new_expr = '(' : definition ++ ") :: String -> IO String"
927 -- compile the expression
929 maybe_hv <- io (GHC.compileExpr cms new_expr)
932 Just hv -> io (writeIORef macros_ref --
933 (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
935 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
937 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
938 enqueueCommands (lines str)
941 undefineMacro :: String -> GHCi ()
942 undefineMacro str = mapM_ undef (words str)
943 where undef macro_name = do
944 cmds <- io (readIORef macros_ref)
945 if (macro_name `notElem` map cmdName cmds)
946 then throwDyn (CmdLineError
947 ("macro '" ++ macro_name ++ "' is not defined"))
949 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
951 cmdCmd :: String -> GHCi ()
953 let expr = '(' : str ++ ") :: IO String"
954 session <- getSession
955 maybe_hv <- io (GHC.compileExpr session expr)
959 cmds <- io $ (unsafeCoerce# hv :: IO String)
960 enqueueCommands (lines cmds)
963 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
964 loadModule fs = timeIt (loadModule' fs)
966 loadModule_ :: [FilePath] -> GHCi ()
967 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
969 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
970 loadModule' files = do
971 session <- getSession
972 prev_context <- io $ GHC.getContext session
975 discardActiveBreakPoints
976 io (GHC.setTargets session [])
977 io (GHC.load session LoadAllTargets)
980 let (filenames, phases) = unzip files
981 exp_filenames <- mapM expandPath filenames
982 let files' = zip exp_filenames phases
983 targets <- io (mapM (uncurry GHC.guessTarget) files')
985 -- NOTE: we used to do the dependency anal first, so that if it
986 -- fails we didn't throw away the current set of modules. This would
987 -- require some re-working of the GHC interface, so we'll leave it
988 -- as a ToDo for now.
990 io (GHC.setTargets session targets)
991 doLoad session False prev_context LoadAllTargets
993 checkModule :: String -> GHCi ()
995 let modl = GHC.mkModuleName m
996 session <- getSession
997 prev_context <- io $ GHC.getContext session
998 result <- io (GHC.checkModule session modl False)
1000 Nothing -> io $ putStrLn "Nothing"
1001 Just r -> io $ putStrLn (showSDoc (
1002 case GHC.checkedModuleInfo r of
1003 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1005 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1007 (text "global names: " <+> ppr global) $$
1008 (text "local names: " <+> ppr local)
1010 afterLoad (successIf (isJust result)) session False prev_context
1012 reloadModule :: String -> GHCi ()
1014 session <- getSession
1015 prev_context <- io $ GHC.getContext session
1016 doLoad session True prev_context $
1017 if null m then LoadAllTargets
1018 else LoadUpTo (GHC.mkModuleName m)
1021 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1022 doLoad session retain_context prev_context howmuch = do
1023 -- turn off breakpoints before we load: we can't turn them off later, because
1024 -- the ModBreaks will have gone away.
1025 discardActiveBreakPoints
1026 ok <- io (GHC.load session howmuch)
1027 afterLoad ok session retain_context prev_context
1030 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1031 afterLoad ok session retain_context prev_context = do
1032 io (revertCAFs) -- always revert CAFs on load.
1034 loaded_mod_summaries <- getLoadedModules session
1035 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1036 loaded_mod_names = map GHC.moduleName loaded_mods
1037 modulesLoadedMsg ok loaded_mod_names
1040 if not retain_context
1042 setGHCiState st{ remembered_ctx = Nothing }
1043 setContextAfterLoad session prev_context loaded_mod_summaries
1045 -- figure out which modules we can keep in the context, which we
1046 -- have to put back, and which we have to remember because they
1047 -- are (temporarily) unavailable. See ghci.prog009, #1873, #1360
1048 let (as,bs) = prev_context
1049 as1 = filter isHomeModule as -- package modules are kept anyway
1050 bs1 = filter isHomeModule bs
1051 (as_ok, as_bad) = partition (`elem` loaded_mods) as1
1052 (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1
1053 (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st)
1054 (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as
1055 (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs
1056 as' = nub (as_ok++rem_as_ok)
1057 bs' = nub (bs_ok++rem_bs_ok)
1058 rem_as' = nub (rem_as_bad ++ as_bad)
1059 rem_bs' = nub (rem_bs_bad ++ bs_bad)
1061 -- Put back into the context any modules that we previously had
1062 -- to drop because they weren't available (rem_as_ok, rem_bs_ok).
1063 setContextKeepingPackageModules session prev_context (as',bs')
1065 -- If compilation failed, remember any modules that we are unable
1066 -- to load, so that we can put them back in the context in the future.
1068 Succeeded -> setGHCiState st{ remembered_ctx = Nothing }
1069 Failed -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') }
1073 setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi ()
1074 setContextAfterLoad session prev [] = do
1075 prel_mod <- getPrelude
1076 setContextKeepingPackageModules session prev ([], [prel_mod])
1077 setContextAfterLoad session prev ms = do
1078 -- load a target if one is available, otherwise load the topmost module.
1079 targets <- io (GHC.getTargets session)
1080 case [ m | Just m <- map (findTarget ms) targets ] of
1082 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1083 load_this (last graph')
1088 = case filter (`matches` t) ms of
1092 summary `matches` Target (TargetModule m) _
1093 = GHC.ms_mod_name summary == m
1094 summary `matches` Target (TargetFile f _) _
1095 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1099 load_this summary | m <- GHC.ms_mod summary = do
1100 b <- io (GHC.moduleIsInterpreted session m)
1101 if b then setContextKeepingPackageModules session prev ([m], [])
1103 prel_mod <- getPrelude
1104 setContextKeepingPackageModules session prev ([],[prel_mod,m])
1106 -- | Keep any package modules (except Prelude) when changing the context.
1107 setContextKeepingPackageModules
1109 -> ([Module],[Module]) -- previous context
1110 -> ([Module],[Module]) -- new context
1112 setContextKeepingPackageModules session prev_context (as,bs) = do
1113 let (_,bs0) = prev_context
1114 prel_mod <- getPrelude
1115 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1116 let bs1 = if null as then nub (prel_mod : bs) else bs
1117 io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1119 isHomeModule :: Module -> Bool
1120 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1122 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1123 modulesLoadedMsg ok mods = do
1124 dflags <- getDynFlags
1125 when (verbosity dflags > 0) $ do
1127 | null mods = text "none."
1128 | otherwise = hsep (
1129 punctuate comma (map ppr mods)) <> text "."
1132 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1134 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1137 typeOfExpr :: String -> GHCi ()
1139 = do cms <- getSession
1140 maybe_ty <- io (GHC.exprType cms str)
1142 Nothing -> return ()
1143 Just ty -> do dflags <- getDynFlags
1144 let pefas = dopt Opt_PrintExplicitForalls dflags
1145 printForUser $ text str <+> dcolon
1146 <+> pprTypeForUser pefas ty
1148 kindOfType :: String -> GHCi ()
1150 = do cms <- getSession
1151 maybe_ty <- io (GHC.typeKind cms str)
1153 Nothing -> return ()
1154 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1156 quit :: String -> GHCi Bool
1157 quit _ = return True
1159 shellEscape :: String -> GHCi Bool
1160 shellEscape str = io (system str >> return False)
1162 -----------------------------------------------------------------------------
1163 -- Browsing a module's contents
1165 browseCmd :: Bool -> String -> GHCi ()
1168 ['*':s] | looksLikeModuleName s -> do
1169 m <- wantInterpretedModule s
1170 browseModule bang m False
1171 [s] | looksLikeModuleName s -> do
1173 browseModule bang m True
1176 (as,bs) <- io $ GHC.getContext s
1177 -- Guess which module the user wants to browse. Pick
1178 -- modules that are interpreted first. The most
1179 -- recently-added module occurs last, it seems.
1181 (as@(_:_), _) -> browseModule bang (last as) True
1182 ([], bs@(_:_)) -> browseModule bang (last bs) True
1183 ([], []) -> throwDyn (CmdLineError ":browse: no current module")
1184 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1186 -- without bang, show items in context of their parents and omit children
1187 -- with bang, show class methods and data constructors separately, and
1188 -- indicate import modules, to aid qualifying unqualified names
1189 -- with sorted, sort items alphabetically
1190 browseModule :: Bool -> Module -> Bool -> GHCi ()
1191 browseModule bang modl exports_only = do
1193 -- :browse! reports qualifiers wrt current context
1194 current_unqual <- io (GHC.getPrintUnqual s)
1195 -- Temporarily set the context to the module we're interested in,
1196 -- just so we can get an appropriate PrintUnqualified
1197 (as,bs) <- io (GHC.getContext s)
1198 prel_mod <- getPrelude
1199 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1200 else GHC.setContext s [modl] [])
1201 target_unqual <- io (GHC.getPrintUnqual s)
1202 io (GHC.setContext s as bs)
1204 let unqual = if bang then current_unqual else target_unqual
1206 mb_mod_info <- io $ GHC.getModuleInfo s modl
1208 Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1209 GHC.moduleNameString (GHC.moduleName modl)))
1211 dflags <- getDynFlags
1213 | exports_only = GHC.modInfoExports mod_info
1214 | otherwise = GHC.modInfoTopLevelScope mod_info
1217 -- sort alphabetically name, but putting
1218 -- locally-defined identifiers first.
1219 -- We would like to improve this; see #1799.
1220 sorted_names = loc_sort local ++ occ_sort external
1222 (local,external) = partition ((==modl) . nameModule) names
1223 occ_sort = sortBy (compare `on` nameOccName)
1224 -- try to sort by src location. If the first name in
1225 -- our list has a good source location, then they all should.
1227 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1228 = sortBy (compare `on` nameSrcSpan) names
1232 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1233 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1235 rdr_env <- io $ GHC.getGRE s
1237 let pefas = dopt Opt_PrintExplicitForalls dflags
1238 things | bang = catMaybes mb_things
1239 | otherwise = filtered_things
1240 pretty | bang = pprTyThing
1241 | otherwise = pprTyThingInContext
1243 labels [] = text "-- not currently imported"
1244 labels l = text $ intercalate "\n" $ map qualifier l
1245 qualifier = maybe "-- defined locally"
1246 (("-- imported via "++) . intercalate ", "
1247 . map GHC.moduleNameString)
1248 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1249 modNames = map (importInfo . GHC.getName) things
1251 -- annotate groups of imports with their import modules
1252 -- the default ordering is somewhat arbitrary, so we group
1253 -- by header and sort groups; the names themselves should
1254 -- really come in order of source appearance.. (trac #1799)
1255 annotate mts = concatMap (\(m,ts)->labels m:ts)
1256 $ sortBy cmpQualifiers $ group mts
1257 where cmpQualifiers =
1258 compare `on` (map (fmap (map moduleNameFS)) . fst)
1260 group mts@((m,_):_) = (m,map snd g) : group ng
1261 where (g,ng) = partition ((==m).fst) mts
1263 let prettyThings = map (pretty pefas) things
1264 prettyThings' | bang = annotate $ zip modNames prettyThings
1265 | otherwise = prettyThings
1266 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1267 -- ToDo: modInfoInstances currently throws an exception for
1268 -- package modules. When it works, we can do this:
1269 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1271 -----------------------------------------------------------------------------
1272 -- Setting the module context
1274 setContext :: String -> GHCi ()
1276 | all sensible mods = fn mods
1277 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1279 (fn, mods) = case str of
1280 '+':stuff -> (addToContext, words stuff)
1281 '-':stuff -> (removeFromContext, words stuff)
1282 stuff -> (newContext, words stuff)
1284 sensible ('*':m) = looksLikeModuleName m
1285 sensible m = looksLikeModuleName m
1287 separate :: Session -> [String] -> [Module] -> [Module]
1288 -> GHCi ([Module],[Module])
1289 separate _ [] as bs = return (as,bs)
1290 separate session (('*':str):ms) as bs = do
1291 m <- wantInterpretedModule str
1292 separate session ms (m:as) bs
1293 separate session (str:ms) as bs = do
1294 m <- lookupModule str
1295 separate session ms as (m:bs)
1297 newContext :: [String] -> GHCi ()
1298 newContext strs = do
1300 (as,bs) <- separate s strs [] []
1301 prel_mod <- getPrelude
1302 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1303 io $ GHC.setContext s as bs'
1306 addToContext :: [String] -> GHCi ()
1307 addToContext strs = do
1309 (as,bs) <- io $ GHC.getContext s
1311 (new_as,new_bs) <- separate s strs [] []
1313 let as_to_add = new_as \\ (as ++ bs)
1314 bs_to_add = new_bs \\ (as ++ bs)
1316 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1319 removeFromContext :: [String] -> GHCi ()
1320 removeFromContext strs = do
1322 (as,bs) <- io $ GHC.getContext s
1324 (as_to_remove,bs_to_remove) <- separate s strs [] []
1326 let as' = as \\ (as_to_remove ++ bs_to_remove)
1327 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1329 io $ GHC.setContext s as' bs'
1331 ----------------------------------------------------------------------------
1334 -- set options in the interpreter. Syntax is exactly the same as the
1335 -- ghc command line, except that certain options aren't available (-C,
1338 -- This is pretty fragile: most options won't work as expected. ToDo:
1339 -- figure out which ones & disallow them.
1341 setCmd :: String -> GHCi ()
1343 = do st <- getGHCiState
1344 let opts = options st
1345 io $ putStrLn (showSDoc (
1346 text "options currently set: " <>
1349 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1351 dflags <- getDynFlags
1352 io $ putStrLn (showSDoc (
1353 vcat (text "GHCi-specific dynamic flag settings:"
1354 :map (flagSetting dflags) ghciFlags)
1356 io $ putStrLn (showSDoc (
1357 vcat (text "other dynamic, non-language, flag settings:"
1358 :map (flagSetting dflags) nonLanguageDynFlags)
1360 where flagSetting dflags (str,f)
1361 | dopt f dflags = text " " <> text "-f" <> text str
1362 | otherwise = text " " <> text "-fno-" <> text str
1363 (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
1365 nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1367 flags = [Opt_PrintExplicitForalls
1368 ,Opt_PrintBindResult
1369 ,Opt_BreakOnException
1371 ,Opt_PrintEvldWithShow
1374 = case toArgs str of
1375 ("args":args) -> setArgs args
1376 ("prog":prog) -> setProg prog
1377 ("prompt":_) -> setPrompt (after 6)
1378 ("editor":_) -> setEditor (after 6)
1379 ("stop":_) -> setStop (after 4)
1380 wds -> setOptions wds
1381 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1383 setArgs, setProg, setOptions :: [String] -> GHCi ()
1384 setEditor, setStop, setPrompt :: String -> GHCi ()
1388 setGHCiState st{ args = args }
1392 setGHCiState st{ progname = prog }
1394 io (hPutStrLn stderr "syntax: :set prog <progname>")
1398 setGHCiState st{ editor = cmd }
1400 setStop str@(c:_) | isDigit c
1401 = do let (nm_str,rest) = break (not.isDigit) str
1404 let old_breaks = breaks st
1405 if all ((/= nm) . fst) old_breaks
1406 then printForUser (text "Breakpoint" <+> ppr nm <+>
1407 text "does not exist")
1409 let new_breaks = map fn old_breaks
1410 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1411 | otherwise = (i,loc)
1412 setGHCiState st{ breaks = new_breaks }
1415 setGHCiState st{ stop = cmd }
1417 setPrompt value = do
1420 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1421 else setGHCiState st{ prompt = remQuotes value }
1423 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1427 do -- first, deal with the GHCi opts (+s, +t, etc.)
1428 let (plus_opts, minus_opts) = partitionWith isPlus wds
1429 mapM_ setOpt plus_opts
1430 -- then, dynamic flags
1431 newDynFlags minus_opts
1433 newDynFlags :: [String] -> GHCi ()
1434 newDynFlags minus_opts = do
1435 dflags <- getDynFlags
1436 let pkg_flags = packageFlags dflags
1437 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1439 if (not (null leftovers))
1440 then throwDyn (CmdLineError ("unrecognised flags: " ++
1444 new_pkgs <- setDynFlags dflags'
1446 -- if the package flags changed, we should reset the context
1447 -- and link the new packages.
1448 dflags <- getDynFlags
1449 when (packageFlags dflags /= pkg_flags) $ do
1450 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1451 session <- getSession
1452 io (GHC.setTargets session [])
1453 io (GHC.load session LoadAllTargets)
1454 io (linkPackages dflags new_pkgs)
1455 -- package flags changed, we can't re-use any of the old context
1456 setContextAfterLoad session ([],[]) []
1460 unsetOptions :: String -> GHCi ()
1462 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1463 let opts = words str
1464 (minus_opts, rest1) = partition isMinus opts
1465 (plus_opts, rest2) = partitionWith isPlus rest1
1467 if (not (null rest2))
1468 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1471 mapM_ unsetOpt plus_opts
1473 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1474 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1476 no_flags <- mapM no_flag minus_opts
1477 newDynFlags no_flags
1479 isMinus :: String -> Bool
1480 isMinus ('-':_) = True
1483 isPlus :: String -> Either String String
1484 isPlus ('+':opt) = Left opt
1485 isPlus other = Right other
1487 setOpt, unsetOpt :: String -> GHCi ()
1490 = case strToGHCiOpt str of
1491 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1492 Just o -> setOption o
1495 = case strToGHCiOpt str of
1496 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1497 Just o -> unsetOption o
1499 strToGHCiOpt :: String -> (Maybe GHCiOption)
1500 strToGHCiOpt "s" = Just ShowTiming
1501 strToGHCiOpt "t" = Just ShowType
1502 strToGHCiOpt "r" = Just RevertCAFs
1503 strToGHCiOpt _ = Nothing
1505 optToStr :: GHCiOption -> String
1506 optToStr ShowTiming = "s"
1507 optToStr ShowType = "t"
1508 optToStr RevertCAFs = "r"
1510 -- ---------------------------------------------------------------------------
1513 showCmd :: String -> GHCi ()
1517 ["args"] -> io $ putStrLn (show (args st))
1518 ["prog"] -> io $ putStrLn (show (progname st))
1519 ["prompt"] -> io $ putStrLn (show (prompt st))
1520 ["editor"] -> io $ putStrLn (show (editor st))
1521 ["stop"] -> io $ putStrLn (show (stop st))
1522 ["modules" ] -> showModules
1523 ["bindings"] -> showBindings
1524 ["linker"] -> io showLinkerState
1525 ["breaks"] -> showBkptTable
1526 ["context"] -> showContext
1527 ["packages"] -> showPackages
1528 ["languages"] -> showLanguages
1529 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1531 showModules :: GHCi ()
1533 session <- getSession
1534 loaded_mods <- getLoadedModules session
1535 -- we want *loaded* modules only, see #1734
1536 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1537 mapM_ show_one loaded_mods
1539 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1540 getLoadedModules session = do
1541 graph <- io (GHC.getModuleGraph session)
1542 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1544 showBindings :: GHCi ()
1547 bindings <- io (GHC.getBindings s)
1548 docs <- io$ pprTypeAndContents s
1549 [ id | AnId id <- sortBy compareTyThings bindings]
1550 printForUserPartWay docs
1552 compareTyThings :: TyThing -> TyThing -> Ordering
1553 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1555 printTyThing :: TyThing -> GHCi ()
1556 printTyThing tyth = do dflags <- getDynFlags
1557 let pefas = dopt Opt_PrintExplicitForalls dflags
1558 printForUser (pprTyThing pefas tyth)
1560 showBkptTable :: GHCi ()
1563 printForUser $ prettyLocations (breaks st)
1565 showContext :: GHCi ()
1567 session <- getSession
1568 resumes <- io $ GHC.getResumeContext session
1569 printForUser $ vcat (map pp_resume (reverse resumes))
1572 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1573 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1575 showPackages :: GHCi ()
1577 pkg_flags <- fmap packageFlags getDynFlags
1578 io $ putStrLn $ showSDoc $ vcat $
1579 text ("active package flags:"++if null pkg_flags then " none" else "")
1580 : map showFlag pkg_flags
1581 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1582 io $ putStrLn $ showSDoc $ vcat $
1583 text "packages currently loaded:"
1584 : map (nest 2 . text . packageIdString) pkg_ids
1585 where showFlag (ExposePackage p) = text $ " -package " ++ p
1586 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1587 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1589 showLanguages :: GHCi ()
1591 dflags <- getDynFlags
1592 io $ putStrLn $ showSDoc $ vcat $
1593 text "active language flags:" :
1594 [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1596 -- -----------------------------------------------------------------------------
1599 completeNone :: String -> IO [String]
1600 completeNone _w = return []
1602 completeMacro, completeIdentifier, completeModule,
1603 completeHomeModule, completeSetOptions, completeFilename,
1604 completeHomeModuleOrFile
1605 :: String -> IO [String]
1608 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1609 completeWord w start end = do
1610 line <- Readline.getLineBuffer
1611 let line_words = words (dropWhile isSpace line)
1613 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1615 | ((':':c) : _) <- line_words -> do
1616 maybe_cmd <- lookupCommand' c
1617 let (n,w') = selectWord (words' 0 line)
1619 Nothing -> return Nothing
1620 Just (_,_,False,complete) -> wrapCompleter complete w
1621 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1622 return (map (drop n) rets)
1623 in wrapCompleter complete' w'
1624 | ("import" : _) <- line_words ->
1625 wrapCompleter completeModule w
1627 --printf "complete %s, start = %d, end = %d\n" w start end
1628 wrapCompleter completeIdentifier w
1629 where words' _ [] = []
1630 words' n str = let (w,r) = break isSpace str
1631 (s,r') = span isSpace r
1632 in (n,w):words' (n+length w+length s) r'
1633 -- In a Haskell expression we want to parse 'a-b' as three words
1634 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1635 -- only be a single word.
1636 selectWord [] = (0,w)
1637 selectWord ((offset,x):xs)
1638 | offset+length x >= start = (start-offset,take (end-offset) x)
1639 | otherwise = selectWord xs
1641 completeCmd :: String -> IO [String]
1643 cmds <- readIORef macros_ref
1644 return (filter (w `isPrefixOf`) (map (':':)
1645 (map cmdName (builtin_commands ++ cmds))))
1647 completeMacro w = do
1648 cmds <- readIORef macros_ref
1649 return (filter (w `isPrefixOf`) (map cmdName cmds))
1651 completeIdentifier w = do
1653 rdrs <- GHC.getRdrNamesInScope s
1654 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1656 completeModule w = do
1658 dflags <- GHC.getSessionDynFlags s
1659 let pkg_mods = allExposedModules dflags
1660 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1662 completeHomeModule w = do
1664 g <- GHC.getModuleGraph s
1665 let home_mods = map GHC.ms_mod_name g
1666 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1668 completeSetOptions w = do
1669 return (filter (w `isPrefixOf`) options)
1670 where options = "args":"prog":allFlags
1672 completeFilename = Readline.filenameCompletionFunction
1674 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1676 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1677 unionComplete f1 f2 w = do
1682 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1683 wrapCompleter fun w = do
1686 [] -> return Nothing
1687 [x] -> return (Just (x,[]))
1688 xs -> case getCommonPrefix xs of
1689 "" -> return (Just ("",xs))
1690 pref -> return (Just (pref,xs))
1692 getCommonPrefix :: [String] -> String
1693 getCommonPrefix [] = ""
1694 getCommonPrefix (s:ss) = foldl common s ss
1695 where common _s "" = ""
1697 common (c:cs) (d:ds)
1698 | c == d = c : common cs ds
1701 allExposedModules :: DynFlags -> [ModuleName]
1702 allExposedModules dflags
1703 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1705 pkg_db = pkgIdMap (pkgState dflags)
1707 completeMacro = completeNone
1708 completeIdentifier = completeNone
1709 completeModule = completeNone
1710 completeHomeModule = completeNone
1711 completeSetOptions = completeNone
1712 completeFilename = completeNone
1713 completeHomeModuleOrFile=completeNone
1716 -- ---------------------------------------------------------------------------
1717 -- User code exception handling
1719 -- This is the exception handler for exceptions generated by the
1720 -- user's code and exceptions coming from children sessions;
1721 -- it normally just prints out the exception. The
1722 -- handler must be recursive, in case showing the exception causes
1723 -- more exceptions to be raised.
1725 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1726 -- raising another exception. We therefore don't put the recursive
1727 -- handler arond the flushing operation, so if stderr is closed
1728 -- GHCi will just die gracefully rather than going into an infinite loop.
1729 handler :: Exception -> GHCi Bool
1731 handler exception = do
1733 io installSignalHandlers
1734 ghciHandle handler (showException exception >> return False)
1736 showException :: Exception -> GHCi ()
1737 showException (DynException dyn) =
1738 case fromDynamic dyn of
1739 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1740 Just Interrupted -> io (putStrLn "Interrupted.")
1741 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1742 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1743 Just other_ghc_ex -> io (print other_ghc_ex)
1745 showException other_exception
1746 = io (putStrLn ("*** Exception: " ++ show other_exception))
1748 -----------------------------------------------------------------------------
1749 -- recursive exception handlers
1751 -- Don't forget to unblock async exceptions in the handler, or if we're
1752 -- in an exception loop (eg. let a = error a in a) the ^C exception
1753 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1755 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1756 ghciHandle h (GHCi m) = GHCi $ \s ->
1757 Exception.catch (m s)
1758 (\e -> unGHCi (ghciUnblock (h e)) s)
1760 ghciUnblock :: GHCi a -> GHCi a
1761 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1764 -- ----------------------------------------------------------------------------
1767 expandPath :: String -> GHCi String
1769 case dropWhile isSpace path of
1771 tilde <- io getHomeDirectory -- will fail if HOME not defined
1772 return (tilde ++ '/':d)
1776 wantInterpretedModule :: String -> GHCi Module
1777 wantInterpretedModule str = do
1778 session <- getSession
1779 modl <- lookupModule str
1780 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1781 when (not is_interpreted) $
1782 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1785 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1786 -> (Name -> GHCi ())
1788 wantNameFromInterpretedModule noCanDo str and_then = do
1789 session <- getSession
1790 names <- io $ GHC.parseName session str
1794 let modl = GHC.nameModule n
1795 if not (GHC.isExternalName n)
1796 then noCanDo n $ ppr n <>
1797 text " is not defined in an interpreted module"
1799 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1800 if not is_interpreted
1801 then noCanDo n $ text "module " <> ppr modl <>
1802 text " is not interpreted"
1805 -- -----------------------------------------------------------------------------
1806 -- commands for debugger
1808 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1809 sprintCmd = pprintCommand False False
1810 printCmd = pprintCommand True False
1811 forceCmd = pprintCommand False True
1813 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1814 pprintCommand bind force str = do
1815 session <- getSession
1816 io $ pprintClosureCommand session bind force str
1818 stepCmd :: String -> GHCi ()
1819 stepCmd [] = doContinue (const True) GHC.SingleStep
1820 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1822 stepLocalCmd :: String -> GHCi ()
1823 stepLocalCmd [] = do
1824 mb_span <- getCurrentBreakSpan
1826 Nothing -> stepCmd []
1828 Just mod <- getCurrentBreakModule
1829 current_toplevel_decl <- enclosingTickSpan mod loc
1830 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1832 stepLocalCmd expression = stepCmd expression
1834 stepModuleCmd :: String -> GHCi ()
1835 stepModuleCmd [] = do
1836 mb_span <- getCurrentBreakSpan
1838 Nothing -> stepCmd []
1840 Just span <- getCurrentBreakSpan
1841 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1842 doContinue f GHC.SingleStep
1844 stepModuleCmd expression = stepCmd expression
1846 -- | Returns the span of the largest tick containing the srcspan given
1847 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1848 enclosingTickSpan mod src = do
1849 ticks <- getTickArray mod
1850 let line = srcSpanStartLine src
1851 ASSERT (inRange (bounds ticks) line) do
1852 let enclosing_spans = [ span | (_,span) <- ticks ! line
1853 , srcSpanEnd span >= srcSpanEnd src]
1854 return . head . sortBy leftmost_largest $ enclosing_spans
1856 traceCmd :: String -> GHCi ()
1857 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1858 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1860 continueCmd :: String -> GHCi ()
1861 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1863 -- doContinue :: SingleStep -> GHCi ()
1864 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1865 doContinue pred step = do
1866 session <- getSession
1867 runResult <- io $ GHC.resume session step
1868 afterRunStmt pred runResult
1871 abandonCmd :: String -> GHCi ()
1872 abandonCmd = noArgs $ do
1874 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1875 when (not b) $ io $ putStrLn "There is no computation running."
1878 deleteCmd :: String -> GHCi ()
1879 deleteCmd argLine = do
1880 deleteSwitch $ words argLine
1882 deleteSwitch :: [String] -> GHCi ()
1884 io $ putStrLn "The delete command requires at least one argument."
1885 -- delete all break points
1886 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1887 deleteSwitch idents = do
1888 mapM_ deleteOneBreak idents
1890 deleteOneBreak :: String -> GHCi ()
1892 | all isDigit str = deleteBreak (read str)
1893 | otherwise = return ()
1895 historyCmd :: String -> GHCi ()
1897 | null arg = history 20
1898 | all isDigit arg = history (read arg)
1899 | otherwise = io $ putStrLn "Syntax: :history [num]"
1903 resumes <- io $ GHC.getResumeContext s
1905 [] -> io $ putStrLn "Not stopped at a breakpoint"
1907 let hist = GHC.resumeHistory r
1908 (took,rest) = splitAt num hist
1909 spans <- mapM (io . GHC.getHistorySpan s) took
1910 let nums = map (printf "-%-3d:") [(1::Int)..]
1911 let names = map GHC.historyEnclosingDecl took
1912 printForUser (vcat(zipWith3
1913 (\x y z -> x <+> y <+> z)
1915 (map (bold . ppr) names)
1916 (map (parens . ppr) spans)))
1917 io $ putStrLn $ if null rest then "<end of history>" else "..."
1919 bold :: SDoc -> SDoc
1920 bold c | do_bold = text start_bold <> c <> text end_bold
1923 backCmd :: String -> GHCi ()
1924 backCmd = noArgs $ do
1926 (names, _, span) <- io $ GHC.back s
1927 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1928 printTypeOfNames s names
1929 -- run the command set with ":set stop <cmd>"
1931 enqueueCommands [stop st]
1933 forwardCmd :: String -> GHCi ()
1934 forwardCmd = noArgs $ do
1936 (names, ix, span) <- io $ GHC.forward s
1937 printForUser $ (if (ix == 0)
1938 then ptext SLIT("Stopped at")
1939 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1940 printTypeOfNames s names
1941 -- run the command set with ":set stop <cmd>"
1943 enqueueCommands [stop st]
1945 -- handle the "break" command
1946 breakCmd :: String -> GHCi ()
1947 breakCmd argLine = do
1948 session <- getSession
1949 breakSwitch session $ words argLine
1951 breakSwitch :: Session -> [String] -> GHCi ()
1952 breakSwitch _session [] = do
1953 io $ putStrLn "The break command requires at least one argument."
1954 breakSwitch session (arg1:rest)
1955 | looksLikeModuleName arg1 = do
1956 mod <- wantInterpretedModule arg1
1957 breakByModule mod rest
1958 | all isDigit arg1 = do
1959 (toplevel, _) <- io $ GHC.getContext session
1961 (mod : _) -> breakByModuleLine mod (read arg1) rest
1963 io $ putStrLn "Cannot find default module for breakpoint."
1964 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1965 | otherwise = do -- try parsing it as an identifier
1966 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1967 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1968 if GHC.isGoodSrcLoc loc
1969 then findBreakAndSet (GHC.nameModule name) $
1970 findBreakByCoord (Just (GHC.srcLocFile loc))
1971 (GHC.srcLocLine loc,
1973 else noCanDo name $ text "can't find its location: " <> ppr loc
1975 noCanDo n why = printForUser $
1976 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1978 breakByModule :: Module -> [String] -> GHCi ()
1979 breakByModule mod (arg1:rest)
1980 | all isDigit arg1 = do -- looks like a line number
1981 breakByModuleLine mod (read arg1) rest
1985 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1986 breakByModuleLine mod line args
1987 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1988 | [col] <- args, all isDigit col =
1989 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1990 | otherwise = breakSyntax
1993 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1995 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1996 findBreakAndSet mod lookupTickTree = do
1997 tickArray <- getTickArray mod
1998 (breakArray, _) <- getModBreak mod
1999 case lookupTickTree tickArray of
2000 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2001 Just (tick, span) -> do
2002 success <- io $ setBreakFlag True breakArray tick
2006 recordBreak $ BreakLocation
2013 text "Breakpoint " <> ppr nm <>
2015 then text " was already set at " <> ppr span
2016 else text " activated at " <> ppr span
2018 printForUser $ text "Breakpoint could not be activated at"
2021 -- When a line number is specified, the current policy for choosing
2022 -- the best breakpoint is this:
2023 -- - the leftmost complete subexpression on the specified line, or
2024 -- - the leftmost subexpression starting on the specified line, or
2025 -- - the rightmost subexpression enclosing the specified line
2027 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2028 findBreakByLine line arr
2029 | not (inRange (bounds arr) line) = Nothing
2031 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2032 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2033 listToMaybe (sortBy (rightmost `on` snd) ticks)
2037 starts_here = [ tick | tick@(_,span) <- ticks,
2038 GHC.srcSpanStartLine span == line ]
2040 (complete,incomplete) = partition ends_here starts_here
2041 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2043 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2044 -> Maybe (BreakIndex,SrcSpan)
2045 findBreakByCoord mb_file (line, col) arr
2046 | not (inRange (bounds arr) line) = Nothing
2048 listToMaybe (sortBy (rightmost `on` snd) contains ++
2049 sortBy (leftmost_smallest `on` snd) after_here)
2053 -- the ticks that span this coordinate
2054 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2055 is_correct_file span ]
2057 is_correct_file span
2058 | Just f <- mb_file = GHC.srcSpanFile span == f
2061 after_here = [ tick | tick@(_,span) <- ticks,
2062 GHC.srcSpanStartLine span == line,
2063 GHC.srcSpanStartCol span >= col ]
2065 -- For now, use ANSI bold on terminals that we know support it.
2066 -- Otherwise, we add a line of carets under the active expression instead.
2067 -- In particular, on Windows and when running the testsuite (which sets
2068 -- TERM to vt100 for other reasons) we get carets.
2069 -- We really ought to use a proper termcap/terminfo library.
2071 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2072 where mTerm = System.Environment.getEnv "TERM"
2073 `Exception.catch` \_ -> return "TERM not set"
2075 start_bold :: String
2076 start_bold = "\ESC[1m"
2078 end_bold = "\ESC[0m"
2080 listCmd :: String -> GHCi ()
2082 mb_span <- getCurrentBreakSpan
2084 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
2085 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
2086 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
2087 listCmd str = list2 (words str)
2089 list2 :: [String] -> GHCi ()
2090 list2 [arg] | all isDigit arg = do
2091 session <- getSession
2092 (toplevel, _) <- io $ GHC.getContext session
2094 [] -> io $ putStrLn "No module to list"
2095 (mod : _) -> listModuleLine mod (read arg)
2096 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2097 mod <- wantInterpretedModule arg1
2098 listModuleLine mod (read arg2)
2100 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2101 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2102 if GHC.isGoodSrcLoc loc
2104 tickArray <- getTickArray (GHC.nameModule name)
2105 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2106 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2109 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2110 Just (_,span) -> io $ listAround span False
2112 noCanDo name $ text "can't find its location: " <>
2115 noCanDo n why = printForUser $
2116 text "cannot list source code for " <> ppr n <> text ": " <> why
2118 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2120 listModuleLine :: Module -> Int -> GHCi ()
2121 listModuleLine modl line = do
2122 session <- getSession
2123 graph <- io (GHC.getModuleGraph session)
2124 let this = filter ((== modl) . GHC.ms_mod) graph
2126 [] -> panic "listModuleLine"
2128 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2129 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2130 io $ listAround (GHC.srcLocSpan loc) False
2132 -- | list a section of a source file around a particular SrcSpan.
2133 -- If the highlight flag is True, also highlight the span using
2134 -- start_bold/end_bold.
2135 listAround :: SrcSpan -> Bool -> IO ()
2136 listAround span do_highlight = do
2137 contents <- BS.readFile (unpackFS file)
2139 lines = BS.split '\n' contents
2140 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2141 drop (line1 - 1 - pad_before) $ lines
2142 fst_line = max 1 (line1 - pad_before)
2143 line_nos = [ fst_line .. ]
2145 highlighted | do_highlight = zipWith highlight line_nos these_lines
2146 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2148 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2149 prefixed = zipWith ($) highlighted bs_line_nos
2151 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2153 file = GHC.srcSpanFile span
2154 line1 = GHC.srcSpanStartLine span
2155 col1 = GHC.srcSpanStartCol span
2156 line2 = GHC.srcSpanEndLine span
2157 col2 = GHC.srcSpanEndCol span
2159 pad_before | line1 == 1 = 0
2163 highlight | do_bold = highlight_bold
2164 | otherwise = highlight_carets
2166 highlight_bold no line prefix
2167 | no == line1 && no == line2
2168 = let (a,r) = BS.splitAt col1 line
2169 (b,c) = BS.splitAt (col2-col1) r
2171 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2173 = let (a,b) = BS.splitAt col1 line in
2174 BS.concat [prefix, a, BS.pack start_bold, b]
2176 = let (a,b) = BS.splitAt col2 line in
2177 BS.concat [prefix, a, BS.pack end_bold, b]
2178 | otherwise = BS.concat [prefix, line]
2180 highlight_carets no line prefix
2181 | no == line1 && no == line2
2182 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2183 BS.replicate (col2-col1) '^']
2185 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2188 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2190 | otherwise = BS.concat [prefix, line]
2192 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2193 nl = BS.singleton '\n'
2195 -- --------------------------------------------------------------------------
2198 getTickArray :: Module -> GHCi TickArray
2199 getTickArray modl = do
2201 let arrmap = tickarrays st
2202 case lookupModuleEnv arrmap modl of
2203 Just arr -> return arr
2205 (_breakArray, ticks) <- getModBreak modl
2206 let arr = mkTickArray (assocs ticks)
2207 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2210 discardTickArrays :: GHCi ()
2211 discardTickArrays = do
2213 setGHCiState st{tickarrays = emptyModuleEnv}
2215 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2217 = accumArray (flip (:)) [] (1, max_line)
2218 [ (line, (nm,span)) | (nm,span) <- ticks,
2219 line <- srcSpanLines span ]
2221 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2222 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2223 GHC.srcSpanEndLine span ]
2225 lookupModule :: String -> GHCi Module
2226 lookupModule modName
2227 = do session <- getSession
2228 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2230 -- don't reset the counter back to zero?
2231 discardActiveBreakPoints :: GHCi ()
2232 discardActiveBreakPoints = do
2234 mapM (turnOffBreak.snd) (breaks st)
2235 setGHCiState $ st { breaks = [] }
2237 deleteBreak :: Int -> GHCi ()
2238 deleteBreak identity = do
2240 let oldLocations = breaks st
2241 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2243 then printForUser (text "Breakpoint" <+> ppr identity <+>
2244 text "does not exist")
2246 mapM (turnOffBreak.snd) this
2247 setGHCiState $ st { breaks = rest }
2249 turnOffBreak :: BreakLocation -> GHCi Bool
2250 turnOffBreak loc = do
2251 (arr, _) <- getModBreak (breakModule loc)
2252 io $ setBreakFlag False arr (breakTick loc)
2254 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2255 getModBreak mod = do
2256 session <- getSession
2257 Just mod_info <- io $ GHC.getModuleInfo session mod
2258 let modBreaks = GHC.modInfoModBreaks mod_info
2259 let array = GHC.modBreaks_flags modBreaks
2260 let ticks = GHC.modBreaks_locs modBreaks
2261 return (array, ticks)
2263 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2264 setBreakFlag toggle array index
2265 | toggle = GHC.setBreakOn array index
2266 | otherwise = GHC.setBreakOff array index