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 ( LoadHowMuch(..), Target(..), TargetId(..),
25 Module, ModuleName, TyThing(..), Phase,
26 BreakIndex, SrcSpan, Resume, SingleStep,
27 Ghc, handleSourceError )
37 import HscTypes ( implicitTyThings, reflectGhc, reifyGhc
38 , handleFlagWarnings )
39 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
40 import Outputable hiding (printForUser, printForUserPartWay)
41 import Module -- for ModuleEnv
45 -- Other random utilities
48 import BasicTypes hiding (isTopLevel)
49 import Panic hiding (showException)
55 import Maybes ( orElse, expectJust )
58 import MonadUtils ( liftIO )
60 #ifndef mingw32_HOST_OS
61 import System.Posix hiding (getEnv)
63 import GHC.ConsoleHandler ( flushConsole )
64 import qualified System.Win32
68 import Control.Concurrent ( yield ) -- Used in readline loop
69 import System.Console.Editline.Readline as Readline
75 -- import Control.Concurrent
77 import System.FilePath
78 import qualified Data.ByteString.Char8 as BS
82 import System.Environment
83 import System.Exit ( exitWith, ExitCode(..) )
84 import System.Directory
86 import System.IO.Error as IO
89 import Control.Monad as Monad
93 import GHC.Exts ( unsafeCoerce# )
94 import GHC.IOBase ( IOErrorType(InvalidArgument) )
97 import Data.IORef ( IORef, readIORef, writeIORef )
99 -----------------------------------------------------------------------------
101 ghciWelcomeMsg :: String
102 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
103 ": http://www.haskell.org/ghc/ :? for help"
105 cmdName :: Command -> String
106 cmdName (n,_,_,_) = n
108 GLOBAL_VAR(macros_ref, [], [Command])
110 builtin_commands :: [Command]
112 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
113 ("?", keepGoing help, Nothing, completeNone),
114 ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename),
115 ("abandon", keepGoing abandonCmd, Nothing, completeNone),
116 ("break", keepGoing breakCmd, Nothing, completeIdentifier),
117 ("back", keepGoing backCmd, Nothing, completeNone),
118 ("browse", keepGoing (browseCmd False), Nothing, completeModule),
119 ("browse!", keepGoing (browseCmd True), Nothing, completeModule),
120 ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename),
121 ("check", keepGoing checkModule, Nothing, completeHomeModule),
122 ("continue", keepGoing continueCmd, Nothing, completeNone),
123 ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier),
124 ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename),
125 ("def", keepGoing (defineMacro False), Nothing, completeIdentifier),
126 ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier),
127 ("delete", keepGoing deleteCmd, Nothing, completeNone),
128 ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
129 ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
130 ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename),
131 ("force", keepGoing forceCmd, Nothing, completeIdentifier),
132 ("forward", keepGoing forwardCmd, Nothing, completeNone),
133 ("help", keepGoing help, Nothing, completeNone),
134 ("history", keepGoing historyCmd, Nothing, completeNone),
135 ("info", keepGoing info, Nothing, completeIdentifier),
136 ("kind", keepGoing kindOfType, Nothing, completeIdentifier),
137 ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile),
138 ("list", keepGoing listCmd, Nothing, completeNone),
139 ("module", keepGoing setContext, Nothing, completeModule),
140 ("main", keepGoing runMain, Nothing, completeIdentifier),
141 ("print", keepGoing printCmd, Nothing, completeIdentifier),
142 ("quit", quit, Nothing, completeNone),
143 ("reload", keepGoing reloadModule, Nothing, completeNone),
144 ("run", keepGoing runRun, Nothing, completeIdentifier),
145 ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions),
146 ("show", keepGoing showCmd, Nothing, completeShowOptions),
147 ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier),
148 ("step", keepGoing stepCmd, Nothing, completeIdentifier),
149 ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier),
150 ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier),
151 ("type", keepGoing typeOfExpr, Nothing, completeIdentifier),
152 ("trace", keepGoing traceCmd, Nothing, completeIdentifier),
153 ("undef", keepGoing undefineMacro, Nothing, completeMacro),
154 ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions)
158 -- We initialize readline (in the interactiveUI function) to use
159 -- word_break_chars as the default set of completion word break characters.
160 -- This can be overridden for a particular command (for example, filename
161 -- expansion shouldn't consider '/' to be a word break) by setting the third
162 -- entry in the Command tuple above.
164 -- NOTE: in order for us to override the default correctly, any custom entry
165 -- must be a SUBSET of word_break_chars.
167 word_break_chars :: String
168 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
169 specials = "(),;[]`{}"
171 in spaces ++ specials ++ symbols
174 flagWordBreakChars, filenameWordBreakChars :: String
175 flagWordBreakChars = " \t\n"
176 filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults
179 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
180 keepGoing a str = a str >> return False
182 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
184 = do case toArgs str of
185 Left err -> io (hPutStrLn stderr err)
189 shortHelpText :: String
190 shortHelpText = "use :? for help.\n"
194 " Commands available from the prompt:\n" ++
196 " <statement> evaluate/run <statement>\n" ++
197 " : repeat last command\n" ++
198 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
199 " :add [*]<module> ... add module(s) to the current target set\n" ++
200 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
201 " (!: more details; *: all top-level names)\n" ++
202 " :cd <dir> change directory to <dir>\n" ++
203 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
204 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
205 " :def <cmd> <expr> define a command :<cmd>\n" ++
206 " :edit <file> edit file\n" ++
207 " :edit edit last module\n" ++
208 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
209 " :help, :? display this list of commands\n" ++
210 " :info [<name> ...] display information about the given names\n" ++
211 " :kind <type> show the kind of <type>\n" ++
212 " :load [*]<module> ... load module(s) and their dependents\n" ++
213 " :main [<arguments> ...] run the main function with the given arguments\n" ++
214 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
215 " :quit exit GHCi\n" ++
216 " :reload reload the current module set\n" ++
217 " :run function [<arguments> ...] run the function with the given arguments\n" ++
218 " :type <expr> show the type of <expr>\n" ++
219 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
220 " :!<command> run the shell command <command>\n" ++
222 " -- Commands for debugging:\n" ++
224 " :abandon at a breakpoint, abandon current computation\n" ++
225 " :back go back in the history (after :trace)\n" ++
226 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
227 " :break <name> set a breakpoint on the specified function\n" ++
228 " :continue resume after a breakpoint\n" ++
229 " :delete <number> delete the specified breakpoint\n" ++
230 " :delete * delete all breakpoints\n" ++
231 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
232 " :forward go forward in the history (after :back)\n" ++
233 " :history [<n>] after :trace, show the execution history\n" ++
234 " :list show the source code around current breakpoint\n" ++
235 " :list identifier show the source code for <identifier>\n" ++
236 " :list [<module>] <line> show the source code around line number <line>\n" ++
237 " :print [<name> ...] prints a value without forcing its computation\n" ++
238 " :sprint [<name> ...] simplifed version of :print\n" ++
239 " :step single-step after stopping at a breakpoint\n"++
240 " :step <expr> single-step into <expr>\n"++
241 " :steplocal single-step within the current top-level binding\n"++
242 " :stepmodule single-step restricted to the current module\n"++
243 " :trace trace after stopping at a breakpoint\n"++
244 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
247 " -- Commands for changing settings:\n" ++
249 " :set <option> ... set options\n" ++
250 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
251 " :set prog <progname> set the value returned by System.getProgName\n" ++
252 " :set prompt <prompt> set the prompt used in GHCi\n" ++
253 " :set editor <cmd> set the command used for :edit\n" ++
254 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
255 " :unset <option> ... unset options\n" ++
257 " Options for ':set' and ':unset':\n" ++
259 " +r revert top-level expressions after each evaluation\n" ++
260 " +s print timing/memory stats after each evaluation\n" ++
261 " +t print type after evaluation\n" ++
262 " -<flags> most GHC command line flags can also be set here\n" ++
263 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
264 " for GHCi-specific flags, see User's Guide,\n"++
265 " Flag reference, Interactive-mode options\n" ++
267 " -- Commands for displaying information:\n" ++
269 " :show bindings show the current bindings made at the prompt\n" ++
270 " :show breaks show the active breakpoints\n" ++
271 " :show context show the breakpoint context\n" ++
272 " :show modules show the currently loaded modules\n" ++
273 " :show packages show the currently active package flags\n" ++
274 " :show languages show the currently active language flags\n" ++
275 " :show <setting> show value of <setting>, which is one of\n" ++
276 " [args, prog, prompt, editor, stop]\n" ++
279 findEditor :: IO String
284 win <- System.Win32.getWindowsDirectory
285 return (win </> "notepad.exe")
290 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
292 interactiveUI srcs maybe_exprs = withTerminalReset $ do
293 -- HACK! If we happen to get into an infinite loop (eg the user
294 -- types 'let x=x in x' at the prompt), then the thread will block
295 -- on a blackhole, and become unreachable during GC. The GC will
296 -- detect that it is unreachable and send it the NonTermination
297 -- exception. However, since the thread is unreachable, everything
298 -- it refers to might be finalized, including the standard Handles.
299 -- This sounds like a bug, but we don't have a good solution right
301 liftIO $ newStablePtr stdin
302 liftIO $ newStablePtr stdout
303 liftIO $ newStablePtr stderr
305 -- Initialise buffering for the *interpreted* I/O system
308 liftIO $ when (isNothing maybe_exprs) $ do
309 -- Only for GHCi (not runghc and ghc -e):
311 -- Turn buffering off for the compiled program's stdout/stderr
313 -- Turn buffering off for GHCi's stdout
315 hSetBuffering stdout NoBuffering
316 -- We don't want the cmd line to buffer any input that might be
317 -- intended for the program, so unbuffer stdin.
318 hSetBuffering stdin NoBuffering
321 is_tty <- hIsTerminalDevice stdin
322 when is_tty $ withReadline $ do
326 (\dir -> Readline.readHistory (dir </> "ghci_history"))
329 Readline.setAttemptedCompletionFunction (Just completeWord)
330 --Readline.parseAndBind "set show-all-if-ambiguous 1"
332 Readline.setBasicWordBreakCharacters word_break_chars
333 Readline.setCompleterWordBreakCharacters word_break_chars
334 Readline.setCompletionAppendCharacter Nothing
337 -- initial context is just the Prelude
338 prel_mod <- GHC.findModule (GHC.mkModuleName "Prelude") Nothing
339 GHC.setContext [] [prel_mod]
341 default_editor <- liftIO $ findEditor
343 startGHCi (runGHCi srcs maybe_exprs)
344 GHCiState{ progname = "<interactive>",
348 editor = default_editor,
349 -- session = session,
354 tickarrays = emptyModuleEnv,
355 last_command = Nothing,
358 ghc_e = isJust maybe_exprs
363 Readline.stifleHistory 100
364 withGhcAppData (\dir -> Readline.writeHistory (dir </> "ghci_history"))
366 Readline.resetTerminal Nothing
371 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
372 withGhcAppData right left = do
373 either_dir <- IO.try (getAppUserDataDirectory "ghc")
375 Right dir -> right dir
378 -- libedit doesn't always restore the terminal settings correctly (as of at
379 -- least 07/12/2008); see trac #2691. Work around this by manually resetting
380 -- the terminal outselves.
381 withTerminalReset :: Ghc () -> Ghc ()
382 #ifdef mingw32_HOST_OS
383 withTerminalReset = id
385 withTerminalReset f = do
386 isTTY <- liftIO $ hIsTerminalDevice stdout
389 else gbracket (liftIO $ getTerminalAttributes stdOutput)
390 (\attrs -> liftIO $ setTerminalAttributes stdOutput attrs Immediately)
394 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
395 runGHCi paths maybe_exprs = do
397 read_dot_files = not opt_IgnoreDotGhci
399 current_dir = return (Just ".ghci")
401 app_user_dir = io $ withGhcAppData
402 (\dir -> return (Just (dir </> "ghci.conf")))
406 either_dir <- io $ IO.try (getEnv "HOME")
408 Right home -> return (Just (home </> ".ghci"))
411 sourceConfigFile :: FilePath -> GHCi ()
412 sourceConfigFile file = do
413 exists <- io $ doesFileExist file
415 dir_ok <- io $ checkPerms (getDirectory file)
416 file_ok <- io $ checkPerms file
417 when (dir_ok && file_ok) $ do
418 either_hdl <- io $ IO.try (openFile file ReadMode)
421 Right hdl -> runCommands (fileLoop hdl False False)
423 getDirectory f = case takeDirectory f of "" -> "."; d -> d
425 when (read_dot_files) $ do
426 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
427 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
428 mapM_ sourceConfigFile (nub cfgs)
429 -- nub, because we don't want to read .ghci twice if the
432 -- Perform a :load for files given on the GHCi command line
433 -- When in -e mode, if the load fails then we want to stop
434 -- immediately rather than going on to evaluate the expression.
435 when (not (null paths)) $ do
436 ok <- ghciHandle (\e -> do showException e; return Failed) $
438 when (isJust maybe_exprs && failed ok) $
439 io (exitWith (ExitFailure 1))
441 -- if verbosity is greater than 0, or we are connected to a
442 -- terminal, display the prompt in the interactive loop.
443 is_tty <- io (hIsTerminalDevice stdin)
444 dflags <- getDynFlags
445 let show_prompt = verbosity dflags > 0 || is_tty
450 #if defined(mingw32_HOST_OS)
451 -- The win32 Console API mutates the first character of
452 -- type-ahead when reading from it in a non-buffered manner. Work
453 -- around this by flushing the input buffer of type-ahead characters,
454 -- but only if stdin is available.
455 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
457 Left err | isDoesNotExistError err -> return ()
458 | otherwise -> io (ioError err)
459 Right () -> return ()
461 -- enter the interactive loop
462 interactiveLoop is_tty show_prompt
464 -- just evaluate the expression we were given
465 enqueueCommands exprs
466 let handle e = do st <- getGHCiState
467 -- Jump through some hoops to get the
468 -- current progname in the exception text:
469 -- <progname>: <exception>
470 io $ withProgName (progname st)
471 -- this used to be topHandlerFastExit, see #2228
473 runCommands' handle (return Nothing)
476 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
478 interactiveLoop :: Bool -> Bool -> GHCi ()
479 interactiveLoop is_tty show_prompt =
480 -- Ignore ^C exceptions caught here
481 ghciHandleGhcException (\e -> case e of
483 #if defined(mingw32_HOST_OS)
486 interactiveLoop is_tty show_prompt
487 _other -> return ()) $
489 ghciUnblock $ do -- unblock necessary if we recursed from the
490 -- exception handler above.
492 -- read commands from stdin
495 then runCommands readlineLoop
496 else runCommands (fileLoop stdin show_prompt is_tty)
498 runCommands (fileLoop stdin show_prompt is_tty)
502 -- NOTE: We only read .ghci files if they are owned by the current user,
503 -- and aren't world writable. Otherwise, we could be accidentally
504 -- running code planted by a malicious third party.
506 -- Furthermore, We only read ./.ghci if . is owned by the current user
507 -- and isn't writable by anyone else. I think this is sufficient: we
508 -- don't need to check .. and ../.. etc. because "." always refers to
509 -- the same directory while a process is running.
511 checkPerms :: String -> IO Bool
512 #ifdef mingw32_HOST_OS
517 handleIO (\_ -> return False) $ do
518 st <- getFileStatus name
520 if fileOwner st /= me then do
521 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
524 let mode = fileMode st
525 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
526 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
528 putStrLn $ "*** WARNING: " ++ name ++
529 " is writable by someone else, IGNORING!"
534 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
535 fileLoop hdl show_prompt is_tty = do
536 when show_prompt $ do
539 l <- io (IO.try (hGetLine hdl))
541 Left e | isEOFError e -> return Nothing
542 | InvalidArgument <- etype -> return Nothing
543 | otherwise -> io (ioError e)
544 where etype = ioeGetErrorType e
545 -- treat InvalidArgument in the same way as EOF:
546 -- this can happen if the user closed stdin, or
547 -- perhaps did getContents which closes stdin at
550 str <- io $ consoleInputToUnicode is_tty l
553 #ifdef mingw32_HOST_OS
554 -- Convert the console input into Unicode according to the current code page.
555 -- The Windows console stores Unicode characters directly, so this is a
556 -- rather roundabout way of doing things... oh well.
557 -- See #782, #1483, #1649
558 consoleInputToUnicode :: Bool -> String -> IO String
559 consoleInputToUnicode is_tty str
561 cp <- System.Win32.getConsoleCP
562 System.Win32.stringToUnicode cp str
564 decodeStringAsUTF8 str
566 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
568 consoleInputToUnicode :: Bool -> String -> IO String
569 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
572 decodeStringAsUTF8 :: String -> IO String
573 decodeStringAsUTF8 str =
574 withCStringLen str $ \(cstr,len) ->
575 utf8DecodeString (castPtr cstr :: Ptr Word8) len
577 mkPrompt :: GHCi String
579 (toplevs,exports) <- GHC.getContext
580 resumes <- GHC.getResumeContext
581 -- st <- getGHCiState
587 let ix = GHC.resumeHistoryIx r
589 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
591 let hist = GHC.resumeHistory r !! (ix-1)
592 span <- GHC.getHistorySpan hist
593 return (brackets (ppr (negate ix) <> char ':'
594 <+> ppr span) <> space)
596 dots | _:rs <- resumes, not (null rs) = text "... "
603 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
604 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
605 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
606 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
607 hsep (map (ppr . GHC.moduleName) exports)
609 deflt_prompt = dots <> context_bit <> modules_bit
611 f ('%':'s':xs) = deflt_prompt <> f xs
612 f ('%':'%':xs) = char '%' <> f xs
613 f (x:xs) = char x <> f xs
617 return (showSDoc (f (prompt st)))
621 readlineLoop :: GHCi (Maybe String)
624 saveSession -- for use by completion
626 l <- io $ withReadline (readline prompt)
629 Nothing -> return Nothing
630 Just "" -> return (Just "") -- Don't put empty lines in the history
633 str <- io $ consoleInputToUnicode True l
636 withReadline :: IO a -> IO a
637 withReadline = bracket_ stopTimer startTimer
638 -- editline doesn't handle some of its system calls returning
639 -- EINTR, so our timer signal confuses it, hence we turn off
640 -- the timer signal when making calls to editline. (#2277)
641 -- If editline is ever fixed, we can remove this.
643 -- These come from the RTS
644 foreign import ccall unsafe startTimer :: IO ()
645 foreign import ccall unsafe stopTimer :: IO ()
648 queryQueue :: GHCi (Maybe String)
653 c:cs -> do setGHCiState st{ cmdqueue = cs }
656 runCommands :: GHCi (Maybe String) -> GHCi ()
657 runCommands = runCommands' handler
659 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
660 -> GHCi (Maybe String) -> GHCi ()
661 runCommands' eh getCmd = do
662 mb_cmd <- noSpace queryQueue
663 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
668 handleSourceError printErrorAndKeepGoing
670 if b then return () else runCommands' eh getCmd
672 printErrorAndKeepGoing err = do
673 GHC.printExceptionAndWarnings err
676 noSpace q = q >>= maybe (return Nothing)
677 (\c->case removeSpaces c of
679 ":{" -> multiLineCmd q
680 c -> return (Just c) )
684 setGHCiState st{ prompt = "%s| " }
685 mb_cmd <- collectCommand q ""
686 getGHCiState >>= \st->setGHCiState st{ prompt = p }
688 -- we can't use removeSpaces for the sublines here, so
689 -- multiline commands are somewhat more brittle against
690 -- fileformat errors (such as \r in dos input on unix),
691 -- we get rid of any extra spaces for the ":}" test;
692 -- we also avoid silent failure if ":}" is not found;
693 -- and since there is no (?) valid occurrence of \r (as
694 -- opposed to its String representation, "\r") inside a
695 -- ghci command, we replace any such with ' ' (argh:-(
696 collectCommand q c = q >>=
697 maybe (io (ioError collectError))
698 (\l->if removeSpaces l == ":}"
699 then return (Just $ removeSpaces c)
700 else collectCommand q (c++map normSpace l))
701 where normSpace '\r' = ' '
703 -- QUESTION: is userError the one to use here?
704 collectError = userError "unterminated multiline command :{ .. :}"
705 doCommand (':' : cmd) = specialCommand cmd
706 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
709 enqueueCommands :: [String] -> GHCi ()
710 enqueueCommands cmds = do
712 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
715 runStmt :: String -> SingleStep -> GHCi Bool
717 | null (filter (not.isSpace) stmt) = return False
718 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
720 = do result <- GhciMonad.runStmt stmt step
721 afterRunStmt (const True) result
723 --afterRunStmt :: GHC.RunResult -> GHCi Bool
724 -- False <=> the statement failed to compile
725 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
726 afterRunStmt _ (GHC.RunException e) = throw e
727 afterRunStmt step_here run_result = do
728 resumes <- GHC.getResumeContext
730 GHC.RunOk names -> do
731 show_types <- isOptionSet ShowType
732 when show_types $ printTypeOfNames names
733 GHC.RunBreak _ names mb_info
734 | isNothing mb_info ||
735 step_here (GHC.resumeSpan $ head resumes) -> do
736 mb_id_loc <- toBreakIdAndLocation mb_info
737 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
739 then printStoppedAtBreakInfo (head resumes) names
740 else enqueueCommands [breakCmd]
741 -- run the command set with ":set stop <cmd>"
743 enqueueCommands [stop st]
745 | otherwise -> resume step_here GHC.SingleStep >>=
746 afterRunStmt step_here >> return ()
750 io installSignalHandlers
751 b <- isOptionSet RevertCAFs
754 return (case run_result of GHC.RunOk _ -> True; _ -> False)
756 toBreakIdAndLocation ::
757 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
758 toBreakIdAndLocation Nothing = return Nothing
759 toBreakIdAndLocation (Just info) = do
760 let mod = GHC.breakInfo_module info
761 nm = GHC.breakInfo_number info
763 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
764 breakModule loc == mod,
765 breakTick loc == nm ]
767 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
768 printStoppedAtBreakInfo resume names = do
769 printForUser $ ptext (sLit "Stopped at") <+>
770 ppr (GHC.resumeSpan resume)
771 -- printTypeOfNames session names
772 let namesSorted = sortBy compareNames names
773 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
774 docs <- pprTypeAndContents [id | AnId id <- tythings]
775 printForUserPartWay docs
777 printTypeOfNames :: [Name] -> GHCi ()
778 printTypeOfNames names
779 = mapM_ (printTypeOfName ) $ sortBy compareNames names
781 compareNames :: Name -> Name -> Ordering
782 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
783 where compareWith n = (getOccString n, getSrcSpan n)
785 printTypeOfName :: Name -> GHCi ()
787 = do maybe_tything <- GHC.lookupName n
788 case maybe_tything of
790 Just thing -> printTyThing thing
793 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
795 specialCommand :: String -> GHCi Bool
796 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
797 specialCommand str = do
798 let (cmd,rest) = break isSpace str
799 maybe_cmd <- lookupCommand cmd
801 GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
803 do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
807 do io $ hPutStr stdout ("there is no last command to perform\n"
811 lookupCommand :: String -> GHCi (MaybeCommand)
812 lookupCommand "" = do
814 case last_command st of
815 Just c -> return $ GotCommand c
816 Nothing -> return NoLastCommand
817 lookupCommand str = do
818 mc <- io $ lookupCommand' str
820 setGHCiState st{ last_command = mc }
822 Just c -> GotCommand c
823 Nothing -> BadCommand
825 lookupCommand' :: String -> IO (Maybe Command)
826 lookupCommand' str = do
827 macros <- readIORef macros_ref
828 let cmds = builtin_commands ++ macros
829 -- look for exact match first, then the first prefix match
830 return $ case [ c | c <- cmds, str == cmdName c ] of
832 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
836 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
837 getCurrentBreakSpan = do
838 resumes <- GHC.getResumeContext
842 let ix = GHC.resumeHistoryIx r
844 then return (Just (GHC.resumeSpan r))
846 let hist = GHC.resumeHistory r !! (ix-1)
847 span <- GHC.getHistorySpan hist
850 getCurrentBreakModule :: GHCi (Maybe Module)
851 getCurrentBreakModule = do
852 resumes <- GHC.getResumeContext
856 let ix = GHC.resumeHistoryIx r
858 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
860 let hist = GHC.resumeHistory r !! (ix-1)
861 return $ Just $ GHC.getHistoryModule hist
863 -----------------------------------------------------------------------------
866 noArgs :: GHCi () -> String -> GHCi ()
868 noArgs _ _ = io $ putStrLn "This command takes no arguments"
870 help :: String -> GHCi ()
871 help _ = io (putStr helpText)
873 info :: String -> GHCi ()
874 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
875 info s = handleSourceError GHC.printExceptionAndWarnings $ do
876 { let names = words s
877 ; dflags <- getDynFlags
878 ; let pefas = dopt Opt_PrintExplicitForalls dflags
879 ; mapM_ (infoThing pefas) names }
881 infoThing pefas str = do
882 names <- GHC.parseName str
883 mb_stuffs <- mapM GHC.getInfo names
884 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
885 unqual <- GHC.getPrintUnqual
887 putStrLn (showSDocForUser unqual $
888 vcat (intersperse (text "") $
889 map (pprInfo pefas) filtered))
891 -- Filter out names whose parent is also there Good
892 -- example is '[]', which is both a type and data
893 -- constructor in the same type
894 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
895 filterOutChildren get_thing xs
896 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
898 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
900 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
901 pprInfo pefas (thing, fixity, insts)
902 = pprTyThingInContextLoc pefas thing
903 $$ show_fixity fixity
904 $$ vcat (map GHC.pprInstance insts)
907 | fix == GHC.defaultFixity = empty
908 | otherwise = ppr fix <+> ppr (GHC.getName thing)
910 runMain :: String -> GHCi ()
911 runMain s = case toArgs s of
912 Left err -> io (hPutStrLn stderr err)
914 do dflags <- getDynFlags
915 case mainFunIs dflags of
916 Nothing -> doWithArgs args "main"
917 Just f -> doWithArgs args f
919 runRun :: String -> GHCi ()
920 runRun s = case toCmdArgs s of
921 Left err -> io (hPutStrLn stderr err)
922 Right (cmd, args) -> doWithArgs args cmd
924 doWithArgs :: [String] -> String -> GHCi ()
925 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
926 show args ++ " (" ++ cmd ++ ")"]
928 addModule :: [FilePath] -> GHCi ()
930 revertCAFs -- always revert CAFs on load/add.
931 files <- mapM expandPath files
932 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
933 -- remove old targets with the same id; e.g. for :add *M
934 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
935 mapM_ GHC.addTarget targets
936 prev_context <- GHC.getContext
937 ok <- trySuccess $ GHC.load LoadAllTargets
938 afterLoad ok False prev_context
940 changeDirectory :: String -> GHCi ()
941 changeDirectory "" = do
942 -- :cd on its own changes to the user's home directory
943 either_dir <- io (IO.try getHomeDirectory)
946 Right dir -> changeDirectory dir
947 changeDirectory dir = do
948 graph <- GHC.getModuleGraph
949 when (not (null graph)) $
950 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
951 prev_context <- GHC.getContext
953 GHC.load LoadAllTargets
954 setContextAfterLoad prev_context False []
955 GHC.workingDirectoryChanged
956 dir <- expandPath dir
957 io (setCurrentDirectory dir)
959 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
961 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
965 editFile :: String -> GHCi ()
967 do file <- if null str then chooseEditFile else return str
971 $ ghcError (CmdLineError "editor not set, use :set editor")
972 io $ system (cmd ++ ' ':file)
975 -- The user didn't specify a file so we pick one for them.
976 -- Our strategy is to pick the first module that failed to load,
977 -- or otherwise the first target.
979 -- XXX: Can we figure out what happened if the depndecy analysis fails
980 -- (e.g., because the porgrammeer mistyped the name of a module)?
981 -- XXX: Can we figure out the location of an error to pass to the editor?
982 -- XXX: if we could figure out the list of errors that occured during the
983 -- last load/reaload, then we could start the editor focused on the first
985 chooseEditFile :: GHCi String
987 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
989 graph <- GHC.getModuleGraph
990 failed_graph <- filterM hasFailed graph
991 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
993 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
996 case pick (order failed_graph) of
997 Just file -> return file
999 do targets <- GHC.getTargets
1000 case msum (map fromTarget targets) of
1001 Just file -> return file
1002 Nothing -> ghcError (CmdLineError "No files to edit.")
1004 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
1005 fromTarget _ = Nothing -- when would we get a module target?
1007 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
1008 defineMacro overwrite s = do
1009 let (macro_name, definition) = break isSpace s
1010 macros <- io (readIORef macros_ref)
1011 let defined = map cmdName macros
1012 if (null macro_name)
1013 then if null defined
1014 then io $ putStrLn "no macros defined"
1015 else io $ putStr ("the following macros are defined:\n" ++
1018 if (not overwrite && macro_name `elem` defined)
1019 then ghcError (CmdLineError
1020 ("macro '" ++ macro_name ++ "' is already defined"))
1023 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
1025 -- give the expression a type signature, so we can be sure we're getting
1026 -- something of the right type.
1027 let new_expr = '(' : definition ++ ") :: String -> IO String"
1029 -- compile the expression
1030 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1031 hv <- GHC.compileExpr new_expr
1032 io (writeIORef macros_ref --
1033 (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)]))
1035 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
1037 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
1038 -- make sure we force any exceptions in the result, while we are still
1039 -- inside the exception handler for commands:
1040 seqList str (return ())
1041 enqueueCommands (lines str)
1044 undefineMacro :: String -> GHCi ()
1045 undefineMacro str = mapM_ undef (words str)
1046 where undef macro_name = do
1047 cmds <- io (readIORef macros_ref)
1048 if (macro_name `notElem` map cmdName cmds)
1049 then ghcError (CmdLineError
1050 ("macro '" ++ macro_name ++ "' is not defined"))
1052 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
1054 cmdCmd :: String -> GHCi ()
1056 let expr = '(' : str ++ ") :: IO String"
1057 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1058 hv <- GHC.compileExpr expr
1059 cmds <- io $ (unsafeCoerce# hv :: IO String)
1060 enqueueCommands (lines cmds)
1063 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1064 loadModule fs = timeIt (loadModule' fs)
1066 loadModule_ :: [FilePath] -> GHCi ()
1067 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
1069 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1070 loadModule' files = do
1071 prev_context <- GHC.getContext
1075 discardActiveBreakPoints
1077 GHC.load LoadAllTargets
1080 let (filenames, phases) = unzip files
1081 exp_filenames <- mapM expandPath filenames
1082 let files' = zip exp_filenames phases
1083 targets <- mapM (uncurry GHC.guessTarget) files'
1085 -- NOTE: we used to do the dependency anal first, so that if it
1086 -- fails we didn't throw away the current set of modules. This would
1087 -- require some re-working of the GHC interface, so we'll leave it
1088 -- as a ToDo for now.
1090 GHC.setTargets targets
1091 doLoad False prev_context LoadAllTargets
1093 checkModule :: String -> GHCi ()
1095 let modl = GHC.mkModuleName m
1096 prev_context <- GHC.getContext
1097 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1098 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1099 io $ putStrLn (showSDoc (
1100 case GHC.moduleInfo r of
1101 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1103 (local,global) = ASSERT( all isExternalName scope )
1104 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1106 (text "global names: " <+> ppr global) $$
1107 (text "local names: " <+> ppr local)
1110 afterLoad (successIf ok) False prev_context
1112 reloadModule :: String -> GHCi ()
1114 prev_context <- GHC.getContext
1115 doLoad True prev_context $
1116 if null m then LoadAllTargets
1117 else LoadUpTo (GHC.mkModuleName m)
1120 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1121 doLoad retain_context prev_context howmuch = do
1122 -- turn off breakpoints before we load: we can't turn them off later, because
1123 -- the ModBreaks will have gone away.
1124 discardActiveBreakPoints
1125 ok <- trySuccess $ GHC.load howmuch
1126 afterLoad ok retain_context prev_context
1129 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> GHCi ()
1130 afterLoad ok retain_context prev_context = do
1131 revertCAFs -- always revert CAFs on load.
1133 loaded_mod_summaries <- getLoadedModules
1134 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1135 loaded_mod_names = map GHC.moduleName loaded_mods
1136 modulesLoadedMsg ok loaded_mod_names
1138 setContextAfterLoad prev_context retain_context loaded_mod_summaries
1141 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1142 setContextAfterLoad prev keep_ctxt [] = do
1143 prel_mod <- getPrelude
1144 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1145 setContextAfterLoad prev keep_ctxt ms = do
1146 -- load a target if one is available, otherwise load the topmost module.
1147 targets <- GHC.getTargets
1148 case [ m | Just m <- map (findTarget ms) targets ] of
1150 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1151 load_this (last graph')
1156 = case filter (`matches` t) ms of
1160 summary `matches` Target (TargetModule m) _ _
1161 = GHC.ms_mod_name summary == m
1162 summary `matches` Target (TargetFile f _) _ _
1163 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1167 load_this summary | m <- GHC.ms_mod summary = do
1168 b <- GHC.moduleIsInterpreted m
1169 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1171 prel_mod <- getPrelude
1172 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1174 -- | Keep any package modules (except Prelude) when changing the context.
1175 setContextKeepingPackageModules
1176 :: ([Module],[Module]) -- previous context
1177 -> Bool -- re-execute :module commands
1178 -> ([Module],[Module]) -- new context
1180 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1181 let (_,bs0) = prev_context
1182 prel_mod <- getPrelude
1183 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1184 let bs1 = if null as then nub (prel_mod : bs) else bs
1185 GHC.setContext as (nub (bs1 ++ pkg_modules))
1189 mapM_ (playCtxtCmd False) (remembered_ctx st)
1192 setGHCiState st{ remembered_ctx = [] }
1194 isHomeModule :: Module -> Bool
1195 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1197 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1198 modulesLoadedMsg ok mods = do
1199 dflags <- getDynFlags
1200 when (verbosity dflags > 0) $ do
1202 | null mods = text "none."
1203 | otherwise = hsep (
1204 punctuate comma (map ppr mods)) <> text "."
1207 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1209 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1212 typeOfExpr :: String -> GHCi ()
1214 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1215 ty <- GHC.exprType str
1216 dflags <- getDynFlags
1217 let pefas = dopt Opt_PrintExplicitForalls dflags
1218 printForUser $ sep [utext str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1220 kindOfType :: String -> GHCi ()
1222 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1223 ty <- GHC.typeKind str
1224 printForUser $ utext str <+> dcolon <+> ppr ty
1226 -- HACK for printing unicode text. We assume the output device
1227 -- understands UTF-8, and go via FastString which converts to UTF-8.
1228 -- ToDo: fix properly when we have encoding support in Handles.
1229 utext :: String -> SDoc
1230 utext str = ftext (mkFastString str)
1232 quit :: String -> GHCi Bool
1233 quit _ = return True
1235 shellEscape :: String -> GHCi Bool
1236 shellEscape str = io (system str >> return False)
1238 -----------------------------------------------------------------------------
1239 -- Browsing a module's contents
1241 browseCmd :: Bool -> String -> GHCi ()
1244 ['*':s] | looksLikeModuleName s -> do
1245 m <- wantInterpretedModule s
1246 browseModule bang m False
1247 [s] | looksLikeModuleName s -> do
1249 browseModule bang m True
1251 (as,bs) <- GHC.getContext
1252 -- Guess which module the user wants to browse. Pick
1253 -- modules that are interpreted first. The most
1254 -- recently-added module occurs last, it seems.
1256 (as@(_:_), _) -> browseModule bang (last as) True
1257 ([], bs@(_:_)) -> browseModule bang (last bs) True
1258 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1259 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1261 -- without bang, show items in context of their parents and omit children
1262 -- with bang, show class methods and data constructors separately, and
1263 -- indicate import modules, to aid qualifying unqualified names
1264 -- with sorted, sort items alphabetically
1265 browseModule :: Bool -> Module -> Bool -> GHCi ()
1266 browseModule bang modl exports_only = do
1267 -- :browse! reports qualifiers wrt current context
1268 current_unqual <- GHC.getPrintUnqual
1269 -- Temporarily set the context to the module we're interested in,
1270 -- just so we can get an appropriate PrintUnqualified
1271 (as,bs) <- GHC.getContext
1272 prel_mod <- getPrelude
1273 if exports_only then GHC.setContext [] [prel_mod,modl]
1274 else GHC.setContext [modl] []
1275 target_unqual <- GHC.getPrintUnqual
1276 GHC.setContext as bs
1278 let unqual = if bang then current_unqual else target_unqual
1280 mb_mod_info <- GHC.getModuleInfo modl
1282 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1283 GHC.moduleNameString (GHC.moduleName modl)))
1285 dflags <- getDynFlags
1287 | exports_only = GHC.modInfoExports mod_info
1288 | otherwise = GHC.modInfoTopLevelScope mod_info
1291 -- sort alphabetically name, but putting
1292 -- locally-defined identifiers first.
1293 -- We would like to improve this; see #1799.
1294 sorted_names = loc_sort local ++ occ_sort external
1296 (local,external) = ASSERT( all isExternalName names )
1297 partition ((==modl) . nameModule) names
1298 occ_sort = sortBy (compare `on` nameOccName)
1299 -- try to sort by src location. If the first name in
1300 -- our list has a good source location, then they all should.
1302 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1303 = sortBy (compare `on` nameSrcSpan) names
1307 mb_things <- mapM GHC.lookupName sorted_names
1308 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1310 rdr_env <- GHC.getGRE
1312 let pefas = dopt Opt_PrintExplicitForalls dflags
1313 things | bang = catMaybes mb_things
1314 | otherwise = filtered_things
1315 pretty | bang = pprTyThing
1316 | otherwise = pprTyThingInContext
1318 labels [] = text "-- not currently imported"
1319 labels l = text $ intercalate "\n" $ map qualifier l
1320 qualifier = maybe "-- defined locally"
1321 (("-- imported via "++) . intercalate ", "
1322 . map GHC.moduleNameString)
1323 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1324 modNames = map (importInfo . GHC.getName) things
1326 -- annotate groups of imports with their import modules
1327 -- the default ordering is somewhat arbitrary, so we group
1328 -- by header and sort groups; the names themselves should
1329 -- really come in order of source appearance.. (trac #1799)
1330 annotate mts = concatMap (\(m,ts)->labels m:ts)
1331 $ sortBy cmpQualifiers $ group mts
1332 where cmpQualifiers =
1333 compare `on` (map (fmap (map moduleNameFS)) . fst)
1335 group mts@((m,_):_) = (m,map snd g) : group ng
1336 where (g,ng) = partition ((==m).fst) mts
1338 let prettyThings = map (pretty pefas) things
1339 prettyThings' | bang = annotate $ zip modNames prettyThings
1340 | otherwise = prettyThings
1341 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1342 -- ToDo: modInfoInstances currently throws an exception for
1343 -- package modules. When it works, we can do this:
1344 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1346 -----------------------------------------------------------------------------
1347 -- Setting the module context
1349 setContext :: String -> GHCi ()
1351 | all sensible strs = do
1352 playCtxtCmd True (cmd, as, bs)
1354 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1355 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1357 (cmd, strs, as, bs) =
1359 '+':stuff -> rest AddModules stuff
1360 '-':stuff -> rest RemModules stuff
1361 stuff -> rest SetContext stuff
1363 rest cmd stuff = (cmd, strs, as, bs)
1364 where strs = words stuff
1365 (as,bs) = partitionWith starred strs
1367 sensible ('*':m) = looksLikeModuleName m
1368 sensible m = looksLikeModuleName m
1370 starred ('*':m) = Left m
1373 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1374 playCtxtCmd fail (cmd, as, bs)
1376 (as',bs') <- do_checks fail
1377 (prev_as,prev_bs) <- GHC.getContext
1381 prel_mod <- getPrelude
1382 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1386 let as_to_add = as' \\ (prev_as ++ prev_bs)
1387 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1388 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1390 let new_as = prev_as \\ (as' ++ bs')
1391 new_bs = prev_bs \\ (as' ++ bs')
1392 return (new_as, new_bs)
1393 GHC.setContext new_as new_bs
1396 as' <- mapM wantInterpretedModule as
1397 bs' <- mapM lookupModule bs
1399 do_checks False = do
1400 as' <- mapM (trymaybe . wantInterpretedModule) as
1401 bs' <- mapM (trymaybe . lookupModule) bs
1402 return (catMaybes as', catMaybes bs')
1407 Left _ -> return Nothing
1408 Right a -> return (Just a)
1410 ----------------------------------------------------------------------------
1413 -- set options in the interpreter. Syntax is exactly the same as the
1414 -- ghc command line, except that certain options aren't available (-C,
1417 -- This is pretty fragile: most options won't work as expected. ToDo:
1418 -- figure out which ones & disallow them.
1420 setCmd :: String -> GHCi ()
1422 = do st <- getGHCiState
1423 let opts = options st
1424 io $ putStrLn (showSDoc (
1425 text "options currently set: " <>
1428 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1430 dflags <- getDynFlags
1431 io $ putStrLn (showSDoc (
1432 vcat (text "GHCi-specific dynamic flag settings:"
1433 :map (flagSetting dflags) ghciFlags)
1435 io $ putStrLn (showSDoc (
1436 vcat (text "other dynamic, non-language, flag settings:"
1437 :map (flagSetting dflags) nonLanguageDynFlags)
1439 where flagSetting dflags (str, f, _)
1440 | dopt f dflags = text " " <> text "-f" <> text str
1441 | otherwise = text " " <> text "-fno-" <> text str
1442 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1444 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1446 flags = [Opt_PrintExplicitForalls
1447 ,Opt_PrintBindResult
1448 ,Opt_BreakOnException
1450 ,Opt_PrintEvldWithShow
1453 = case getCmd str of
1454 Right ("args", rest) ->
1456 Left err -> io (hPutStrLn stderr err)
1457 Right args -> setArgs args
1458 Right ("prog", rest) ->
1460 Right [prog] -> setProg prog
1461 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1462 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1463 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1464 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1465 _ -> case toArgs str of
1466 Left err -> io (hPutStrLn stderr err)
1467 Right wds -> setOptions wds
1469 setArgs, setOptions :: [String] -> GHCi ()
1470 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1474 setGHCiState st{ args = args }
1478 setGHCiState st{ progname = prog }
1482 setGHCiState st{ editor = cmd }
1484 setStop str@(c:_) | isDigit c
1485 = do let (nm_str,rest) = break (not.isDigit) str
1488 let old_breaks = breaks st
1489 if all ((/= nm) . fst) old_breaks
1490 then printForUser (text "Breakpoint" <+> ppr nm <+>
1491 text "does not exist")
1493 let new_breaks = map fn old_breaks
1494 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1495 | otherwise = (i,loc)
1496 setGHCiState st{ breaks = new_breaks }
1499 setGHCiState st{ stop = cmd }
1501 setPrompt value = do
1504 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1506 '\"' : _ -> case reads value of
1507 [(value', xs)] | all isSpace xs ->
1508 setGHCiState (st { prompt = value' })
1510 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1511 _ -> setGHCiState (st { prompt = value })
1514 do -- first, deal with the GHCi opts (+s, +t, etc.)
1515 let (plus_opts, minus_opts) = partitionWith isPlus wds
1516 mapM_ setOpt plus_opts
1517 -- then, dynamic flags
1518 newDynFlags minus_opts
1520 newDynFlags :: [String] -> GHCi ()
1521 newDynFlags minus_opts = do
1522 dflags <- getDynFlags
1523 let pkg_flags = packageFlags dflags
1524 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1525 handleFlagWarnings dflags' warns
1527 if (not (null leftovers))
1528 then ghcError $ errorsToGhcException leftovers
1531 new_pkgs <- setDynFlags dflags'
1533 -- if the package flags changed, we should reset the context
1534 -- and link the new packages.
1535 dflags <- getDynFlags
1536 when (packageFlags dflags /= pkg_flags) $ do
1537 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1539 GHC.load LoadAllTargets
1540 io (linkPackages dflags new_pkgs)
1541 -- package flags changed, we can't re-use any of the old context
1542 setContextAfterLoad ([],[]) False []
1546 unsetOptions :: String -> GHCi ()
1548 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1549 let opts = words str
1550 (minus_opts, rest1) = partition isMinus opts
1551 (plus_opts, rest2) = partitionWith isPlus rest1
1553 if (not (null rest2))
1554 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1557 mapM_ unsetOpt plus_opts
1559 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1560 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1562 no_flags <- mapM no_flag minus_opts
1563 newDynFlags no_flags
1565 isMinus :: String -> Bool
1566 isMinus ('-':_) = True
1569 isPlus :: String -> Either String String
1570 isPlus ('+':opt) = Left opt
1571 isPlus other = Right other
1573 setOpt, unsetOpt :: String -> GHCi ()
1576 = case strToGHCiOpt str of
1577 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1578 Just o -> setOption o
1581 = case strToGHCiOpt str of
1582 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1583 Just o -> unsetOption o
1585 strToGHCiOpt :: String -> (Maybe GHCiOption)
1586 strToGHCiOpt "s" = Just ShowTiming
1587 strToGHCiOpt "t" = Just ShowType
1588 strToGHCiOpt "r" = Just RevertCAFs
1589 strToGHCiOpt _ = Nothing
1591 optToStr :: GHCiOption -> String
1592 optToStr ShowTiming = "s"
1593 optToStr ShowType = "t"
1594 optToStr RevertCAFs = "r"
1596 -- ---------------------------------------------------------------------------
1599 showCmd :: String -> GHCi ()
1603 ["args"] -> io $ putStrLn (show (args st))
1604 ["prog"] -> io $ putStrLn (show (progname st))
1605 ["prompt"] -> io $ putStrLn (show (prompt st))
1606 ["editor"] -> io $ putStrLn (show (editor st))
1607 ["stop"] -> io $ putStrLn (show (stop st))
1608 ["modules" ] -> showModules
1609 ["bindings"] -> showBindings
1610 ["linker"] -> io showLinkerState
1611 ["breaks"] -> showBkptTable
1612 ["context"] -> showContext
1613 ["packages"] -> showPackages
1614 ["languages"] -> showLanguages
1615 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1616 " | breaks | context | packages | languages ]"))
1618 showModules :: GHCi ()
1620 loaded_mods <- getLoadedModules
1621 -- we want *loaded* modules only, see #1734
1622 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1623 mapM_ show_one loaded_mods
1625 getLoadedModules :: GHCi [GHC.ModSummary]
1626 getLoadedModules = do
1627 graph <- GHC.getModuleGraph
1628 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1630 showBindings :: GHCi ()
1632 bindings <- GHC.getBindings
1633 docs <- pprTypeAndContents
1634 [ id | AnId id <- sortBy compareTyThings bindings]
1635 printForUserPartWay docs
1637 compareTyThings :: TyThing -> TyThing -> Ordering
1638 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1640 printTyThing :: TyThing -> GHCi ()
1641 printTyThing tyth = do dflags <- getDynFlags
1642 let pefas = dopt Opt_PrintExplicitForalls dflags
1643 printForUser (pprTyThing pefas tyth)
1645 showBkptTable :: GHCi ()
1648 printForUser $ prettyLocations (breaks st)
1650 showContext :: GHCi ()
1652 resumes <- GHC.getResumeContext
1653 printForUser $ vcat (map pp_resume (reverse resumes))
1656 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1657 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1659 showPackages :: GHCi ()
1661 pkg_flags <- fmap packageFlags getDynFlags
1662 io $ putStrLn $ showSDoc $ vcat $
1663 text ("active package flags:"++if null pkg_flags then " none" else "")
1664 : map showFlag pkg_flags
1665 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1666 io $ putStrLn $ showSDoc $ vcat $
1667 text "packages currently loaded:"
1668 : map (nest 2 . text . packageIdString)
1669 (sortBy (compare `on` packageIdFS) pkg_ids)
1670 where showFlag (ExposePackage p) = text $ " -package " ++ p
1671 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1672 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1674 showLanguages :: GHCi ()
1676 dflags <- getDynFlags
1677 io $ putStrLn $ showSDoc $ vcat $
1678 text "active language flags:" :
1679 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1681 -- -----------------------------------------------------------------------------
1684 completeNone :: String -> IO [String]
1685 completeNone _w = return []
1687 completeMacro, completeIdentifier, completeModule,
1688 completeHomeModule, completeSetOptions, completeShowOptions,
1689 completeFilename, completeHomeModuleOrFile
1690 :: String -> IO [String]
1693 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1694 completeWord w start end = do
1695 line <- Readline.getLineBuffer
1696 let line_words = words (dropWhile isSpace line)
1698 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1700 | ((':':c) : _) <- line_words -> do
1701 completionVars <- lookupCompletionVars c
1702 case completionVars of
1703 (Nothing,complete) -> wrapCompleter complete w
1704 (Just breakChars,complete)
1705 -> let (n,w') = selectWord
1706 (words' (`elem` breakChars) 0 line)
1707 complete' w = do rets <- complete w
1708 return (map (drop n) rets)
1709 in wrapCompleter complete' w'
1710 | ("import" : _) <- line_words ->
1711 wrapCompleter completeModule w
1713 --printf "complete %s, start = %d, end = %d\n" w start end
1714 wrapCompleter completeIdentifier w
1715 where words' _ _ [] = []
1716 words' isBreak n str = let (w,r) = break isBreak str
1717 (s,r') = span isBreak r
1718 in (n,w):words' isBreak (n+length w+length s) r'
1719 -- In a Haskell expression we want to parse 'a-b' as three words
1720 -- where a compiler flag (e.g. -ddump-simpl) should
1721 -- only be a single word.
1722 selectWord [] = (0,w)
1723 selectWord ((offset,x):xs)
1724 | offset+length x >= start = (start-offset,take (end-offset) x)
1725 | otherwise = selectWord xs
1727 lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars,
1729 lookupCompletionVars c = do
1730 maybe_cmd <- lookupCommand' c
1732 Just (_,_,ws,f) -> return (ws,f)
1733 Nothing -> return (Just filenameWordBreakChars,
1737 completeCmd :: String -> IO [String]
1739 cmds <- readIORef macros_ref
1740 return (filter (w `isPrefixOf`) (map (':':)
1741 (map cmdName (builtin_commands ++ cmds))))
1743 completeMacro w = do
1744 cmds <- readIORef macros_ref
1745 return (filter (w `isPrefixOf`) (map cmdName cmds))
1747 completeIdentifier w = do
1748 rdrs <- withRestoredSession GHC.getRdrNamesInScope
1749 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1751 completeModule w = do
1752 dflags <- withRestoredSession GHC.getSessionDynFlags
1753 let pkg_mods = allExposedModules dflags
1754 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1756 completeHomeModule w = do
1757 g <- withRestoredSession GHC.getModuleGraph
1758 let home_mods = map GHC.ms_mod_name g
1759 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1761 completeSetOptions w = do
1762 return (filter (w `isPrefixOf`) options)
1763 where options = "args":"prog":"prompt":"editor":"stop":flagList
1764 flagList = map head $ group $ sort allFlags
1766 completeShowOptions w = do
1767 return (filter (w `isPrefixOf`) options)
1768 where options = ["args", "prog", "prompt", "editor", "stop",
1769 "modules", "bindings", "linker", "breaks",
1770 "context", "packages", "languages"]
1772 completeFilename w = do
1773 ws <- Readline.filenameCompletionFunction w
1775 -- If we only found one result, and it's a directory,
1776 -- add a trailing slash.
1778 isDir <- expandPathIO file >>= doesDirectoryExist
1779 if isDir && last file /= '/'
1780 then return [file ++ "/"]
1785 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1787 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1788 unionComplete f1 f2 w = do
1793 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1794 wrapCompleter fun w = do
1797 [] -> Readline.setAttemptedCompletionOver True >> return Nothing
1798 [x] -> -- Add a trailing space, unless it already has an appended slash.
1799 let appended = if last x == '/' then x else x ++ " "
1800 in return (Just (appended,[]))
1801 xs -> case getCommonPrefix xs of
1802 "" -> return (Just ("",xs))
1803 pref -> return (Just (pref,xs))
1805 getCommonPrefix :: [String] -> String
1806 getCommonPrefix [] = ""
1807 getCommonPrefix (s:ss) = foldl common s ss
1808 where common _s "" = ""
1810 common (c:cs) (d:ds)
1811 | c == d = c : common cs ds
1814 allExposedModules :: DynFlags -> [ModuleName]
1815 allExposedModules dflags
1816 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1818 pkg_db = pkgIdMap (pkgState dflags)
1820 completeMacro = completeNone
1821 completeIdentifier = completeNone
1822 completeModule = completeNone
1823 completeHomeModule = completeNone
1824 completeSetOptions = completeNone
1825 completeShowOptions = completeNone
1826 completeFilename = completeNone
1827 completeHomeModuleOrFile=completeNone
1830 -- ---------------------------------------------------------------------------
1831 -- User code exception handling
1833 -- This is the exception handler for exceptions generated by the
1834 -- user's code and exceptions coming from children sessions;
1835 -- it normally just prints out the exception. The
1836 -- handler must be recursive, in case showing the exception causes
1837 -- more exceptions to be raised.
1839 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1840 -- raising another exception. We therefore don't put the recursive
1841 -- handler arond the flushing operation, so if stderr is closed
1842 -- GHCi will just die gracefully rather than going into an infinite loop.
1843 handler :: SomeException -> GHCi Bool
1845 handler exception = do
1847 io installSignalHandlers
1848 ghciHandle handler (showException exception >> return False)
1850 showException :: SomeException -> GHCi ()
1852 io $ case fromException se of
1853 Just Interrupted -> putStrLn "Interrupted."
1854 -- omit the location for CmdLineError:
1855 Just (CmdLineError s) -> putStrLn s
1857 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1858 Just other_ghc_ex -> print other_ghc_ex
1859 Nothing -> putStrLn ("*** Exception: " ++ show se)
1861 -----------------------------------------------------------------------------
1862 -- recursive exception handlers
1864 -- Don't forget to unblock async exceptions in the handler, or if we're
1865 -- in an exception loop (eg. let a = error a in a) the ^C exception
1866 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1868 ghciHandle :: (SomeException -> GHCi a) -> GHCi a -> GHCi a
1869 ghciHandle h (GHCi m) = GHCi $ \s ->
1871 (\e -> unGHCi (ghciUnblock (h e)) s)
1873 ghciUnblock :: GHCi a -> GHCi a
1874 ghciUnblock (GHCi a) =
1875 GHCi $ \s -> reifyGhc $ \gs ->
1876 Exception.unblock (reflectGhc (a s) gs)
1878 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1879 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1881 -- ----------------------------------------------------------------------------
1884 expandPath :: String -> GHCi String
1885 expandPath path = io (expandPathIO path)
1887 expandPathIO :: String -> IO String
1889 case dropWhile isSpace path of
1891 tilde <- getHomeDirectory -- will fail if HOME not defined
1892 return (tilde ++ '/':d)
1896 wantInterpretedModule :: String -> GHCi Module
1897 wantInterpretedModule str = do
1898 modl <- lookupModule str
1899 dflags <- getDynFlags
1900 when (GHC.modulePackageId modl /= thisPackage dflags) $
1901 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1902 is_interpreted <- GHC.moduleIsInterpreted modl
1903 when (not is_interpreted) $
1904 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1907 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1908 -> (Name -> GHCi ())
1910 wantNameFromInterpretedModule noCanDo str and_then =
1911 handleSourceError (GHC.printExceptionAndWarnings) $ do
1912 names <- GHC.parseName str
1916 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1917 if not (GHC.isExternalName n)
1918 then noCanDo n $ ppr n <>
1919 text " is not defined in an interpreted module"
1921 is_interpreted <- GHC.moduleIsInterpreted modl
1922 if not is_interpreted
1923 then noCanDo n $ text "module " <> ppr modl <>
1924 text " is not interpreted"
1927 -- -----------------------------------------------------------------------------
1928 -- commands for debugger
1930 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1931 sprintCmd = pprintCommand False False
1932 printCmd = pprintCommand True False
1933 forceCmd = pprintCommand False True
1935 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1936 pprintCommand bind force str = do
1937 pprintClosureCommand bind force str
1939 stepCmd :: String -> GHCi ()
1940 stepCmd [] = doContinue (const True) GHC.SingleStep
1941 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1943 stepLocalCmd :: String -> GHCi ()
1944 stepLocalCmd [] = do
1945 mb_span <- getCurrentBreakSpan
1947 Nothing -> stepCmd []
1949 Just mod <- getCurrentBreakModule
1950 current_toplevel_decl <- enclosingTickSpan mod loc
1951 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1953 stepLocalCmd expression = stepCmd expression
1955 stepModuleCmd :: String -> GHCi ()
1956 stepModuleCmd [] = do
1957 mb_span <- getCurrentBreakSpan
1959 Nothing -> stepCmd []
1961 Just span <- getCurrentBreakSpan
1962 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1963 doContinue f GHC.SingleStep
1965 stepModuleCmd expression = stepCmd expression
1967 -- | Returns the span of the largest tick containing the srcspan given
1968 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1969 enclosingTickSpan mod src = do
1970 ticks <- getTickArray mod
1971 let line = srcSpanStartLine src
1972 ASSERT (inRange (bounds ticks) line) do
1973 let enclosing_spans = [ span | (_,span) <- ticks ! line
1974 , srcSpanEnd span >= srcSpanEnd src]
1975 return . head . sortBy leftmost_largest $ enclosing_spans
1977 traceCmd :: String -> GHCi ()
1978 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1979 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1981 continueCmd :: String -> GHCi ()
1982 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1984 -- doContinue :: SingleStep -> GHCi ()
1985 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1986 doContinue pred step = do
1987 runResult <- resume pred step
1988 afterRunStmt pred runResult
1991 abandonCmd :: String -> GHCi ()
1992 abandonCmd = noArgs $ do
1993 b <- GHC.abandon -- the prompt will change to indicate the new context
1994 when (not b) $ io $ putStrLn "There is no computation running."
1997 deleteCmd :: String -> GHCi ()
1998 deleteCmd argLine = do
1999 deleteSwitch $ words argLine
2001 deleteSwitch :: [String] -> GHCi ()
2003 io $ putStrLn "The delete command requires at least one argument."
2004 -- delete all break points
2005 deleteSwitch ("*":_rest) = discardActiveBreakPoints
2006 deleteSwitch idents = do
2007 mapM_ deleteOneBreak idents
2009 deleteOneBreak :: String -> GHCi ()
2011 | all isDigit str = deleteBreak (read str)
2012 | otherwise = return ()
2014 historyCmd :: String -> GHCi ()
2016 | null arg = history 20
2017 | all isDigit arg = history (read arg)
2018 | otherwise = io $ putStrLn "Syntax: :history [num]"
2021 resumes <- GHC.getResumeContext
2023 [] -> io $ putStrLn "Not stopped at a breakpoint"
2025 let hist = GHC.resumeHistory r
2026 (took,rest) = splitAt num hist
2028 [] -> io $ putStrLn $
2029 "Empty history. Perhaps you forgot to use :trace?"
2031 spans <- mapM GHC.getHistorySpan took
2032 let nums = map (printf "-%-3d:") [(1::Int)..]
2033 names = map GHC.historyEnclosingDecl took
2034 printForUser (vcat(zipWith3
2035 (\x y z -> x <+> y <+> z)
2037 (map (bold . ppr) names)
2038 (map (parens . ppr) spans)))
2039 io $ putStrLn $ if null rest then "<end of history>" else "..."
2041 bold :: SDoc -> SDoc
2042 bold c | do_bold = text start_bold <> c <> text end_bold
2045 backCmd :: String -> GHCi ()
2046 backCmd = noArgs $ do
2047 (names, _, span) <- GHC.back
2048 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
2049 printTypeOfNames names
2050 -- run the command set with ":set stop <cmd>"
2052 enqueueCommands [stop st]
2054 forwardCmd :: String -> GHCi ()
2055 forwardCmd = noArgs $ do
2056 (names, ix, span) <- GHC.forward
2057 printForUser $ (if (ix == 0)
2058 then ptext (sLit "Stopped at")
2059 else ptext (sLit "Logged breakpoint at")) <+> ppr span
2060 printTypeOfNames names
2061 -- run the command set with ":set stop <cmd>"
2063 enqueueCommands [stop st]
2065 -- handle the "break" command
2066 breakCmd :: String -> GHCi ()
2067 breakCmd argLine = do
2068 breakSwitch $ words argLine
2070 breakSwitch :: [String] -> GHCi ()
2072 io $ putStrLn "The break command requires at least one argument."
2073 breakSwitch (arg1:rest)
2074 | looksLikeModuleName arg1 && not (null rest) = do
2075 mod <- wantInterpretedModule arg1
2076 breakByModule mod rest
2077 | all isDigit arg1 = do
2078 (toplevel, _) <- GHC.getContext
2080 (mod : _) -> breakByModuleLine mod (read arg1) rest
2082 io $ putStrLn "Cannot find default module for breakpoint."
2083 io $ putStrLn "Perhaps no modules are loaded for debugging?"
2084 | otherwise = do -- try parsing it as an identifier
2085 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2086 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2087 if GHC.isGoodSrcLoc loc
2088 then ASSERT( isExternalName name )
2089 findBreakAndSet (GHC.nameModule name) $
2090 findBreakByCoord (Just (GHC.srcLocFile loc))
2091 (GHC.srcLocLine loc,
2093 else noCanDo name $ text "can't find its location: " <> ppr loc
2095 noCanDo n why = printForUser $
2096 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2098 breakByModule :: Module -> [String] -> GHCi ()
2099 breakByModule mod (arg1:rest)
2100 | all isDigit arg1 = do -- looks like a line number
2101 breakByModuleLine mod (read arg1) rest
2105 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2106 breakByModuleLine mod line args
2107 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2108 | [col] <- args, all isDigit col =
2109 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2110 | otherwise = breakSyntax
2113 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2115 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2116 findBreakAndSet mod lookupTickTree = do
2117 tickArray <- getTickArray mod
2118 (breakArray, _) <- getModBreak mod
2119 case lookupTickTree tickArray of
2120 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2121 Just (tick, span) -> do
2122 success <- io $ setBreakFlag True breakArray tick
2126 recordBreak $ BreakLocation
2133 text "Breakpoint " <> ppr nm <>
2135 then text " was already set at " <> ppr span
2136 else text " activated at " <> ppr span
2138 printForUser $ text "Breakpoint could not be activated at"
2141 -- When a line number is specified, the current policy for choosing
2142 -- the best breakpoint is this:
2143 -- - the leftmost complete subexpression on the specified line, or
2144 -- - the leftmost subexpression starting on the specified line, or
2145 -- - the rightmost subexpression enclosing the specified line
2147 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2148 findBreakByLine line arr
2149 | not (inRange (bounds arr) line) = Nothing
2151 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2152 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2153 listToMaybe (sortBy (rightmost `on` snd) ticks)
2157 starts_here = [ tick | tick@(_,span) <- ticks,
2158 GHC.srcSpanStartLine span == line ]
2160 (complete,incomplete) = partition ends_here starts_here
2161 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2163 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2164 -> Maybe (BreakIndex,SrcSpan)
2165 findBreakByCoord mb_file (line, col) arr
2166 | not (inRange (bounds arr) line) = Nothing
2168 listToMaybe (sortBy (rightmost `on` snd) contains ++
2169 sortBy (leftmost_smallest `on` snd) after_here)
2173 -- the ticks that span this coordinate
2174 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2175 is_correct_file span ]
2177 is_correct_file span
2178 | Just f <- mb_file = GHC.srcSpanFile span == f
2181 after_here = [ tick | tick@(_,span) <- ticks,
2182 GHC.srcSpanStartLine span == line,
2183 GHC.srcSpanStartCol span >= col ]
2185 -- For now, use ANSI bold on terminals that we know support it.
2186 -- Otherwise, we add a line of carets under the active expression instead.
2187 -- In particular, on Windows and when running the testsuite (which sets
2188 -- TERM to vt100 for other reasons) we get carets.
2189 -- We really ought to use a proper termcap/terminfo library.
2191 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2192 where mTerm = System.Environment.getEnv "TERM"
2193 `catchIO` \_ -> return "TERM not set"
2195 start_bold :: String
2196 start_bold = "\ESC[1m"
2198 end_bold = "\ESC[0m"
2200 listCmd :: String -> GHCi ()
2202 mb_span <- getCurrentBreakSpan
2205 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2207 | GHC.isGoodSrcSpan span -> io $ listAround span True
2209 do resumes <- GHC.getResumeContext
2211 [] -> panic "No resumes"
2213 do let traceIt = case GHC.resumeHistory r of
2214 [] -> text "rerunning with :trace,"
2216 doWhat = traceIt <+> text ":back then :list"
2217 printForUser (text "Unable to list source for" <+>
2219 $$ text "Try" <+> doWhat)
2220 listCmd str = list2 (words str)
2222 list2 :: [String] -> GHCi ()
2223 list2 [arg] | all isDigit arg = do
2224 (toplevel, _) <- GHC.getContext
2226 [] -> io $ putStrLn "No module to list"
2227 (mod : _) -> listModuleLine mod (read arg)
2228 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2229 mod <- wantInterpretedModule arg1
2230 listModuleLine mod (read arg2)
2232 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2233 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2234 if GHC.isGoodSrcLoc loc
2236 tickArray <- ASSERT( isExternalName name )
2237 getTickArray (GHC.nameModule name)
2238 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2239 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2242 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2243 Just (_,span) -> io $ listAround span False
2245 noCanDo name $ text "can't find its location: " <>
2248 noCanDo n why = printForUser $
2249 text "cannot list source code for " <> ppr n <> text ": " <> why
2251 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2253 listModuleLine :: Module -> Int -> GHCi ()
2254 listModuleLine modl line = do
2255 graph <- GHC.getModuleGraph
2256 let this = filter ((== modl) . GHC.ms_mod) graph
2258 [] -> panic "listModuleLine"
2260 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2261 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2262 io $ listAround (GHC.srcLocSpan loc) False
2264 -- | list a section of a source file around a particular SrcSpan.
2265 -- If the highlight flag is True, also highlight the span using
2266 -- start_bold\/end_bold.
2267 listAround :: SrcSpan -> Bool -> IO ()
2268 listAround span do_highlight = do
2269 contents <- BS.readFile (unpackFS file)
2271 lines = BS.split '\n' contents
2272 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2273 drop (line1 - 1 - pad_before) $ lines
2274 fst_line = max 1 (line1 - pad_before)
2275 line_nos = [ fst_line .. ]
2277 highlighted | do_highlight = zipWith highlight line_nos these_lines
2278 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2280 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2281 prefixed = zipWith ($) highlighted bs_line_nos
2283 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2285 file = GHC.srcSpanFile span
2286 line1 = GHC.srcSpanStartLine span
2287 col1 = GHC.srcSpanStartCol span
2288 line2 = GHC.srcSpanEndLine span
2289 col2 = GHC.srcSpanEndCol span
2291 pad_before | line1 == 1 = 0
2295 highlight | do_bold = highlight_bold
2296 | otherwise = highlight_carets
2298 highlight_bold no line prefix
2299 | no == line1 && no == line2
2300 = let (a,r) = BS.splitAt col1 line
2301 (b,c) = BS.splitAt (col2-col1) r
2303 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2305 = let (a,b) = BS.splitAt col1 line in
2306 BS.concat [prefix, a, BS.pack start_bold, b]
2308 = let (a,b) = BS.splitAt col2 line in
2309 BS.concat [prefix, a, BS.pack end_bold, b]
2310 | otherwise = BS.concat [prefix, line]
2312 highlight_carets no line prefix
2313 | no == line1 && no == line2
2314 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2315 BS.replicate (col2-col1) '^']
2317 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2320 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2322 | otherwise = BS.concat [prefix, line]
2324 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2325 nl = BS.singleton '\n'
2327 -- --------------------------------------------------------------------------
2330 getTickArray :: Module -> GHCi TickArray
2331 getTickArray modl = do
2333 let arrmap = tickarrays st
2334 case lookupModuleEnv arrmap modl of
2335 Just arr -> return arr
2337 (_breakArray, ticks) <- getModBreak modl
2338 let arr = mkTickArray (assocs ticks)
2339 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2342 discardTickArrays :: GHCi ()
2343 discardTickArrays = do
2345 setGHCiState st{tickarrays = emptyModuleEnv}
2347 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2349 = accumArray (flip (:)) [] (1, max_line)
2350 [ (line, (nm,span)) | (nm,span) <- ticks,
2351 line <- srcSpanLines span ]
2353 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2354 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2355 GHC.srcSpanEndLine span ]
2357 lookupModule :: String -> GHCi Module
2358 lookupModule modName
2359 = GHC.findModule (GHC.mkModuleName modName) Nothing
2361 -- don't reset the counter back to zero?
2362 discardActiveBreakPoints :: GHCi ()
2363 discardActiveBreakPoints = do
2365 mapM (turnOffBreak.snd) (breaks st)
2366 setGHCiState $ st { breaks = [] }
2368 deleteBreak :: Int -> GHCi ()
2369 deleteBreak identity = do
2371 let oldLocations = breaks st
2372 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2374 then printForUser (text "Breakpoint" <+> ppr identity <+>
2375 text "does not exist")
2377 mapM (turnOffBreak.snd) this
2378 setGHCiState $ st { breaks = rest }
2380 turnOffBreak :: BreakLocation -> GHCi Bool
2381 turnOffBreak loc = do
2382 (arr, _) <- getModBreak (breakModule loc)
2383 io $ setBreakFlag False arr (breakTick loc)
2385 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2386 getModBreak mod = do
2387 Just mod_info <- GHC.getModuleInfo mod
2388 let modBreaks = GHC.modInfoModBreaks mod_info
2389 let array = GHC.modBreaks_flags modBreaks
2390 let ticks = GHC.modBreaks_locs modBreaks
2391 return (array, ticks)
2393 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2394 setBreakFlag toggle array index
2395 | toggle = GHC.setBreakOn array index
2396 | otherwise = GHC.setBreakOff array index