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[!] [-s] [[*]<mod>] display the names defined by module <mod>\n" ++
171 " (!: more details; -s: sort; *: 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 -- Temporarily set the context to the module we're interested in,
1175 -- just so we can get an appropriate PrintUnqualified
1176 (as,bs) <- io (GHC.getContext s)
1177 prel_mod <- getPrelude
1178 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1179 else GHC.setContext s [modl] [])
1180 unqual <- io (GHC.getPrintUnqual s)
1181 io (GHC.setContext s as bs)
1183 mb_mod_info <- io $ GHC.getModuleInfo s modl
1185 Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1186 GHC.moduleNameString (GHC.moduleName modl)))
1188 dflags <- getDynFlags
1190 | exports_only = GHC.modInfoExports mod_info
1191 | otherwise = GHC.modInfoTopLevelScope mod_info
1194 -- sort alphabetically name, but putting
1195 -- locally-defined identifiers first.
1196 -- We would like to improve this; see #1799.
1197 sorted_names = loc_sort local ++ occ_sort external
1199 (local,external) = partition ((==modl) . nameModule) names
1200 occ_sort = sortBy (compare `on` nameOccName)
1201 -- try to sort by src location. If the first name in
1202 -- our list has a good source location, then they all should.
1204 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1205 = sortBy (compare `on` nameSrcSpan) names
1209 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1210 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1212 rdr_env <- io $ GHC.getGRE s
1214 let pefas = dopt Opt_PrintExplicitForalls dflags
1215 things | bang = catMaybes mb_things
1216 | otherwise = filtered_things
1217 pretty | bang = pprTyThing
1218 | otherwise = pprTyThingInContext
1220 labels [] = text "-- not currently imported"
1221 labels l = text $ intercalate "\n" $ map qualifier l
1222 qualifier = maybe "-- defined locally"
1223 (("-- imported from "++) . intercalate ", "
1224 . map GHC.moduleNameString)
1225 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1226 modNames = map (importInfo . GHC.getName) things
1228 -- annotate groups of imports with their import modules
1229 -- the default ordering is somewhat arbitrary, so we group
1230 -- by header and sort groups; the names themselves should
1231 -- really come in order of source appearance.. (trac #1799)
1232 annotate mts = concatMap (\(m,ts)->labels m:ts)
1233 $ sortBy cmpQualifiers $ group mts
1234 where cmpQualifiers =
1235 compare `on` (map (fmap (map moduleNameFS)) . fst)
1237 group mts@((m,_):_) = (m,map snd g) : group ng
1238 where (g,ng) = partition ((==m).fst) mts
1240 let prettyThings = map (pretty pefas) things
1241 prettyThings' | bang = annotate $ zip modNames prettyThings
1242 | otherwise = prettyThings
1243 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1244 -- ToDo: modInfoInstances currently throws an exception for
1245 -- package modules. When it works, we can do this:
1246 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1248 -----------------------------------------------------------------------------
1249 -- Setting the module context
1251 setContext :: String -> GHCi ()
1253 | all sensible mods = fn mods
1254 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1256 (fn, mods) = case str of
1257 '+':stuff -> (addToContext, words stuff)
1258 '-':stuff -> (removeFromContext, words stuff)
1259 stuff -> (newContext, words stuff)
1261 sensible ('*':m) = looksLikeModuleName m
1262 sensible m = looksLikeModuleName m
1264 separate :: Session -> [String] -> [Module] -> [Module]
1265 -> GHCi ([Module],[Module])
1266 separate _ [] as bs = return (as,bs)
1267 separate session (('*':str):ms) as bs = do
1268 m <- wantInterpretedModule str
1269 separate session ms (m:as) bs
1270 separate session (str:ms) as bs = do
1271 m <- lookupModule str
1272 separate session ms as (m:bs)
1274 newContext :: [String] -> GHCi ()
1275 newContext strs = do
1277 (as,bs) <- separate s strs [] []
1278 prel_mod <- getPrelude
1279 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1280 io $ GHC.setContext s as bs'
1283 addToContext :: [String] -> GHCi ()
1284 addToContext strs = do
1286 (as,bs) <- io $ GHC.getContext s
1288 (new_as,new_bs) <- separate s strs [] []
1290 let as_to_add = new_as \\ (as ++ bs)
1291 bs_to_add = new_bs \\ (as ++ bs)
1293 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1296 removeFromContext :: [String] -> GHCi ()
1297 removeFromContext strs = do
1299 (as,bs) <- io $ GHC.getContext s
1301 (as_to_remove,bs_to_remove) <- separate s strs [] []
1303 let as' = as \\ (as_to_remove ++ bs_to_remove)
1304 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1306 io $ GHC.setContext s as' bs'
1308 ----------------------------------------------------------------------------
1311 -- set options in the interpreter. Syntax is exactly the same as the
1312 -- ghc command line, except that certain options aren't available (-C,
1315 -- This is pretty fragile: most options won't work as expected. ToDo:
1316 -- figure out which ones & disallow them.
1318 setCmd :: String -> GHCi ()
1320 = do st <- getGHCiState
1321 let opts = options st
1322 io $ putStrLn (showSDoc (
1323 text "options currently set: " <>
1326 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1328 dflags <- getDynFlags
1329 io $ putStrLn (showSDoc (
1330 vcat (text "GHCi-specific dynamic flag settings:"
1331 :map (flagSetting dflags) ghciFlags)
1333 io $ putStrLn (showSDoc (
1334 vcat (text "other dynamic, non-language, flag settings:"
1335 :map (flagSetting dflags) nonLanguageDynFlags)
1337 where flagSetting dflags (str,f)
1338 | dopt f dflags = text " " <> text "-f" <> text str
1339 | otherwise = text " " <> text "-fno-" <> text str
1340 (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
1342 nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1344 flags = [Opt_PrintExplicitForalls
1345 ,Opt_PrintBindResult
1346 ,Opt_BreakOnException
1348 ,Opt_PrintEvldWithShow
1351 = case toArgs str of
1352 ("args":args) -> setArgs args
1353 ("prog":prog) -> setProg prog
1354 ("prompt":_) -> setPrompt (after 6)
1355 ("editor":_) -> setEditor (after 6)
1356 ("stop":_) -> setStop (after 4)
1357 wds -> setOptions wds
1358 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1360 setArgs, setProg, setOptions :: [String] -> GHCi ()
1361 setEditor, setStop, setPrompt :: String -> GHCi ()
1365 setGHCiState st{ args = args }
1369 setGHCiState st{ progname = prog }
1371 io (hPutStrLn stderr "syntax: :set prog <progname>")
1375 setGHCiState st{ editor = cmd }
1377 setStop str@(c:_) | isDigit c
1378 = do let (nm_str,rest) = break (not.isDigit) str
1381 let old_breaks = breaks st
1382 if all ((/= nm) . fst) old_breaks
1383 then printForUser (text "Breakpoint" <+> ppr nm <+>
1384 text "does not exist")
1386 let new_breaks = map fn old_breaks
1387 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1388 | otherwise = (i,loc)
1389 setGHCiState st{ breaks = new_breaks }
1392 setGHCiState st{ stop = cmd }
1394 setPrompt value = do
1397 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1398 else setGHCiState st{ prompt = remQuotes value }
1400 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1404 do -- first, deal with the GHCi opts (+s, +t, etc.)
1405 let (plus_opts, minus_opts) = partitionWith isPlus wds
1406 mapM_ setOpt plus_opts
1407 -- then, dynamic flags
1408 newDynFlags minus_opts
1410 newDynFlags :: [String] -> GHCi ()
1411 newDynFlags minus_opts = do
1412 dflags <- getDynFlags
1413 let pkg_flags = packageFlags dflags
1414 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1416 if (not (null leftovers))
1417 then throwDyn (CmdLineError ("unrecognised flags: " ++
1421 new_pkgs <- setDynFlags dflags'
1423 -- if the package flags changed, we should reset the context
1424 -- and link the new packages.
1425 dflags <- getDynFlags
1426 when (packageFlags dflags /= pkg_flags) $ do
1427 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1428 session <- getSession
1429 io (GHC.setTargets session [])
1430 io (GHC.load session LoadAllTargets)
1431 io (linkPackages dflags new_pkgs)
1432 -- package flags changed, we can't re-use any of the old context
1433 setContextAfterLoad session ([],[]) []
1437 unsetOptions :: String -> GHCi ()
1439 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1440 let opts = words str
1441 (minus_opts, rest1) = partition isMinus opts
1442 (plus_opts, rest2) = partitionWith isPlus rest1
1444 if (not (null rest2))
1445 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1448 mapM_ unsetOpt plus_opts
1450 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1451 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1453 no_flags <- mapM no_flag minus_opts
1454 newDynFlags no_flags
1456 isMinus :: String -> Bool
1457 isMinus ('-':_) = True
1460 isPlus :: String -> Either String String
1461 isPlus ('+':opt) = Left opt
1462 isPlus other = Right other
1464 setOpt, unsetOpt :: String -> GHCi ()
1467 = case strToGHCiOpt str of
1468 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1469 Just o -> setOption o
1472 = case strToGHCiOpt str of
1473 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1474 Just o -> unsetOption o
1476 strToGHCiOpt :: String -> (Maybe GHCiOption)
1477 strToGHCiOpt "s" = Just ShowTiming
1478 strToGHCiOpt "t" = Just ShowType
1479 strToGHCiOpt "r" = Just RevertCAFs
1480 strToGHCiOpt _ = Nothing
1482 optToStr :: GHCiOption -> String
1483 optToStr ShowTiming = "s"
1484 optToStr ShowType = "t"
1485 optToStr RevertCAFs = "r"
1487 -- ---------------------------------------------------------------------------
1490 showCmd :: String -> GHCi ()
1494 ["args"] -> io $ putStrLn (show (args st))
1495 ["prog"] -> io $ putStrLn (show (progname st))
1496 ["prompt"] -> io $ putStrLn (show (prompt st))
1497 ["editor"] -> io $ putStrLn (show (editor st))
1498 ["stop"] -> io $ putStrLn (show (stop st))
1499 ["modules" ] -> showModules
1500 ["bindings"] -> showBindings
1501 ["linker"] -> io showLinkerState
1502 ["breaks"] -> showBkptTable
1503 ["context"] -> showContext
1504 ["packages"] -> showPackages
1505 ["languages"] -> showLanguages
1506 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1508 showModules :: GHCi ()
1510 session <- getSession
1511 loaded_mods <- getLoadedModules session
1512 -- we want *loaded* modules only, see #1734
1513 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1514 mapM_ show_one loaded_mods
1516 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1517 getLoadedModules session = do
1518 graph <- io (GHC.getModuleGraph session)
1519 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1521 showBindings :: GHCi ()
1524 bindings <- io (GHC.getBindings s)
1525 docs <- io$ pprTypeAndContents s
1526 [ id | AnId id <- sortBy compareTyThings bindings]
1527 printForUserPartWay docs
1529 compareTyThings :: TyThing -> TyThing -> Ordering
1530 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1532 printTyThing :: TyThing -> GHCi ()
1533 printTyThing tyth = do dflags <- getDynFlags
1534 let pefas = dopt Opt_PrintExplicitForalls dflags
1535 printForUser (pprTyThing pefas tyth)
1537 showBkptTable :: GHCi ()
1540 printForUser $ prettyLocations (breaks st)
1542 showContext :: GHCi ()
1544 session <- getSession
1545 resumes <- io $ GHC.getResumeContext session
1546 printForUser $ vcat (map pp_resume (reverse resumes))
1549 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1550 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1552 showPackages :: GHCi ()
1554 pkg_flags <- fmap packageFlags getDynFlags
1555 io $ putStrLn $ showSDoc $ vcat $
1556 text ("active package flags:"++if null pkg_flags then " none" else "")
1557 : map showFlag pkg_flags
1558 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1559 io $ putStrLn $ showSDoc $ vcat $
1560 text "packages currently loaded:"
1561 : map (nest 2 . text . packageIdString) pkg_ids
1562 where showFlag (ExposePackage p) = text $ " -package " ++ p
1563 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1564 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1566 showLanguages :: GHCi ()
1568 dflags <- getDynFlags
1569 io $ putStrLn $ showSDoc $ vcat $
1570 text "active language flags:" :
1571 [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1573 -- -----------------------------------------------------------------------------
1576 completeNone :: String -> IO [String]
1577 completeNone _w = return []
1579 completeMacro, completeIdentifier, completeModule,
1580 completeHomeModule, completeSetOptions, completeFilename,
1581 completeHomeModuleOrFile
1582 :: String -> IO [String]
1585 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1586 completeWord w start end = do
1587 line <- Readline.getLineBuffer
1588 let line_words = words (dropWhile isSpace line)
1590 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1592 | ((':':c) : _) <- line_words -> do
1593 maybe_cmd <- lookupCommand c
1594 let (n,w') = selectWord (words' 0 line)
1596 Nothing -> return Nothing
1597 Just (_,_,False,complete) -> wrapCompleter complete w
1598 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1599 return (map (drop n) rets)
1600 in wrapCompleter complete' w'
1601 | ("import" : _) <- line_words ->
1602 wrapCompleter completeModule w
1604 --printf "complete %s, start = %d, end = %d\n" w start end
1605 wrapCompleter completeIdentifier w
1606 where words' _ [] = []
1607 words' n str = let (w,r) = break isSpace str
1608 (s,r') = span isSpace r
1609 in (n,w):words' (n+length w+length s) r'
1610 -- In a Haskell expression we want to parse 'a-b' as three words
1611 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1612 -- only be a single word.
1613 selectWord [] = (0,w)
1614 selectWord ((offset,x):xs)
1615 | offset+length x >= start = (start-offset,take (end-offset) x)
1616 | otherwise = selectWord xs
1618 completeCmd :: String -> IO [String]
1620 cmds <- readIORef macros_ref
1621 return (filter (w `isPrefixOf`) (map (':':)
1622 (map cmdName (builtin_commands ++ cmds))))
1624 completeMacro w = do
1625 cmds <- readIORef macros_ref
1626 return (filter (w `isPrefixOf`) (map cmdName cmds))
1628 completeIdentifier w = do
1630 rdrs <- GHC.getRdrNamesInScope s
1631 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1633 completeModule w = do
1635 dflags <- GHC.getSessionDynFlags s
1636 let pkg_mods = allExposedModules dflags
1637 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1639 completeHomeModule w = do
1641 g <- GHC.getModuleGraph s
1642 let home_mods = map GHC.ms_mod_name g
1643 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1645 completeSetOptions w = do
1646 return (filter (w `isPrefixOf`) options)
1647 where options = "args":"prog":allFlags
1649 completeFilename = Readline.filenameCompletionFunction
1651 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1653 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1654 unionComplete f1 f2 w = do
1659 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1660 wrapCompleter fun w = do
1663 [] -> return Nothing
1664 [x] -> return (Just (x,[]))
1665 xs -> case getCommonPrefix xs of
1666 "" -> return (Just ("",xs))
1667 pref -> return (Just (pref,xs))
1669 getCommonPrefix :: [String] -> String
1670 getCommonPrefix [] = ""
1671 getCommonPrefix (s:ss) = foldl common s ss
1672 where common _s "" = ""
1674 common (c:cs) (d:ds)
1675 | c == d = c : common cs ds
1678 allExposedModules :: DynFlags -> [ModuleName]
1679 allExposedModules dflags
1680 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1682 pkg_db = pkgIdMap (pkgState dflags)
1684 completeMacro = completeNone
1685 completeIdentifier = completeNone
1686 completeModule = completeNone
1687 completeHomeModule = completeNone
1688 completeSetOptions = completeNone
1689 completeFilename = completeNone
1690 completeHomeModuleOrFile=completeNone
1693 -- ---------------------------------------------------------------------------
1694 -- User code exception handling
1696 -- This is the exception handler for exceptions generated by the
1697 -- user's code and exceptions coming from children sessions;
1698 -- it normally just prints out the exception. The
1699 -- handler must be recursive, in case showing the exception causes
1700 -- more exceptions to be raised.
1702 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1703 -- raising another exception. We therefore don't put the recursive
1704 -- handler arond the flushing operation, so if stderr is closed
1705 -- GHCi will just die gracefully rather than going into an infinite loop.
1706 handler :: Exception -> GHCi Bool
1708 handler exception = do
1710 io installSignalHandlers
1711 ghciHandle handler (showException exception >> return False)
1713 showException :: Exception -> GHCi ()
1714 showException (DynException dyn) =
1715 case fromDynamic dyn of
1716 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1717 Just Interrupted -> io (putStrLn "Interrupted.")
1718 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1719 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1720 Just other_ghc_ex -> io (print other_ghc_ex)
1722 showException other_exception
1723 = io (putStrLn ("*** Exception: " ++ show other_exception))
1725 -----------------------------------------------------------------------------
1726 -- recursive exception handlers
1728 -- Don't forget to unblock async exceptions in the handler, or if we're
1729 -- in an exception loop (eg. let a = error a in a) the ^C exception
1730 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1732 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1733 ghciHandle h (GHCi m) = GHCi $ \s ->
1734 Exception.catch (m s)
1735 (\e -> unGHCi (ghciUnblock (h e)) s)
1737 ghciUnblock :: GHCi a -> GHCi a
1738 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1741 -- ----------------------------------------------------------------------------
1744 expandPath :: String -> GHCi String
1746 case dropWhile isSpace path of
1748 tilde <- io getHomeDirectory -- will fail if HOME not defined
1749 return (tilde ++ '/':d)
1753 wantInterpretedModule :: String -> GHCi Module
1754 wantInterpretedModule str = do
1755 session <- getSession
1756 modl <- lookupModule str
1757 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1758 when (not is_interpreted) $
1759 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1762 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1763 -> (Name -> GHCi ())
1765 wantNameFromInterpretedModule noCanDo str and_then = do
1766 session <- getSession
1767 names <- io $ GHC.parseName session str
1771 let modl = GHC.nameModule n
1772 if not (GHC.isExternalName n)
1773 then noCanDo n $ ppr n <>
1774 text " is not defined in an interpreted module"
1776 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1777 if not is_interpreted
1778 then noCanDo n $ text "module " <> ppr modl <>
1779 text " is not interpreted"
1782 -- -----------------------------------------------------------------------------
1783 -- commands for debugger
1785 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1786 sprintCmd = pprintCommand False False
1787 printCmd = pprintCommand True False
1788 forceCmd = pprintCommand False True
1790 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1791 pprintCommand bind force str = do
1792 session <- getSession
1793 io $ pprintClosureCommand session bind force str
1795 stepCmd :: String -> GHCi ()
1796 stepCmd [] = doContinue (const True) GHC.SingleStep
1797 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1799 stepLocalCmd :: String -> GHCi ()
1800 stepLocalCmd [] = do
1801 mb_span <- getCurrentBreakSpan
1803 Nothing -> stepCmd []
1805 Just mod <- getCurrentBreakModule
1806 current_toplevel_decl <- enclosingTickSpan mod loc
1807 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1809 stepLocalCmd expression = stepCmd expression
1811 stepModuleCmd :: String -> GHCi ()
1812 stepModuleCmd [] = do
1813 mb_span <- getCurrentBreakSpan
1815 Nothing -> stepCmd []
1817 Just span <- getCurrentBreakSpan
1818 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1819 doContinue f GHC.SingleStep
1821 stepModuleCmd expression = stepCmd expression
1823 -- | Returns the span of the largest tick containing the srcspan given
1824 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1825 enclosingTickSpan mod src = do
1826 ticks <- getTickArray mod
1827 let line = srcSpanStartLine src
1828 ASSERT (inRange (bounds ticks) line) do
1829 let enclosing_spans = [ span | (_,span) <- ticks ! line
1830 , srcSpanEnd span >= srcSpanEnd src]
1831 return . head . sortBy leftmost_largest $ enclosing_spans
1833 traceCmd :: String -> GHCi ()
1834 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1835 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1837 continueCmd :: String -> GHCi ()
1838 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1840 -- doContinue :: SingleStep -> GHCi ()
1841 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1842 doContinue pred step = do
1843 session <- getSession
1844 runResult <- io $ GHC.resume session step
1845 afterRunStmt pred runResult
1848 abandonCmd :: String -> GHCi ()
1849 abandonCmd = noArgs $ do
1851 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1852 when (not b) $ io $ putStrLn "There is no computation running."
1855 deleteCmd :: String -> GHCi ()
1856 deleteCmd argLine = do
1857 deleteSwitch $ words argLine
1859 deleteSwitch :: [String] -> GHCi ()
1861 io $ putStrLn "The delete command requires at least one argument."
1862 -- delete all break points
1863 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1864 deleteSwitch idents = do
1865 mapM_ deleteOneBreak idents
1867 deleteOneBreak :: String -> GHCi ()
1869 | all isDigit str = deleteBreak (read str)
1870 | otherwise = return ()
1872 historyCmd :: String -> GHCi ()
1874 | null arg = history 20
1875 | all isDigit arg = history (read arg)
1876 | otherwise = io $ putStrLn "Syntax: :history [num]"
1880 resumes <- io $ GHC.getResumeContext s
1882 [] -> io $ putStrLn "Not stopped at a breakpoint"
1884 let hist = GHC.resumeHistory r
1885 (took,rest) = splitAt num hist
1886 spans <- mapM (io . GHC.getHistorySpan s) took
1887 let nums = map (printf "-%-3d:") [(1::Int)..]
1888 let names = map GHC.historyEnclosingDecl took
1889 printForUser (vcat(zipWith3
1890 (\x y z -> x <+> y <+> z)
1892 (map (bold . ppr) names)
1893 (map (parens . ppr) spans)))
1894 io $ putStrLn $ if null rest then "<end of history>" else "..."
1896 bold :: SDoc -> SDoc
1897 bold c | do_bold = text start_bold <> c <> text end_bold
1900 backCmd :: String -> GHCi ()
1901 backCmd = noArgs $ do
1903 (names, _, span) <- io $ GHC.back s
1904 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1905 printTypeOfNames s names
1906 -- run the command set with ":set stop <cmd>"
1908 enqueueCommands [stop st]
1910 forwardCmd :: String -> GHCi ()
1911 forwardCmd = noArgs $ do
1913 (names, ix, span) <- io $ GHC.forward s
1914 printForUser $ (if (ix == 0)
1915 then ptext SLIT("Stopped at")
1916 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1917 printTypeOfNames s names
1918 -- run the command set with ":set stop <cmd>"
1920 enqueueCommands [stop st]
1922 -- handle the "break" command
1923 breakCmd :: String -> GHCi ()
1924 breakCmd argLine = do
1925 session <- getSession
1926 breakSwitch session $ words argLine
1928 breakSwitch :: Session -> [String] -> GHCi ()
1929 breakSwitch _session [] = do
1930 io $ putStrLn "The break command requires at least one argument."
1931 breakSwitch session (arg1:rest)
1932 | looksLikeModuleName arg1 = do
1933 mod <- wantInterpretedModule arg1
1934 breakByModule mod rest
1935 | all isDigit arg1 = do
1936 (toplevel, _) <- io $ GHC.getContext session
1938 (mod : _) -> breakByModuleLine mod (read arg1) rest
1940 io $ putStrLn "Cannot find default module for breakpoint."
1941 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1942 | otherwise = do -- try parsing it as an identifier
1943 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1944 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1945 if GHC.isGoodSrcLoc loc
1946 then findBreakAndSet (GHC.nameModule name) $
1947 findBreakByCoord (Just (GHC.srcLocFile loc))
1948 (GHC.srcLocLine loc,
1950 else noCanDo name $ text "can't find its location: " <> ppr loc
1952 noCanDo n why = printForUser $
1953 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1955 breakByModule :: Module -> [String] -> GHCi ()
1956 breakByModule mod (arg1:rest)
1957 | all isDigit arg1 = do -- looks like a line number
1958 breakByModuleLine mod (read arg1) rest
1962 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1963 breakByModuleLine mod line args
1964 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1965 | [col] <- args, all isDigit col =
1966 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1967 | otherwise = breakSyntax
1970 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1972 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1973 findBreakAndSet mod lookupTickTree = do
1974 tickArray <- getTickArray mod
1975 (breakArray, _) <- getModBreak mod
1976 case lookupTickTree tickArray of
1977 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1978 Just (tick, span) -> do
1979 success <- io $ setBreakFlag True breakArray tick
1983 recordBreak $ BreakLocation
1990 text "Breakpoint " <> ppr nm <>
1992 then text " was already set at " <> ppr span
1993 else text " activated at " <> ppr span
1995 printForUser $ text "Breakpoint could not be activated at"
1998 -- When a line number is specified, the current policy for choosing
1999 -- the best breakpoint is this:
2000 -- - the leftmost complete subexpression on the specified line, or
2001 -- - the leftmost subexpression starting on the specified line, or
2002 -- - the rightmost subexpression enclosing the specified line
2004 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2005 findBreakByLine line arr
2006 | not (inRange (bounds arr) line) = Nothing
2008 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2009 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2010 listToMaybe (sortBy (rightmost `on` snd) ticks)
2014 starts_here = [ tick | tick@(_,span) <- ticks,
2015 GHC.srcSpanStartLine span == line ]
2017 (complete,incomplete) = partition ends_here starts_here
2018 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2020 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2021 -> Maybe (BreakIndex,SrcSpan)
2022 findBreakByCoord mb_file (line, col) arr
2023 | not (inRange (bounds arr) line) = Nothing
2025 listToMaybe (sortBy (rightmost `on` snd) contains ++
2026 sortBy (leftmost_smallest `on` snd) after_here)
2030 -- the ticks that span this coordinate
2031 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2032 is_correct_file span ]
2034 is_correct_file span
2035 | Just f <- mb_file = GHC.srcSpanFile span == f
2038 after_here = [ tick | tick@(_,span) <- ticks,
2039 GHC.srcSpanStartLine span == line,
2040 GHC.srcSpanStartCol span >= col ]
2042 -- For now, use ANSI bold on terminals that we know support it.
2043 -- Otherwise, we add a line of carets under the active expression instead.
2044 -- In particular, on Windows and when running the testsuite (which sets
2045 -- TERM to vt100 for other reasons) we get carets.
2046 -- We really ought to use a proper termcap/terminfo library.
2048 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2049 where mTerm = System.Environment.getEnv "TERM"
2050 `Exception.catch` \_ -> return "TERM not set"
2052 start_bold :: String
2053 start_bold = "\ESC[1m"
2055 end_bold = "\ESC[0m"
2057 listCmd :: String -> GHCi ()
2059 mb_span <- getCurrentBreakSpan
2061 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
2062 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
2063 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
2064 listCmd str = list2 (words str)
2066 list2 :: [String] -> GHCi ()
2067 list2 [arg] | all isDigit arg = do
2068 session <- getSession
2069 (toplevel, _) <- io $ GHC.getContext session
2071 [] -> io $ putStrLn "No module to list"
2072 (mod : _) -> listModuleLine mod (read arg)
2073 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2074 mod <- wantInterpretedModule arg1
2075 listModuleLine mod (read arg2)
2077 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2078 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2079 if GHC.isGoodSrcLoc loc
2081 tickArray <- getTickArray (GHC.nameModule name)
2082 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2083 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2086 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2087 Just (_,span) -> io $ listAround span False
2089 noCanDo name $ text "can't find its location: " <>
2092 noCanDo n why = printForUser $
2093 text "cannot list source code for " <> ppr n <> text ": " <> why
2095 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2097 listModuleLine :: Module -> Int -> GHCi ()
2098 listModuleLine modl line = do
2099 session <- getSession
2100 graph <- io (GHC.getModuleGraph session)
2101 let this = filter ((== modl) . GHC.ms_mod) graph
2103 [] -> panic "listModuleLine"
2105 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2106 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2107 io $ listAround (GHC.srcLocSpan loc) False
2109 -- | list a section of a source file around a particular SrcSpan.
2110 -- If the highlight flag is True, also highlight the span using
2111 -- start_bold/end_bold.
2112 listAround :: SrcSpan -> Bool -> IO ()
2113 listAround span do_highlight = do
2114 contents <- BS.readFile (unpackFS file)
2116 lines = BS.split '\n' contents
2117 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2118 drop (line1 - 1 - pad_before) $ lines
2119 fst_line = max 1 (line1 - pad_before)
2120 line_nos = [ fst_line .. ]
2122 highlighted | do_highlight = zipWith highlight line_nos these_lines
2123 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2125 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2126 prefixed = zipWith ($) highlighted bs_line_nos
2128 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2130 file = GHC.srcSpanFile span
2131 line1 = GHC.srcSpanStartLine span
2132 col1 = GHC.srcSpanStartCol span
2133 line2 = GHC.srcSpanEndLine span
2134 col2 = GHC.srcSpanEndCol span
2136 pad_before | line1 == 1 = 0
2140 highlight | do_bold = highlight_bold
2141 | otherwise = highlight_carets
2143 highlight_bold no line prefix
2144 | no == line1 && no == line2
2145 = let (a,r) = BS.splitAt col1 line
2146 (b,c) = BS.splitAt (col2-col1) r
2148 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2150 = let (a,b) = BS.splitAt col1 line in
2151 BS.concat [prefix, a, BS.pack start_bold, b]
2153 = let (a,b) = BS.splitAt col2 line in
2154 BS.concat [prefix, a, BS.pack end_bold, b]
2155 | otherwise = BS.concat [prefix, line]
2157 highlight_carets no line prefix
2158 | no == line1 && no == line2
2159 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2160 BS.replicate (col2-col1) '^']
2162 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2165 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2167 | otherwise = BS.concat [prefix, line]
2169 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2170 nl = BS.singleton '\n'
2172 -- --------------------------------------------------------------------------
2175 getTickArray :: Module -> GHCi TickArray
2176 getTickArray modl = do
2178 let arrmap = tickarrays st
2179 case lookupModuleEnv arrmap modl of
2180 Just arr -> return arr
2182 (_breakArray, ticks) <- getModBreak modl
2183 let arr = mkTickArray (assocs ticks)
2184 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2187 discardTickArrays :: GHCi ()
2188 discardTickArrays = do
2190 setGHCiState st{tickarrays = emptyModuleEnv}
2192 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2194 = accumArray (flip (:)) [] (1, max_line)
2195 [ (line, (nm,span)) | (nm,span) <- ticks,
2196 line <- srcSpanLines span ]
2198 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2199 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2200 GHC.srcSpanEndLine span ]
2202 lookupModule :: String -> GHCi Module
2203 lookupModule modName
2204 = do session <- getSession
2205 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2207 -- don't reset the counter back to zero?
2208 discardActiveBreakPoints :: GHCi ()
2209 discardActiveBreakPoints = do
2211 mapM (turnOffBreak.snd) (breaks st)
2212 setGHCiState $ st { breaks = [] }
2214 deleteBreak :: Int -> GHCi ()
2215 deleteBreak identity = do
2217 let oldLocations = breaks st
2218 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2220 then printForUser (text "Breakpoint" <+> ppr identity <+>
2221 text "does not exist")
2223 mapM (turnOffBreak.snd) this
2224 setGHCiState $ st { breaks = rest }
2226 turnOffBreak :: BreakLocation -> GHCi Bool
2227 turnOffBreak loc = do
2228 (arr, _) <- getModBreak (breakModule loc)
2229 io $ setBreakFlag False arr (breakTick loc)
2231 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2232 getModBreak mod = do
2233 session <- getSession
2234 Just mod_info <- io $ GHC.getModuleInfo session mod
2235 let modBreaks = GHC.modInfoModBreaks mod_info
2236 let array = GHC.modBreaks_flags modBreaks
2237 let ticks = GHC.modBreaks_locs modBreaks
2238 return (array, ticks)
2240 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2241 setBreakFlag toggle array index
2242 | toggle = GHC.setBreakOn array index
2243 | otherwise = GHC.setBreakOff array index