1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS -#include "Linker.h" #-}
5 -----------------------------------------------------------------------------
7 -- GHC Interactive User Interface
9 -- (c) The GHC Team 2005-2006
11 -----------------------------------------------------------------------------
13 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
15 #include "HsVersions.h"
17 import qualified GhciMonad
18 import GhciMonad hiding (runStmt)
23 import qualified GHC hiding (resume, runStmt)
24 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
25 Module, ModuleName, TyThing(..), Phase,
26 BreakIndex, SrcSpan, Resume, SingleStep )
36 import HscTypes ( implicitTyThings )
37 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
38 import Outputable hiding (printForUser, printForUserPartWay)
39 import Module -- for ModuleEnv
43 -- Other random utilities
46 import BasicTypes hiding (isTopLevel)
47 import Panic hiding (showException)
53 import Maybes ( orElse )
57 #ifndef mingw32_HOST_OS
58 import System.Posix hiding (getEnv)
60 import GHC.ConsoleHandler ( flushConsole )
61 import qualified System.Win32
65 import Control.Concurrent ( yield ) -- Used in readline loop
66 import System.Console.Editline.Readline as Readline
72 -- import Control.Concurrent
74 import System.FilePath
75 import qualified Data.ByteString.Char8 as BS
79 import System.Environment
80 import System.Exit ( exitWith, ExitCode(..) )
81 import System.Directory
83 import System.IO.Error as IO
87 import Control.Monad as Monad
91 import GHC.Exts ( unsafeCoerce# )
92 import GHC.IOBase ( IOErrorType(InvalidArgument) )
95 import Data.IORef ( IORef, readIORef, writeIORef )
98 import System.Posix.Internals ( setNonBlockingFD )
101 -----------------------------------------------------------------------------
103 ghciWelcomeMsg :: String
104 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
105 ": http://www.haskell.org/ghc/ :? for help"
107 cmdName :: Command -> String
108 cmdName (n,_,_,_) = n
110 GLOBAL_VAR(macros_ref, [], [Command])
112 builtin_commands :: [Command]
114 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
115 ("?", keepGoing help, Nothing, completeNone),
116 ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename),
117 ("abandon", keepGoing abandonCmd, Nothing, completeNone),
118 ("break", keepGoing breakCmd, Nothing, completeIdentifier),
119 ("back", keepGoing backCmd, Nothing, completeNone),
120 ("browse", keepGoing (browseCmd False), Nothing, completeModule),
121 ("browse!", keepGoing (browseCmd True), Nothing, completeModule),
122 ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename),
123 ("check", keepGoing checkModule, Nothing, completeHomeModule),
124 ("continue", keepGoing continueCmd, Nothing, completeNone),
125 ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier),
126 ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename),
127 ("def", keepGoing (defineMacro False), Nothing, completeIdentifier),
128 ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier),
129 ("delete", keepGoing deleteCmd, Nothing, completeNone),
130 ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
131 ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
132 ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename),
133 ("force", keepGoing forceCmd, Nothing, completeIdentifier),
134 ("forward", keepGoing forwardCmd, Nothing, completeNone),
135 ("help", keepGoing help, Nothing, completeNone),
136 ("history", keepGoing historyCmd, Nothing, completeNone),
137 ("info", keepGoing info, Nothing, completeIdentifier),
138 ("kind", keepGoing kindOfType, Nothing, completeIdentifier),
139 ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile),
140 ("list", keepGoing listCmd, Nothing, completeNone),
141 ("module", keepGoing setContext, Nothing, completeModule),
142 ("main", keepGoing runMain, Nothing, completeIdentifier),
143 ("print", keepGoing printCmd, Nothing, completeIdentifier),
144 ("quit", quit, Nothing, completeNone),
145 ("reload", keepGoing reloadModule, Nothing, completeNone),
146 ("run", keepGoing runRun, Nothing, completeIdentifier),
147 ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions),
148 ("show", keepGoing showCmd, Nothing, completeNone),
149 ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier),
150 ("step", keepGoing stepCmd, Nothing, completeIdentifier),
151 ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier),
152 ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier),
153 ("type", keepGoing typeOfExpr, Nothing, completeIdentifier),
154 ("trace", keepGoing traceCmd, Nothing, completeIdentifier),
155 ("undef", keepGoing undefineMacro, Nothing, completeMacro),
156 ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions)
160 -- We initialize readline (in the interactiveUI function) to use
161 -- word_break_chars as the default set of completion word break characters.
162 -- This can be overridden for a particular command (for example, filename
163 -- expansion shouldn't consider '/' to be a word break) by setting the third
164 -- entry in the Command tuple above.
166 -- NOTE: in order for us to override the default correctly, any custom entry
167 -- must be a SUBSET of word_break_chars.
169 word_break_chars :: String
170 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
171 specials = "(),;[]`{}"
173 in spaces ++ specials ++ symbols
176 flagWordBreakChars, filenameWordBreakChars :: String
177 flagWordBreakChars = " \t\n"
178 filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults
181 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
182 keepGoing a str = a str >> return False
184 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
186 = do case toArgs str of
187 Left err -> io (hPutStrLn stderr err)
191 shortHelpText :: String
192 shortHelpText = "use :? for help.\n"
196 " Commands available from the prompt:\n" ++
198 " <statement> evaluate/run <statement>\n" ++
199 " : repeat last command\n" ++
200 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
201 " :add <filename> ... add module(s) to the current target set\n" ++
202 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
203 " (!: more details; *: all top-level names)\n" ++
204 " :cd <dir> change directory to <dir>\n" ++
205 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
206 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
207 " :def <cmd> <expr> define a command :<cmd>\n" ++
208 " :edit <file> edit file\n" ++
209 " :edit edit last module\n" ++
210 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
211 " :help, :? display this list of commands\n" ++
212 " :info [<name> ...] display information about the given names\n" ++
213 " :kind <type> show the kind of <type>\n" ++
214 " :load <filename> ... load module(s) and their dependents\n" ++
215 " :main [<arguments> ...] run the main function with the given arguments\n" ++
216 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
217 " :quit exit GHCi\n" ++
218 " :reload reload the current module set\n" ++
219 " :run function [<arguments> ...] run the function with the given arguments\n" ++
220 " :type <expr> show the type of <expr>\n" ++
221 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
222 " :!<command> run the shell command <command>\n" ++
224 " -- Commands for debugging:\n" ++
226 " :abandon at a breakpoint, abandon current computation\n" ++
227 " :back go back in the history (after :trace)\n" ++
228 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
229 " :break <name> set a breakpoint on the specified function\n" ++
230 " :continue resume after a breakpoint\n" ++
231 " :delete <number> delete the specified breakpoint\n" ++
232 " :delete * delete all breakpoints\n" ++
233 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
234 " :forward go forward in the history (after :back)\n" ++
235 " :history [<n>] after :trace, show the execution history\n" ++
236 " :list show the source code around current breakpoint\n" ++
237 " :list identifier show the source code for <identifier>\n" ++
238 " :list [<module>] <line> show the source code around line number <line>\n" ++
239 " :print [<name> ...] prints a value without forcing its computation\n" ++
240 " :sprint [<name> ...] simplifed version of :print\n" ++
241 " :step single-step after stopping at a breakpoint\n"++
242 " :step <expr> single-step into <expr>\n"++
243 " :steplocal single-step within the current top-level binding\n"++
244 " :stepmodule single-step restricted to the current module\n"++
245 " :trace trace after stopping at a breakpoint\n"++
246 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
249 " -- Commands for changing settings:\n" ++
251 " :set <option> ... set options\n" ++
252 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
253 " :set prog <progname> set the value returned by System.getProgName\n" ++
254 " :set prompt <prompt> set the prompt used in GHCi\n" ++
255 " :set editor <cmd> set the command used for :edit\n" ++
256 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
257 " :unset <option> ... unset options\n" ++
259 " Options for ':set' and ':unset':\n" ++
261 " +r revert top-level expressions after each evaluation\n" ++
262 " +s print timing/memory stats after each evaluation\n" ++
263 " +t print type after evaluation\n" ++
264 " -<flags> most GHC command line flags can also be set here\n" ++
265 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
266 " for GHCi-specific flags, see User's Guide,\n"++
267 " Flag reference, Interactive-mode options\n" ++
269 " -- Commands for displaying information:\n" ++
271 " :show bindings show the current bindings made at the prompt\n" ++
272 " :show breaks show the active breakpoints\n" ++
273 " :show context show the breakpoint context\n" ++
274 " :show modules show the currently loaded modules\n" ++
275 " :show packages show the currently active package flags\n" ++
276 " :show languages show the currently active language flags\n" ++
277 " :show <setting> show value of <setting>, which is one of\n" ++
278 " [args, prog, prompt, editor, stop]\n" ++
281 findEditor :: IO String
286 win <- System.Win32.getWindowsDirectory
287 return (win </> "notepad.exe")
292 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String]
294 interactiveUI session srcs maybe_exprs = do
295 -- HACK! If we happen to get into an infinite loop (eg the user
296 -- types 'let x=x in x' at the prompt), then the thread will block
297 -- on a blackhole, and become unreachable during GC. The GC will
298 -- detect that it is unreachable and send it the NonTermination
299 -- exception. However, since the thread is unreachable, everything
300 -- it refers to might be finalized, including the standard Handles.
301 -- This sounds like a bug, but we don't have a good solution right
307 -- Initialise buffering for the *interpreted* I/O system
308 initInterpBuffering session
310 when (isNothing maybe_exprs) $ do
311 -- Only for GHCi (not runghc and ghc -e):
313 -- Turn buffering off for the compiled program's stdout/stderr
315 -- Turn buffering off for GHCi's stdout
317 hSetBuffering stdout NoBuffering
318 -- We don't want the cmd line to buffer any input that might be
319 -- intended for the program, so unbuffer stdin.
320 hSetBuffering stdin NoBuffering
323 is_tty <- hIsTerminalDevice stdin
324 when is_tty $ withReadline $ do
328 (\dir -> Readline.readHistory (dir </> "ghci_history"))
331 Readline.setAttemptedCompletionFunction (Just completeWord)
332 --Readline.parseAndBind "set show-all-if-ambiguous 1"
334 Readline.setBasicWordBreakCharacters word_break_chars
335 Readline.setCompleterWordBreakCharacters word_break_chars
336 Readline.setCompletionAppendCharacter Nothing
339 -- initial context is just the Prelude
340 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") Nothing
341 GHC.setContext session [] [prel_mod]
343 default_editor <- findEditor
345 cwd <- getCurrentDirectory
347 startGHCi (runGHCi srcs maybe_exprs)
348 GHCiState{ progname = "<interactive>",
352 editor = default_editor,
358 tickarrays = emptyModuleEnv,
359 last_command = Nothing,
363 ghc_e = isJust maybe_exprs
367 Readline.stifleHistory 100
368 withGhcAppData (\dir -> Readline.writeHistory (dir </> "ghci_history"))
370 Readline.resetTerminal Nothing
375 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
376 withGhcAppData right left = do
377 either_dir <- IO.try (getAppUserDataDirectory "ghc")
379 Right dir -> right dir
383 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
384 runGHCi paths maybe_exprs = do
386 read_dot_files = not opt_IgnoreDotGhci
388 current_dir = return (Just ".ghci")
390 app_user_dir = io $ withGhcAppData
391 (\dir -> return (Just (dir </> "ghci.conf")))
395 either_dir <- io $ IO.try (getEnv "HOME")
397 Right home -> return (Just (home </> ".ghci"))
400 sourceConfigFile :: FilePath -> GHCi ()
401 sourceConfigFile file = do
402 exists <- io $ doesFileExist file
404 dir_ok <- io $ checkPerms (getDirectory file)
405 file_ok <- io $ checkPerms file
406 when (dir_ok && file_ok) $ do
407 either_hdl <- io $ IO.try (openFile file ReadMode)
410 Right hdl -> runCommands (fileLoop hdl False False)
412 getDirectory f = case takeDirectory f of "" -> "."; d -> d
414 when (read_dot_files) $ do
415 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
416 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
417 mapM_ sourceConfigFile (nub cfgs)
418 -- nub, because we don't want to read .ghci twice if the
421 -- Perform a :load for files given on the GHCi command line
422 -- When in -e mode, if the load fails then we want to stop
423 -- immediately rather than going on to evaluate the expression.
424 when (not (null paths)) $ do
425 ok <- ghciHandle (\e -> do showException e; return Failed) $
427 when (isJust maybe_exprs && failed ok) $
428 io (exitWith (ExitFailure 1))
430 -- if verbosity is greater than 0, or we are connected to a
431 -- terminal, display the prompt in the interactive loop.
432 is_tty <- io (hIsTerminalDevice stdin)
433 dflags <- getDynFlags
434 let show_prompt = verbosity dflags > 0 || is_tty
439 #if defined(mingw32_HOST_OS)
440 -- The win32 Console API mutates the first character of
441 -- type-ahead when reading from it in a non-buffered manner. Work
442 -- around this by flushing the input buffer of type-ahead characters,
443 -- but only if stdin is available.
444 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
446 Left err | isDoesNotExistError err -> return ()
447 | otherwise -> io (ioError err)
448 Right () -> return ()
450 -- enter the interactive loop
451 interactiveLoop is_tty show_prompt
453 -- just evaluate the expression we were given
454 enqueueCommands exprs
455 let handle e = do st <- getGHCiState
456 -- Jump through some hoops to get the
457 -- current progname in the exception text:
458 -- <progname>: <exception>
459 io $ withProgName (progname st)
460 -- this used to be topHandlerFastExit, see #2228
462 runCommands' handle (return Nothing)
465 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
467 interactiveLoop :: Bool -> Bool -> GHCi ()
468 interactiveLoop is_tty show_prompt =
469 -- Ignore ^C exceptions caught here
470 ghciHandleGhcException (\e -> case e of
472 #if defined(mingw32_HOST_OS)
475 interactiveLoop is_tty show_prompt
476 _other -> return ()) $
478 ghciUnblock $ do -- unblock necessary if we recursed from the
479 -- exception handler above.
481 -- read commands from stdin
484 then runCommands readlineLoop
485 else runCommands (fileLoop stdin show_prompt is_tty)
487 runCommands (fileLoop stdin show_prompt is_tty)
491 -- NOTE: We only read .ghci files if they are owned by the current user,
492 -- and aren't world writable. Otherwise, we could be accidentally
493 -- running code planted by a malicious third party.
495 -- Furthermore, We only read ./.ghci if . is owned by the current user
496 -- and isn't writable by anyone else. I think this is sufficient: we
497 -- don't need to check .. and ../.. etc. because "." always refers to
498 -- the same directory while a process is running.
500 checkPerms :: String -> IO Bool
501 #ifdef mingw32_HOST_OS
506 handleIO (\_ -> return False) $ do
507 st <- getFileStatus name
509 if fileOwner st /= me then do
510 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
513 let mode = fileMode st
514 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
515 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
517 putStrLn $ "*** WARNING: " ++ name ++
518 " is writable by someone else, IGNORING!"
523 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
524 fileLoop hdl show_prompt is_tty = do
525 when show_prompt $ do
528 l <- io (IO.try (hGetLine hdl))
530 Left e | isEOFError e -> return Nothing
531 | InvalidArgument <- etype -> return Nothing
532 | otherwise -> io (ioError e)
533 where etype = ioeGetErrorType e
534 -- treat InvalidArgument in the same way as EOF:
535 -- this can happen if the user closed stdin, or
536 -- perhaps did getContents which closes stdin at
539 str <- io $ consoleInputToUnicode is_tty l
542 #ifdef mingw32_HOST_OS
543 -- Convert the console input into Unicode according to the current code page.
544 -- The Windows console stores Unicode characters directly, so this is a
545 -- rather roundabout way of doing things... oh well.
546 -- See #782, #1483, #1649
547 consoleInputToUnicode :: Bool -> String -> IO String
548 consoleInputToUnicode is_tty str
550 cp <- System.Win32.getConsoleCP
551 System.Win32.stringToUnicode cp str
553 decodeStringAsUTF8 str
555 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
557 consoleInputToUnicode :: Bool -> String -> IO String
558 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
561 decodeStringAsUTF8 :: String -> IO String
562 decodeStringAsUTF8 str =
563 withCStringLen str $ \(cstr,len) ->
564 utf8DecodeString (castPtr cstr :: Ptr Word8) len
566 mkPrompt :: GHCi String
568 session <- getSession
569 (toplevs,exports) <- io (GHC.getContext session)
570 resumes <- io $ GHC.getResumeContext session
571 -- st <- getGHCiState
577 let ix = GHC.resumeHistoryIx r
579 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
581 let hist = GHC.resumeHistory r !! (ix-1)
582 span <- io$ GHC.getHistorySpan session hist
583 return (brackets (ppr (negate ix) <> char ':'
584 <+> ppr span) <> space)
586 dots | _:rs <- resumes, not (null rs) = text "... "
593 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
594 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
595 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
596 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
597 hsep (map (ppr . GHC.moduleName) exports)
599 deflt_prompt = dots <> context_bit <> modules_bit
601 f ('%':'s':xs) = deflt_prompt <> f xs
602 f ('%':'%':xs) = char '%' <> f xs
603 f (x:xs) = char x <> f xs
607 return (showSDoc (f (prompt st)))
611 readlineLoop :: GHCi (Maybe String)
614 saveSession -- for use by completion
616 l <- io $ withReadline (readline prompt)
619 Nothing -> return Nothing
620 Just "" -> return (Just "") -- Don't put empty lines in the history
623 str <- io $ consoleInputToUnicode True l
626 withReadline :: IO a -> IO a
627 withReadline = bracket_ stopTimer (do startTimer; setNonBlockingFD 0)
628 -- Two problems are being worked around here:
629 -- 1. readline sometimes puts stdin into blocking mode,
630 -- so we need to put it back for the IO library
631 -- 2. editline doesn't handle some of its system calls returning
632 -- EINTR, so our timer signal confuses it, hence we turn off
633 -- the timer signal when making calls to editline. (#2277)
634 -- If editline is ever fixed, we can remove this.
636 -- These come from the RTS
637 foreign import ccall unsafe startTimer :: IO ()
638 foreign import ccall unsafe stopTimer :: IO ()
641 queryQueue :: GHCi (Maybe String)
646 c:cs -> do setGHCiState st{ cmdqueue = cs }
649 runCommands :: GHCi (Maybe String) -> GHCi ()
650 runCommands = runCommands' handler
652 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
653 -> GHCi (Maybe String) -> GHCi ()
654 runCommands' eh getCmd = do
655 mb_cmd <- noSpace queryQueue
656 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
660 b <- ghciHandle eh (doCommand c)
661 if b then return () else runCommands' eh getCmd
663 noSpace q = q >>= maybe (return Nothing)
664 (\c->case removeSpaces c of
666 ":{" -> multiLineCmd q
667 c -> return (Just c) )
671 setGHCiState st{ prompt = "%s| " }
672 mb_cmd <- collectCommand q ""
673 getGHCiState >>= \st->setGHCiState st{ prompt = p }
675 -- we can't use removeSpaces for the sublines here, so
676 -- multiline commands are somewhat more brittle against
677 -- fileformat errors (such as \r in dos input on unix),
678 -- we get rid of any extra spaces for the ":}" test;
679 -- we also avoid silent failure if ":}" is not found;
680 -- and since there is no (?) valid occurrence of \r (as
681 -- opposed to its String representation, "\r") inside a
682 -- ghci command, we replace any such with ' ' (argh:-(
683 collectCommand q c = q >>=
684 maybe (io (ioError collectError))
685 (\l->if removeSpaces l == ":}"
686 then return (Just $ removeSpaces c)
687 else collectCommand q (c++map normSpace l))
688 where normSpace '\r' = ' '
690 -- QUESTION: is userError the one to use here?
691 collectError = userError "unterminated multiline command :{ .. :}"
692 doCommand (':' : cmd) = specialCommand cmd
693 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
696 enqueueCommands :: [String] -> GHCi ()
697 enqueueCommands cmds = do
699 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
702 runStmt :: String -> SingleStep -> GHCi Bool
704 | null (filter (not.isSpace) stmt) = return False
705 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
707 = do result <- GhciMonad.runStmt stmt step
708 afterRunStmt (const True) result
710 --afterRunStmt :: GHC.RunResult -> GHCi Bool
711 -- False <=> the statement failed to compile
712 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
713 afterRunStmt _ (GHC.RunException e) = throw e
714 afterRunStmt step_here run_result = do
715 session <- getSession
716 resumes <- io $ GHC.getResumeContext session
718 GHC.RunOk names -> do
719 show_types <- isOptionSet ShowType
720 when show_types $ printTypeOfNames session names
721 GHC.RunBreak _ names mb_info
722 | isNothing mb_info ||
723 step_here (GHC.resumeSpan $ head resumes) -> do
724 printForUser $ ptext (sLit "Stopped at") <+>
725 ppr (GHC.resumeSpan $ head resumes)
726 -- printTypeOfNames session names
727 let namesSorted = sortBy compareNames names
728 tythings <- catMaybes `liftM`
729 io (mapM (GHC.lookupName session) namesSorted)
730 docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
731 printForUserPartWay docs
732 maybe (return ()) runBreakCmd mb_info
733 -- run the command set with ":set stop <cmd>"
735 enqueueCommands [stop st]
737 | otherwise -> resume GHC.SingleStep >>=
738 afterRunStmt step_here >> return ()
742 io installSignalHandlers
743 b <- isOptionSet RevertCAFs
746 return (case run_result of GHC.RunOk _ -> True; _ -> False)
748 runBreakCmd :: GHC.BreakInfo -> GHCi ()
749 runBreakCmd info = do
750 let mod = GHC.breakInfo_module info
751 nm = GHC.breakInfo_number info
753 case [ loc | (_,loc) <- breaks st,
754 breakModule loc == mod, breakTick loc == nm ] of
756 loc:_ | null cmd -> return ()
757 | otherwise -> do enqueueCommands [cmd]; return ()
758 where cmd = onBreakCmd loc
760 printTypeOfNames :: Session -> [Name] -> GHCi ()
761 printTypeOfNames session names
762 = mapM_ (printTypeOfName session) $ sortBy compareNames names
764 compareNames :: Name -> Name -> Ordering
765 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
766 where compareWith n = (getOccString n, getSrcSpan n)
768 printTypeOfName :: Session -> Name -> GHCi ()
769 printTypeOfName session n
770 = do maybe_tything <- io (GHC.lookupName session n)
771 case maybe_tything of
773 Just thing -> printTyThing thing
776 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
778 specialCommand :: String -> GHCi Bool
779 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
780 specialCommand str = do
781 let (cmd,rest) = break isSpace str
782 maybe_cmd <- lookupCommand cmd
784 GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
786 do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
790 do io $ hPutStr stdout ("there is no last command to perform\n"
794 lookupCommand :: String -> GHCi (MaybeCommand)
795 lookupCommand "" = do
797 case last_command st of
798 Just c -> return $ GotCommand c
799 Nothing -> return NoLastCommand
800 lookupCommand str = do
801 mc <- io $ lookupCommand' str
803 setGHCiState st{ last_command = mc }
805 Just c -> GotCommand c
806 Nothing -> BadCommand
808 lookupCommand' :: String -> IO (Maybe Command)
809 lookupCommand' str = do
810 macros <- readIORef macros_ref
811 let cmds = builtin_commands ++ macros
812 -- look for exact match first, then the first prefix match
813 return $ case [ c | c <- cmds, str == cmdName c ] of
815 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
819 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
820 getCurrentBreakSpan = do
821 session <- getSession
822 resumes <- io $ GHC.getResumeContext session
826 let ix = GHC.resumeHistoryIx r
828 then return (Just (GHC.resumeSpan r))
830 let hist = GHC.resumeHistory r !! (ix-1)
831 span <- io $ GHC.getHistorySpan session hist
834 getCurrentBreakModule :: GHCi (Maybe Module)
835 getCurrentBreakModule = do
836 session <- getSession
837 resumes <- io $ GHC.getResumeContext session
841 let ix = GHC.resumeHistoryIx r
843 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
845 let hist = GHC.resumeHistory r !! (ix-1)
846 return $ Just $ GHC.getHistoryModule hist
848 -----------------------------------------------------------------------------
851 noArgs :: GHCi () -> String -> GHCi ()
853 noArgs _ _ = io $ putStrLn "This command takes no arguments"
855 help :: String -> GHCi ()
856 help _ = io (putStr helpText)
858 info :: String -> GHCi ()
859 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
860 info s = do { let names = words s
861 ; session <- getSession
862 ; dflags <- getDynFlags
863 ; let pefas = dopt Opt_PrintExplicitForalls dflags
864 ; mapM_ (infoThing pefas session) names }
866 infoThing pefas session str = io $ do
867 names <- GHC.parseName session str
868 mb_stuffs <- mapM (GHC.getInfo session) names
869 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
870 unqual <- GHC.getPrintUnqual session
871 putStrLn (showSDocForUser unqual $
872 vcat (intersperse (text "") $
873 map (pprInfo pefas) filtered))
875 -- Filter out names whose parent is also there Good
876 -- example is '[]', which is both a type and data
877 -- constructor in the same type
878 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
879 filterOutChildren get_thing xs
880 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
882 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
884 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
885 pprInfo pefas (thing, fixity, insts)
886 = pprTyThingInContextLoc pefas thing
887 $$ show_fixity fixity
888 $$ vcat (map GHC.pprInstance insts)
891 | fix == GHC.defaultFixity = empty
892 | otherwise = ppr fix <+> ppr (GHC.getName thing)
894 runMain :: String -> GHCi ()
895 runMain s = case toArgs s of
896 Left err -> io (hPutStrLn stderr err)
898 do dflags <- getDynFlags
899 case mainFunIs dflags of
900 Nothing -> doWithArgs args "main"
901 Just f -> doWithArgs args f
903 runRun :: String -> GHCi ()
904 runRun s = case toCmdArgs s of
905 Left err -> io (hPutStrLn stderr err)
906 Right (cmd, args) -> doWithArgs args cmd
908 doWithArgs :: [String] -> String -> GHCi ()
909 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
910 show args ++ " (" ++ cmd ++ ")"]
912 addModule :: [FilePath] -> GHCi ()
914 revertCAFs -- always revert CAFs on load/add.
915 files <- mapM expandPath files
916 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
917 session <- getSession
918 io (mapM_ (GHC.addTarget session) targets)
919 prev_context <- io $ GHC.getContext session
920 ok <- io (GHC.load session LoadAllTargets)
921 afterLoad ok session False prev_context
923 changeDirectory :: String -> GHCi ()
924 changeDirectory "" = do
925 -- :cd on its own changes to the user's home directory
926 either_dir <- io (IO.try getHomeDirectory)
929 Right dir -> changeDirectory dir
930 changeDirectory dir = do
931 session <- getSession
932 graph <- io (GHC.getModuleGraph session)
933 when (not (null graph)) $
934 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
935 prev_context <- io $ GHC.getContext session
936 io (GHC.setTargets session [])
937 io (GHC.load session LoadAllTargets)
938 setContextAfterLoad session prev_context False []
939 io (GHC.workingDirectoryChanged session)
940 dir <- expandPath dir
941 io (setCurrentDirectory dir)
943 editFile :: String -> GHCi ()
945 do file <- if null str then chooseEditFile else return str
949 $ ghcError (CmdLineError "editor not set, use :set editor")
950 io $ system (cmd ++ ' ':file)
953 -- The user didn't specify a file so we pick one for them.
954 -- Our strategy is to pick the first module that failed to load,
955 -- or otherwise the first target.
957 -- XXX: Can we figure out what happened if the depndecy analysis fails
958 -- (e.g., because the porgrammeer mistyped the name of a module)?
959 -- XXX: Can we figure out the location of an error to pass to the editor?
960 -- XXX: if we could figure out the list of errors that occured during the
961 -- last load/reaload, then we could start the editor focused on the first
963 chooseEditFile :: GHCi String
965 do session <- getSession
966 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
968 graph <- io (GHC.getModuleGraph session)
969 failed_graph <- filterM hasFailed graph
970 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
972 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
975 case pick (order failed_graph) of
976 Just file -> return file
978 do targets <- io (GHC.getTargets session)
979 case msum (map fromTarget targets) of
980 Just file -> return file
981 Nothing -> ghcError (CmdLineError "No files to edit.")
983 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
984 fromTarget _ = Nothing -- when would we get a module target?
986 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
987 defineMacro overwrite s = do
988 let (macro_name, definition) = break isSpace s
989 macros <- io (readIORef macros_ref)
990 let defined = map cmdName macros
993 then io $ putStrLn "no macros defined"
994 else io $ putStr ("the following macros are defined:\n" ++
997 if (not overwrite && macro_name `elem` defined)
998 then ghcError (CmdLineError
999 ("macro '" ++ macro_name ++ "' is already defined"))
1002 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
1004 -- give the expression a type signature, so we can be sure we're getting
1005 -- something of the right type.
1006 let new_expr = '(' : definition ++ ") :: String -> IO String"
1008 -- compile the expression
1010 maybe_hv <- io (GHC.compileExpr cms new_expr)
1012 Nothing -> return ()
1013 Just hv -> io (writeIORef macros_ref --
1014 (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)]))
1016 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
1018 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
1019 enqueueCommands (lines str)
1022 undefineMacro :: String -> GHCi ()
1023 undefineMacro str = mapM_ undef (words str)
1024 where undef macro_name = do
1025 cmds <- io (readIORef macros_ref)
1026 if (macro_name `notElem` map cmdName cmds)
1027 then ghcError (CmdLineError
1028 ("macro '" ++ macro_name ++ "' is not defined"))
1030 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
1032 cmdCmd :: String -> GHCi ()
1034 let expr = '(' : str ++ ") :: IO String"
1035 session <- getSession
1036 maybe_hv <- io (GHC.compileExpr session expr)
1038 Nothing -> return ()
1040 cmds <- io $ (unsafeCoerce# hv :: IO String)
1041 enqueueCommands (lines cmds)
1044 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1045 loadModule fs = timeIt (loadModule' fs)
1047 loadModule_ :: [FilePath] -> GHCi ()
1048 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
1050 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1051 loadModule' files = do
1052 session <- getSession
1053 prev_context <- io $ GHC.getContext session
1056 discardActiveBreakPoints
1057 io (GHC.setTargets session [])
1058 io (GHC.load session LoadAllTargets)
1061 let (filenames, phases) = unzip files
1062 exp_filenames <- mapM expandPath filenames
1063 let files' = zip exp_filenames phases
1064 targets <- io (mapM (uncurry GHC.guessTarget) files')
1066 -- NOTE: we used to do the dependency anal first, so that if it
1067 -- fails we didn't throw away the current set of modules. This would
1068 -- require some re-working of the GHC interface, so we'll leave it
1069 -- as a ToDo for now.
1071 io (GHC.setTargets session targets)
1072 doLoad session False prev_context LoadAllTargets
1074 checkModule :: String -> GHCi ()
1076 let modl = GHC.mkModuleName m
1077 session <- getSession
1078 prev_context <- io $ GHC.getContext session
1079 result <- io (GHC.checkModule session modl False)
1081 Nothing -> io $ putStrLn "Nothing"
1082 Just r -> io $ putStrLn (showSDoc (
1083 case GHC.checkedModuleInfo r of
1084 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1086 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1088 (text "global names: " <+> ppr global) $$
1089 (text "local names: " <+> ppr local)
1091 afterLoad (successIf (isJust result)) session False prev_context
1093 reloadModule :: String -> GHCi ()
1095 session <- getSession
1096 prev_context <- io $ GHC.getContext session
1097 doLoad session True prev_context $
1098 if null m then LoadAllTargets
1099 else LoadUpTo (GHC.mkModuleName m)
1102 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1103 doLoad session retain_context prev_context howmuch = do
1104 -- turn off breakpoints before we load: we can't turn them off later, because
1105 -- the ModBreaks will have gone away.
1106 discardActiveBreakPoints
1107 ok <- io (GHC.load session howmuch)
1108 afterLoad ok session retain_context prev_context
1111 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1112 afterLoad ok session retain_context prev_context = do
1113 revertCAFs -- always revert CAFs on load.
1115 loaded_mod_summaries <- getLoadedModules session
1116 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1117 loaded_mod_names = map GHC.moduleName loaded_mods
1118 modulesLoadedMsg ok loaded_mod_names
1120 setContextAfterLoad session prev_context retain_context loaded_mod_summaries
1123 setContextAfterLoad :: Session -> ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1124 setContextAfterLoad session prev keep_ctxt [] = do
1125 prel_mod <- getPrelude
1126 setContextKeepingPackageModules session prev keep_ctxt ([], [prel_mod])
1127 setContextAfterLoad session prev keep_ctxt ms = do
1128 -- load a target if one is available, otherwise load the topmost module.
1129 targets <- io (GHC.getTargets session)
1130 case [ m | Just m <- map (findTarget ms) targets ] of
1132 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1133 load_this (last graph')
1138 = case filter (`matches` t) ms of
1142 summary `matches` Target (TargetModule m) _
1143 = GHC.ms_mod_name summary == m
1144 summary `matches` Target (TargetFile f _) _
1145 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1149 load_this summary | m <- GHC.ms_mod summary = do
1150 b <- io (GHC.moduleIsInterpreted session m)
1151 if b then setContextKeepingPackageModules session prev keep_ctxt ([m], [])
1153 prel_mod <- getPrelude
1154 setContextKeepingPackageModules session prev keep_ctxt ([],[prel_mod,m])
1156 -- | Keep any package modules (except Prelude) when changing the context.
1157 setContextKeepingPackageModules
1159 -> ([Module],[Module]) -- previous context
1160 -> Bool -- re-execute :module commands
1161 -> ([Module],[Module]) -- new context
1163 setContextKeepingPackageModules session prev_context keep_ctxt (as,bs) = do
1164 let (_,bs0) = prev_context
1165 prel_mod <- getPrelude
1166 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1167 let bs1 = if null as then nub (prel_mod : bs) else bs
1168 io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1172 mapM_ (playCtxtCmd False) (remembered_ctx st)
1175 setGHCiState st{ remembered_ctx = [] }
1177 isHomeModule :: Module -> Bool
1178 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1180 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1181 modulesLoadedMsg ok mods = do
1182 dflags <- getDynFlags
1183 when (verbosity dflags > 0) $ do
1185 | null mods = text "none."
1186 | otherwise = hsep (
1187 punctuate comma (map ppr mods)) <> text "."
1190 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1192 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1195 typeOfExpr :: String -> GHCi ()
1197 = do cms <- getSession
1198 maybe_ty <- io (GHC.exprType cms str)
1200 Nothing -> return ()
1201 Just ty -> do dflags <- getDynFlags
1202 let pefas = dopt Opt_PrintExplicitForalls dflags
1203 printForUser $ text str <+> dcolon
1204 <+> pprTypeForUser pefas ty
1206 kindOfType :: String -> GHCi ()
1208 = do cms <- getSession
1209 maybe_ty <- io (GHC.typeKind cms str)
1211 Nothing -> return ()
1212 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1214 quit :: String -> GHCi Bool
1215 quit _ = return True
1217 shellEscape :: String -> GHCi Bool
1218 shellEscape str = io (system str >> return False)
1220 -----------------------------------------------------------------------------
1221 -- Browsing a module's contents
1223 browseCmd :: Bool -> String -> GHCi ()
1226 ['*':s] | looksLikeModuleName s -> do
1227 m <- wantInterpretedModule s
1228 browseModule bang m False
1229 [s] | looksLikeModuleName s -> do
1231 browseModule bang m True
1234 (as,bs) <- io $ GHC.getContext s
1235 -- Guess which module the user wants to browse. Pick
1236 -- modules that are interpreted first. The most
1237 -- recently-added module occurs last, it seems.
1239 (as@(_:_), _) -> browseModule bang (last as) True
1240 ([], bs@(_:_)) -> browseModule bang (last bs) True
1241 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1242 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1244 -- without bang, show items in context of their parents and omit children
1245 -- with bang, show class methods and data constructors separately, and
1246 -- indicate import modules, to aid qualifying unqualified names
1247 -- with sorted, sort items alphabetically
1248 browseModule :: Bool -> Module -> Bool -> GHCi ()
1249 browseModule bang modl exports_only = do
1251 -- :browse! reports qualifiers wrt current context
1252 current_unqual <- io (GHC.getPrintUnqual s)
1253 -- Temporarily set the context to the module we're interested in,
1254 -- just so we can get an appropriate PrintUnqualified
1255 (as,bs) <- io (GHC.getContext s)
1256 prel_mod <- getPrelude
1257 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1258 else GHC.setContext s [modl] [])
1259 target_unqual <- io (GHC.getPrintUnqual s)
1260 io (GHC.setContext s as bs)
1262 let unqual = if bang then current_unqual else target_unqual
1264 mb_mod_info <- io $ GHC.getModuleInfo s modl
1266 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1267 GHC.moduleNameString (GHC.moduleName modl)))
1269 dflags <- getDynFlags
1271 | exports_only = GHC.modInfoExports mod_info
1272 | otherwise = GHC.modInfoTopLevelScope mod_info
1275 -- sort alphabetically name, but putting
1276 -- locally-defined identifiers first.
1277 -- We would like to improve this; see #1799.
1278 sorted_names = loc_sort local ++ occ_sort external
1280 (local,external) = partition ((==modl) . nameModule) names
1281 occ_sort = sortBy (compare `on` nameOccName)
1282 -- try to sort by src location. If the first name in
1283 -- our list has a good source location, then they all should.
1285 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1286 = sortBy (compare `on` nameSrcSpan) names
1290 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1291 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1293 rdr_env <- io $ GHC.getGRE s
1295 let pefas = dopt Opt_PrintExplicitForalls dflags
1296 things | bang = catMaybes mb_things
1297 | otherwise = filtered_things
1298 pretty | bang = pprTyThing
1299 | otherwise = pprTyThingInContext
1301 labels [] = text "-- not currently imported"
1302 labels l = text $ intercalate "\n" $ map qualifier l
1303 qualifier = maybe "-- defined locally"
1304 (("-- imported via "++) . intercalate ", "
1305 . map GHC.moduleNameString)
1306 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1307 modNames = map (importInfo . GHC.getName) things
1309 -- annotate groups of imports with their import modules
1310 -- the default ordering is somewhat arbitrary, so we group
1311 -- by header and sort groups; the names themselves should
1312 -- really come in order of source appearance.. (trac #1799)
1313 annotate mts = concatMap (\(m,ts)->labels m:ts)
1314 $ sortBy cmpQualifiers $ group mts
1315 where cmpQualifiers =
1316 compare `on` (map (fmap (map moduleNameFS)) . fst)
1318 group mts@((m,_):_) = (m,map snd g) : group ng
1319 where (g,ng) = partition ((==m).fst) mts
1321 let prettyThings = map (pretty pefas) things
1322 prettyThings' | bang = annotate $ zip modNames prettyThings
1323 | otherwise = prettyThings
1324 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1325 -- ToDo: modInfoInstances currently throws an exception for
1326 -- package modules. When it works, we can do this:
1327 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1329 -----------------------------------------------------------------------------
1330 -- Setting the module context
1332 setContext :: String -> GHCi ()
1334 | all sensible strs = do
1335 playCtxtCmd True (cmd, as, bs)
1337 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1338 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1340 (cmd, strs, as, bs) =
1342 '+':stuff -> rest AddModules stuff
1343 '-':stuff -> rest RemModules stuff
1344 stuff -> rest SetContext stuff
1346 rest cmd stuff = (cmd, strs, as, bs)
1347 where strs = words stuff
1348 (as,bs) = partitionWith starred strs
1350 sensible ('*':m) = looksLikeModuleName m
1351 sensible m = looksLikeModuleName m
1353 starred ('*':m) = Left m
1356 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1357 playCtxtCmd fail (cmd, as, bs)
1360 (as',bs') <- do_checks fail
1361 (prev_as,prev_bs) <- io $ GHC.getContext s
1365 prel_mod <- getPrelude
1366 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1370 let as_to_add = as' \\ (prev_as ++ prev_bs)
1371 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1372 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1374 let new_as = prev_as \\ (as' ++ bs')
1375 new_bs = prev_bs \\ (as' ++ bs')
1376 return (new_as, new_bs)
1377 io $ GHC.setContext s new_as new_bs
1380 as' <- mapM wantInterpretedModule as
1381 bs' <- mapM lookupModule bs
1383 do_checks False = do
1384 as' <- mapM (trymaybe . wantInterpretedModule) as
1385 bs' <- mapM (trymaybe . lookupModule) bs
1386 return (catMaybes as', catMaybes bs')
1391 Left _ -> return Nothing
1392 Right a -> return (Just a)
1394 ----------------------------------------------------------------------------
1397 -- set options in the interpreter. Syntax is exactly the same as the
1398 -- ghc command line, except that certain options aren't available (-C,
1401 -- This is pretty fragile: most options won't work as expected. ToDo:
1402 -- figure out which ones & disallow them.
1404 setCmd :: String -> GHCi ()
1406 = do st <- getGHCiState
1407 let opts = options st
1408 io $ putStrLn (showSDoc (
1409 text "options currently set: " <>
1412 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1414 dflags <- getDynFlags
1415 io $ putStrLn (showSDoc (
1416 vcat (text "GHCi-specific dynamic flag settings:"
1417 :map (flagSetting dflags) ghciFlags)
1419 io $ putStrLn (showSDoc (
1420 vcat (text "other dynamic, non-language, flag settings:"
1421 :map (flagSetting dflags) nonLanguageDynFlags)
1423 where flagSetting dflags (str, f, _)
1424 | dopt f dflags = text " " <> text "-f" <> text str
1425 | otherwise = text " " <> text "-fno-" <> text str
1426 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1428 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1430 flags = [Opt_PrintExplicitForalls
1431 ,Opt_PrintBindResult
1432 ,Opt_BreakOnException
1434 ,Opt_PrintEvldWithShow
1437 = case getCmd str of
1438 Right ("args", rest) ->
1440 Left err -> io (hPutStrLn stderr err)
1441 Right args -> setArgs args
1442 Right ("prog", rest) ->
1444 Right [prog] -> setProg prog
1445 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1446 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1447 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1448 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1449 _ -> case toArgs str of
1450 Left err -> io (hPutStrLn stderr err)
1451 Right wds -> setOptions wds
1453 setArgs, setOptions :: [String] -> GHCi ()
1454 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1458 setGHCiState st{ args = args }
1462 setGHCiState st{ progname = prog }
1466 setGHCiState st{ editor = cmd }
1468 setStop str@(c:_) | isDigit c
1469 = do let (nm_str,rest) = break (not.isDigit) str
1472 let old_breaks = breaks st
1473 if all ((/= nm) . fst) old_breaks
1474 then printForUser (text "Breakpoint" <+> ppr nm <+>
1475 text "does not exist")
1477 let new_breaks = map fn old_breaks
1478 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1479 | otherwise = (i,loc)
1480 setGHCiState st{ breaks = new_breaks }
1483 setGHCiState st{ stop = cmd }
1485 setPrompt value = do
1488 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1489 else setGHCiState st{ prompt = remQuotes value }
1491 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1495 do -- first, deal with the GHCi opts (+s, +t, etc.)
1496 let (plus_opts, minus_opts) = partitionWith isPlus wds
1497 mapM_ setOpt plus_opts
1498 -- then, dynamic flags
1499 newDynFlags minus_opts
1501 newDynFlags :: [String] -> GHCi ()
1502 newDynFlags minus_opts = do
1503 dflags <- getDynFlags
1504 let pkg_flags = packageFlags dflags
1505 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags minus_opts
1506 io $ handleFlagWarnings dflags' warns
1508 if (not (null leftovers))
1509 then ghcError (CmdLineError ("unrecognised flags: " ++
1513 new_pkgs <- setDynFlags dflags'
1515 -- if the package flags changed, we should reset the context
1516 -- and link the new packages.
1517 dflags <- getDynFlags
1518 when (packageFlags dflags /= pkg_flags) $ do
1519 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1520 session <- getSession
1521 io (GHC.setTargets session [])
1522 io (GHC.load session LoadAllTargets)
1523 io (linkPackages dflags new_pkgs)
1524 -- package flags changed, we can't re-use any of the old context
1525 setContextAfterLoad session ([],[]) False []
1529 unsetOptions :: String -> GHCi ()
1531 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1532 let opts = words str
1533 (minus_opts, rest1) = partition isMinus opts
1534 (plus_opts, rest2) = partitionWith isPlus rest1
1536 if (not (null rest2))
1537 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1540 mapM_ unsetOpt plus_opts
1542 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1543 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1545 no_flags <- mapM no_flag minus_opts
1546 newDynFlags no_flags
1548 isMinus :: String -> Bool
1549 isMinus ('-':_) = True
1552 isPlus :: String -> Either String String
1553 isPlus ('+':opt) = Left opt
1554 isPlus other = Right other
1556 setOpt, unsetOpt :: String -> GHCi ()
1559 = case strToGHCiOpt str of
1560 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1561 Just o -> setOption o
1564 = case strToGHCiOpt str of
1565 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1566 Just o -> unsetOption o
1568 strToGHCiOpt :: String -> (Maybe GHCiOption)
1569 strToGHCiOpt "s" = Just ShowTiming
1570 strToGHCiOpt "t" = Just ShowType
1571 strToGHCiOpt "r" = Just RevertCAFs
1572 strToGHCiOpt _ = Nothing
1574 optToStr :: GHCiOption -> String
1575 optToStr ShowTiming = "s"
1576 optToStr ShowType = "t"
1577 optToStr RevertCAFs = "r"
1579 -- ---------------------------------------------------------------------------
1582 showCmd :: String -> GHCi ()
1586 ["args"] -> io $ putStrLn (show (args st))
1587 ["prog"] -> io $ putStrLn (show (progname st))
1588 ["prompt"] -> io $ putStrLn (show (prompt st))
1589 ["editor"] -> io $ putStrLn (show (editor st))
1590 ["stop"] -> io $ putStrLn (show (stop st))
1591 ["modules" ] -> showModules
1592 ["bindings"] -> showBindings
1593 ["linker"] -> io showLinkerState
1594 ["breaks"] -> showBkptTable
1595 ["context"] -> showContext
1596 ["packages"] -> showPackages
1597 ["languages"] -> showLanguages
1598 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1599 " | breaks | context | packages | languages ]"))
1601 showModules :: GHCi ()
1603 session <- getSession
1604 loaded_mods <- getLoadedModules session
1605 -- we want *loaded* modules only, see #1734
1606 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1607 mapM_ show_one loaded_mods
1609 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1610 getLoadedModules session = do
1611 graph <- io (GHC.getModuleGraph session)
1612 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1614 showBindings :: GHCi ()
1617 bindings <- io (GHC.getBindings s)
1618 docs <- io$ pprTypeAndContents s
1619 [ id | AnId id <- sortBy compareTyThings bindings]
1620 printForUserPartWay docs
1622 compareTyThings :: TyThing -> TyThing -> Ordering
1623 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1625 printTyThing :: TyThing -> GHCi ()
1626 printTyThing tyth = do dflags <- getDynFlags
1627 let pefas = dopt Opt_PrintExplicitForalls dflags
1628 printForUser (pprTyThing pefas tyth)
1630 showBkptTable :: GHCi ()
1633 printForUser $ prettyLocations (breaks st)
1635 showContext :: GHCi ()
1637 session <- getSession
1638 resumes <- io $ GHC.getResumeContext session
1639 printForUser $ vcat (map pp_resume (reverse resumes))
1642 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1643 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1645 showPackages :: GHCi ()
1647 pkg_flags <- fmap packageFlags getDynFlags
1648 io $ putStrLn $ showSDoc $ vcat $
1649 text ("active package flags:"++if null pkg_flags then " none" else "")
1650 : map showFlag pkg_flags
1651 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1652 io $ putStrLn $ showSDoc $ vcat $
1653 text "packages currently loaded:"
1654 : map (nest 2 . text . packageIdString)
1655 (sortBy (compare `on` packageIdFS) pkg_ids)
1656 where showFlag (ExposePackage p) = text $ " -package " ++ p
1657 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1658 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1660 showLanguages :: GHCi ()
1662 dflags <- getDynFlags
1663 io $ putStrLn $ showSDoc $ vcat $
1664 text "active language flags:" :
1665 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1667 -- -----------------------------------------------------------------------------
1670 completeNone :: String -> IO [String]
1671 completeNone _w = return []
1673 completeMacro, completeIdentifier, completeModule,
1674 completeHomeModule, completeSetOptions, completeFilename,
1675 completeHomeModuleOrFile
1676 :: String -> IO [String]
1679 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1680 completeWord w start end = do
1681 line <- Readline.getLineBuffer
1682 let line_words = words (dropWhile isSpace line)
1684 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1686 | ((':':c) : _) <- line_words -> do
1687 completionVars <- lookupCompletionVars c
1688 case completionVars of
1689 (Nothing,complete) -> wrapCompleter complete w
1690 (Just breakChars,complete)
1691 -> let (n,w') = selectWord
1692 (words' (`elem` breakChars) 0 line)
1693 complete' w = do rets <- complete w
1694 return (map (drop n) rets)
1695 in wrapCompleter complete' w'
1696 | ("import" : _) <- line_words ->
1697 wrapCompleter completeModule w
1699 --printf "complete %s, start = %d, end = %d\n" w start end
1700 wrapCompleter completeIdentifier w
1701 where words' _ _ [] = []
1702 words' isBreak n str = let (w,r) = break isBreak str
1703 (s,r') = span isBreak r
1704 in (n,w):words' isBreak (n+length w+length s) r'
1705 -- In a Haskell expression we want to parse 'a-b' as three words
1706 -- where a compiler flag (e.g. -ddump-simpl) should
1707 -- only be a single word.
1708 selectWord [] = (0,w)
1709 selectWord ((offset,x):xs)
1710 | offset+length x >= start = (start-offset,take (end-offset) x)
1711 | otherwise = selectWord xs
1713 lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars,
1715 lookupCompletionVars c = do
1716 maybe_cmd <- lookupCommand' c
1718 Just (_,_,ws,f) -> return (ws,f)
1719 Nothing -> return (Just filenameWordBreakChars,
1723 completeCmd :: String -> IO [String]
1725 cmds <- readIORef macros_ref
1726 return (filter (w `isPrefixOf`) (map (':':)
1727 (map cmdName (builtin_commands ++ cmds))))
1729 completeMacro w = do
1730 cmds <- readIORef macros_ref
1731 return (filter (w `isPrefixOf`) (map cmdName cmds))
1733 completeIdentifier w = do
1735 rdrs <- GHC.getRdrNamesInScope s
1736 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1738 completeModule w = do
1740 dflags <- GHC.getSessionDynFlags s
1741 let pkg_mods = allExposedModules dflags
1742 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1744 completeHomeModule w = do
1746 g <- GHC.getModuleGraph s
1747 let home_mods = map GHC.ms_mod_name g
1748 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1750 completeSetOptions w = do
1751 return (filter (w `isPrefixOf`) options)
1752 where options = "args":"prog":allFlags
1754 completeFilename w = do
1755 ws <- Readline.filenameCompletionFunction w
1757 -- If we only found one result, and it's a directory,
1758 -- add a trailing slash.
1760 isDir <- expandPathIO file >>= doesDirectoryExist
1761 if isDir && last file /= '/'
1762 then return [file ++ "/"]
1767 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1769 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1770 unionComplete f1 f2 w = do
1775 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1776 wrapCompleter fun w = do
1779 [] -> Readline.setAttemptedCompletionOver True >> return Nothing
1780 [x] -> -- Add a trailing space, unless it already has an appended slash.
1781 let appended = if last x == '/' then x else x ++ " "
1782 in return (Just (appended,[]))
1783 xs -> case getCommonPrefix xs of
1784 "" -> return (Just ("",xs))
1785 pref -> return (Just (pref,xs))
1787 getCommonPrefix :: [String] -> String
1788 getCommonPrefix [] = ""
1789 getCommonPrefix (s:ss) = foldl common s ss
1790 where common _s "" = ""
1792 common (c:cs) (d:ds)
1793 | c == d = c : common cs ds
1796 allExposedModules :: DynFlags -> [ModuleName]
1797 allExposedModules dflags
1798 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1800 pkg_db = pkgIdMap (pkgState dflags)
1802 completeMacro = completeNone
1803 completeIdentifier = completeNone
1804 completeModule = completeNone
1805 completeHomeModule = completeNone
1806 completeSetOptions = completeNone
1807 completeFilename = completeNone
1808 completeHomeModuleOrFile=completeNone
1811 -- ---------------------------------------------------------------------------
1812 -- User code exception handling
1814 -- This is the exception handler for exceptions generated by the
1815 -- user's code and exceptions coming from children sessions;
1816 -- it normally just prints out the exception. The
1817 -- handler must be recursive, in case showing the exception causes
1818 -- more exceptions to be raised.
1820 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1821 -- raising another exception. We therefore don't put the recursive
1822 -- handler arond the flushing operation, so if stderr is closed
1823 -- GHCi will just die gracefully rather than going into an infinite loop.
1824 handler :: SomeException -> GHCi Bool
1826 handler exception = do
1828 io installSignalHandlers
1829 ghciHandle handler (showException exception >> return False)
1831 showException :: SomeException -> GHCi ()
1832 #if __GLASGOW_HASKELL__ < 609
1833 showException (DynException dyn) =
1834 case fromDynamic dyn of
1835 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1836 Just Interrupted -> io (putStrLn "Interrupted.")
1837 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1838 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1839 Just other_ghc_ex -> io (print other_ghc_ex)
1841 showException other_exception
1842 = io (putStrLn ("*** Exception: " ++ show other_exception))
1844 showException (SomeException e) =
1846 Just Interrupted -> putStrLn "Interrupted."
1847 -- omit the location for CmdLineError:
1848 Just (CmdLineError s) -> putStrLn s
1850 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1851 Just other_ghc_ex -> print other_ghc_ex
1852 Nothing -> putStrLn ("*** Exception: " ++ show e)
1855 -----------------------------------------------------------------------------
1856 -- recursive exception handlers
1858 -- Don't forget to unblock async exceptions in the handler, or if we're
1859 -- in an exception loop (eg. let a = error a in a) the ^C exception
1860 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1862 ghciHandle :: (SomeException -> GHCi a) -> GHCi a -> GHCi a
1863 ghciHandle h (GHCi m) = GHCi $ \s ->
1864 Exception.catch (m s)
1865 (\e -> unGHCi (ghciUnblock (h e)) s)
1867 ghciUnblock :: GHCi a -> GHCi a
1868 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1870 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1871 ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s)
1873 -- ----------------------------------------------------------------------------
1876 expandPath :: String -> GHCi String
1877 expandPath path = io (expandPathIO path)
1879 expandPathIO :: String -> IO String
1881 case dropWhile isSpace path of
1883 tilde <- getHomeDirectory -- will fail if HOME not defined
1884 return (tilde ++ '/':d)
1888 wantInterpretedModule :: String -> GHCi Module
1889 wantInterpretedModule str = do
1890 session <- getSession
1891 modl <- lookupModule str
1892 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1893 when (not is_interpreted) $
1894 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1897 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1898 -> (Name -> GHCi ())
1900 wantNameFromInterpretedModule noCanDo str and_then = do
1901 session <- getSession
1902 names <- io $ GHC.parseName session str
1906 let modl = GHC.nameModule n
1907 if not (GHC.isExternalName n)
1908 then noCanDo n $ ppr n <>
1909 text " is not defined in an interpreted module"
1911 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1912 if not is_interpreted
1913 then noCanDo n $ text "module " <> ppr modl <>
1914 text " is not interpreted"
1917 -- -----------------------------------------------------------------------------
1918 -- commands for debugger
1920 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1921 sprintCmd = pprintCommand False False
1922 printCmd = pprintCommand True False
1923 forceCmd = pprintCommand False True
1925 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1926 pprintCommand bind force str = do
1927 session <- getSession
1928 io $ pprintClosureCommand session bind force str
1930 stepCmd :: String -> GHCi ()
1931 stepCmd [] = doContinue (const True) GHC.SingleStep
1932 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1934 stepLocalCmd :: String -> GHCi ()
1935 stepLocalCmd [] = do
1936 mb_span <- getCurrentBreakSpan
1938 Nothing -> stepCmd []
1940 Just mod <- getCurrentBreakModule
1941 current_toplevel_decl <- enclosingTickSpan mod loc
1942 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1944 stepLocalCmd expression = stepCmd expression
1946 stepModuleCmd :: String -> GHCi ()
1947 stepModuleCmd [] = do
1948 mb_span <- getCurrentBreakSpan
1950 Nothing -> stepCmd []
1952 Just span <- getCurrentBreakSpan
1953 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1954 doContinue f GHC.SingleStep
1956 stepModuleCmd expression = stepCmd expression
1958 -- | Returns the span of the largest tick containing the srcspan given
1959 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1960 enclosingTickSpan mod src = do
1961 ticks <- getTickArray mod
1962 let line = srcSpanStartLine src
1963 ASSERT (inRange (bounds ticks) line) do
1964 let enclosing_spans = [ span | (_,span) <- ticks ! line
1965 , srcSpanEnd span >= srcSpanEnd src]
1966 return . head . sortBy leftmost_largest $ enclosing_spans
1968 traceCmd :: String -> GHCi ()
1969 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1970 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1972 continueCmd :: String -> GHCi ()
1973 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1975 -- doContinue :: SingleStep -> GHCi ()
1976 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1977 doContinue pred step = do
1978 runResult <- resume step
1979 afterRunStmt pred runResult
1982 abandonCmd :: String -> GHCi ()
1983 abandonCmd = noArgs $ do
1985 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1986 when (not b) $ io $ putStrLn "There is no computation running."
1989 deleteCmd :: String -> GHCi ()
1990 deleteCmd argLine = do
1991 deleteSwitch $ words argLine
1993 deleteSwitch :: [String] -> GHCi ()
1995 io $ putStrLn "The delete command requires at least one argument."
1996 -- delete all break points
1997 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1998 deleteSwitch idents = do
1999 mapM_ deleteOneBreak idents
2001 deleteOneBreak :: String -> GHCi ()
2003 | all isDigit str = deleteBreak (read str)
2004 | otherwise = return ()
2006 historyCmd :: String -> GHCi ()
2008 | null arg = history 20
2009 | all isDigit arg = history (read arg)
2010 | otherwise = io $ putStrLn "Syntax: :history [num]"
2014 resumes <- io $ GHC.getResumeContext s
2016 [] -> io $ putStrLn "Not stopped at a breakpoint"
2018 let hist = GHC.resumeHistory r
2019 (took,rest) = splitAt num hist
2021 [] -> io $ putStrLn $
2022 "Empty history. Perhaps you forgot to use :trace?"
2024 spans <- mapM (io . GHC.getHistorySpan s) took
2025 let nums = map (printf "-%-3d:") [(1::Int)..]
2026 names = map GHC.historyEnclosingDecl took
2027 printForUser (vcat(zipWith3
2028 (\x y z -> x <+> y <+> z)
2030 (map (bold . ppr) names)
2031 (map (parens . ppr) spans)))
2032 io $ putStrLn $ if null rest then "<end of history>" else "..."
2034 bold :: SDoc -> SDoc
2035 bold c | do_bold = text start_bold <> c <> text end_bold
2038 backCmd :: String -> GHCi ()
2039 backCmd = noArgs $ do
2041 (names, _, span) <- io $ GHC.back s
2042 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
2043 printTypeOfNames s names
2044 -- run the command set with ":set stop <cmd>"
2046 enqueueCommands [stop st]
2048 forwardCmd :: String -> GHCi ()
2049 forwardCmd = noArgs $ do
2051 (names, ix, span) <- io $ GHC.forward s
2052 printForUser $ (if (ix == 0)
2053 then ptext (sLit "Stopped at")
2054 else ptext (sLit "Logged breakpoint at")) <+> ppr span
2055 printTypeOfNames s names
2056 -- run the command set with ":set stop <cmd>"
2058 enqueueCommands [stop st]
2060 -- handle the "break" command
2061 breakCmd :: String -> GHCi ()
2062 breakCmd argLine = do
2063 session <- getSession
2064 breakSwitch session $ words argLine
2066 breakSwitch :: Session -> [String] -> GHCi ()
2067 breakSwitch _session [] = do
2068 io $ putStrLn "The break command requires at least one argument."
2069 breakSwitch session (arg1:rest)
2070 | looksLikeModuleName arg1 && not (null rest) = do
2071 mod <- wantInterpretedModule arg1
2072 breakByModule mod rest
2073 | all isDigit arg1 = do
2074 (toplevel, _) <- io $ GHC.getContext session
2076 (mod : _) -> breakByModuleLine mod (read arg1) rest
2078 io $ putStrLn "Cannot find default module for breakpoint."
2079 io $ putStrLn "Perhaps no modules are loaded for debugging?"
2080 | otherwise = do -- try parsing it as an identifier
2081 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2082 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2083 if GHC.isGoodSrcLoc loc
2084 then findBreakAndSet (GHC.nameModule name) $
2085 findBreakByCoord (Just (GHC.srcLocFile loc))
2086 (GHC.srcLocLine loc,
2088 else noCanDo name $ text "can't find its location: " <> ppr loc
2090 noCanDo n why = printForUser $
2091 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2093 breakByModule :: Module -> [String] -> GHCi ()
2094 breakByModule mod (arg1:rest)
2095 | all isDigit arg1 = do -- looks like a line number
2096 breakByModuleLine mod (read arg1) rest
2100 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2101 breakByModuleLine mod line args
2102 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2103 | [col] <- args, all isDigit col =
2104 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2105 | otherwise = breakSyntax
2108 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2110 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2111 findBreakAndSet mod lookupTickTree = do
2112 tickArray <- getTickArray mod
2113 (breakArray, _) <- getModBreak mod
2114 case lookupTickTree tickArray of
2115 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2116 Just (tick, span) -> do
2117 success <- io $ setBreakFlag True breakArray tick
2121 recordBreak $ BreakLocation
2128 text "Breakpoint " <> ppr nm <>
2130 then text " was already set at " <> ppr span
2131 else text " activated at " <> ppr span
2133 printForUser $ text "Breakpoint could not be activated at"
2136 -- When a line number is specified, the current policy for choosing
2137 -- the best breakpoint is this:
2138 -- - the leftmost complete subexpression on the specified line, or
2139 -- - the leftmost subexpression starting on the specified line, or
2140 -- - the rightmost subexpression enclosing the specified line
2142 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2143 findBreakByLine line arr
2144 | not (inRange (bounds arr) line) = Nothing
2146 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2147 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2148 listToMaybe (sortBy (rightmost `on` snd) ticks)
2152 starts_here = [ tick | tick@(_,span) <- ticks,
2153 GHC.srcSpanStartLine span == line ]
2155 (complete,incomplete) = partition ends_here starts_here
2156 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2158 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2159 -> Maybe (BreakIndex,SrcSpan)
2160 findBreakByCoord mb_file (line, col) arr
2161 | not (inRange (bounds arr) line) = Nothing
2163 listToMaybe (sortBy (rightmost `on` snd) contains ++
2164 sortBy (leftmost_smallest `on` snd) after_here)
2168 -- the ticks that span this coordinate
2169 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2170 is_correct_file span ]
2172 is_correct_file span
2173 | Just f <- mb_file = GHC.srcSpanFile span == f
2176 after_here = [ tick | tick@(_,span) <- ticks,
2177 GHC.srcSpanStartLine span == line,
2178 GHC.srcSpanStartCol span >= col ]
2180 -- For now, use ANSI bold on terminals that we know support it.
2181 -- Otherwise, we add a line of carets under the active expression instead.
2182 -- In particular, on Windows and when running the testsuite (which sets
2183 -- TERM to vt100 for other reasons) we get carets.
2184 -- We really ought to use a proper termcap/terminfo library.
2186 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2187 where mTerm = System.Environment.getEnv "TERM"
2188 `catchIO` \_ -> return "TERM not set"
2190 start_bold :: String
2191 start_bold = "\ESC[1m"
2193 end_bold = "\ESC[0m"
2195 listCmd :: String -> GHCi ()
2197 mb_span <- getCurrentBreakSpan
2200 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2202 | GHC.isGoodSrcSpan span -> io $ listAround span True
2205 resumes <- io $ GHC.getResumeContext s
2207 [] -> panic "No resumes"
2209 do let traceIt = case GHC.resumeHistory r of
2210 [] -> text "rerunning with :trace,"
2212 doWhat = traceIt <+> text ":back then :list"
2213 printForUser (text "Unable to list source for" <+>
2215 $$ text "Try" <+> doWhat)
2216 listCmd str = list2 (words str)
2218 list2 :: [String] -> GHCi ()
2219 list2 [arg] | all isDigit arg = do
2220 session <- getSession
2221 (toplevel, _) <- io $ GHC.getContext session
2223 [] -> io $ putStrLn "No module to list"
2224 (mod : _) -> listModuleLine mod (read arg)
2225 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2226 mod <- wantInterpretedModule arg1
2227 listModuleLine mod (read arg2)
2229 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2230 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2231 if GHC.isGoodSrcLoc loc
2233 tickArray <- getTickArray (GHC.nameModule name)
2234 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2235 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2238 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2239 Just (_,span) -> io $ listAround span False
2241 noCanDo name $ text "can't find its location: " <>
2244 noCanDo n why = printForUser $
2245 text "cannot list source code for " <> ppr n <> text ": " <> why
2247 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2249 listModuleLine :: Module -> Int -> GHCi ()
2250 listModuleLine modl line = do
2251 session <- getSession
2252 graph <- io (GHC.getModuleGraph session)
2253 let this = filter ((== modl) . GHC.ms_mod) graph
2255 [] -> panic "listModuleLine"
2257 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2258 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2259 io $ listAround (GHC.srcLocSpan loc) False
2261 -- | list a section of a source file around a particular SrcSpan.
2262 -- If the highlight flag is True, also highlight the span using
2263 -- start_bold\/end_bold.
2264 listAround :: SrcSpan -> Bool -> IO ()
2265 listAround span do_highlight = do
2266 contents <- BS.readFile (unpackFS file)
2268 lines = BS.split '\n' contents
2269 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2270 drop (line1 - 1 - pad_before) $ lines
2271 fst_line = max 1 (line1 - pad_before)
2272 line_nos = [ fst_line .. ]
2274 highlighted | do_highlight = zipWith highlight line_nos these_lines
2275 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2277 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2278 prefixed = zipWith ($) highlighted bs_line_nos
2280 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2282 file = GHC.srcSpanFile span
2283 line1 = GHC.srcSpanStartLine span
2284 col1 = GHC.srcSpanStartCol span
2285 line2 = GHC.srcSpanEndLine span
2286 col2 = GHC.srcSpanEndCol span
2288 pad_before | line1 == 1 = 0
2292 highlight | do_bold = highlight_bold
2293 | otherwise = highlight_carets
2295 highlight_bold no line prefix
2296 | no == line1 && no == line2
2297 = let (a,r) = BS.splitAt col1 line
2298 (b,c) = BS.splitAt (col2-col1) r
2300 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2302 = let (a,b) = BS.splitAt col1 line in
2303 BS.concat [prefix, a, BS.pack start_bold, b]
2305 = let (a,b) = BS.splitAt col2 line in
2306 BS.concat [prefix, a, BS.pack end_bold, b]
2307 | otherwise = BS.concat [prefix, line]
2309 highlight_carets no line prefix
2310 | no == line1 && no == line2
2311 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2312 BS.replicate (col2-col1) '^']
2314 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2317 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2319 | otherwise = BS.concat [prefix, line]
2321 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2322 nl = BS.singleton '\n'
2324 -- --------------------------------------------------------------------------
2327 getTickArray :: Module -> GHCi TickArray
2328 getTickArray modl = do
2330 let arrmap = tickarrays st
2331 case lookupModuleEnv arrmap modl of
2332 Just arr -> return arr
2334 (_breakArray, ticks) <- getModBreak modl
2335 let arr = mkTickArray (assocs ticks)
2336 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2339 discardTickArrays :: GHCi ()
2340 discardTickArrays = do
2342 setGHCiState st{tickarrays = emptyModuleEnv}
2344 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2346 = accumArray (flip (:)) [] (1, max_line)
2347 [ (line, (nm,span)) | (nm,span) <- ticks,
2348 line <- srcSpanLines span ]
2350 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2351 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2352 GHC.srcSpanEndLine span ]
2354 lookupModule :: String -> GHCi Module
2355 lookupModule modName
2356 = do session <- getSession
2357 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2359 -- don't reset the counter back to zero?
2360 discardActiveBreakPoints :: GHCi ()
2361 discardActiveBreakPoints = do
2363 mapM (turnOffBreak.snd) (breaks st)
2364 setGHCiState $ st { breaks = [] }
2366 deleteBreak :: Int -> GHCi ()
2367 deleteBreak identity = do
2369 let oldLocations = breaks st
2370 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2372 then printForUser (text "Breakpoint" <+> ppr identity <+>
2373 text "does not exist")
2375 mapM (turnOffBreak.snd) this
2376 setGHCiState $ st { breaks = rest }
2378 turnOffBreak :: BreakLocation -> GHCi Bool
2379 turnOffBreak loc = do
2380 (arr, _) <- getModBreak (breakModule loc)
2381 io $ setBreakFlag False arr (breakTick loc)
2383 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2384 getModBreak mod = do
2385 session <- getSession
2386 Just mod_info <- io $ GHC.getModuleInfo session mod
2387 let modBreaks = GHC.modInfoModBreaks mod_info
2388 let array = GHC.modBreaks_flags modBreaks
2389 let ticks = GHC.modBreaks_locs modBreaks
2390 return (array, ticks)
2392 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2393 setBreakFlag toggle array index
2394 | toggle = GHC.setBreakOn array index
2395 | otherwise = GHC.setBreakOff array index