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 [text 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 $ text str <+> dcolon <+> ppr ty
1226 quit :: String -> GHCi Bool
1227 quit _ = return True
1229 shellEscape :: String -> GHCi Bool
1230 shellEscape str = io (system str >> return False)
1232 -----------------------------------------------------------------------------
1233 -- Browsing a module's contents
1235 browseCmd :: Bool -> String -> GHCi ()
1238 ['*':s] | looksLikeModuleName s -> do
1239 m <- wantInterpretedModule s
1240 browseModule bang m False
1241 [s] | looksLikeModuleName s -> do
1243 browseModule bang m True
1245 (as,bs) <- GHC.getContext
1246 -- Guess which module the user wants to browse. Pick
1247 -- modules that are interpreted first. The most
1248 -- recently-added module occurs last, it seems.
1250 (as@(_:_), _) -> browseModule bang (last as) True
1251 ([], bs@(_:_)) -> browseModule bang (last bs) True
1252 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1253 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1255 -- without bang, show items in context of their parents and omit children
1256 -- with bang, show class methods and data constructors separately, and
1257 -- indicate import modules, to aid qualifying unqualified names
1258 -- with sorted, sort items alphabetically
1259 browseModule :: Bool -> Module -> Bool -> GHCi ()
1260 browseModule bang modl exports_only = do
1261 -- :browse! reports qualifiers wrt current context
1262 current_unqual <- GHC.getPrintUnqual
1263 -- Temporarily set the context to the module we're interested in,
1264 -- just so we can get an appropriate PrintUnqualified
1265 (as,bs) <- GHC.getContext
1266 prel_mod <- getPrelude
1267 if exports_only then GHC.setContext [] [prel_mod,modl]
1268 else GHC.setContext [modl] []
1269 target_unqual <- GHC.getPrintUnqual
1270 GHC.setContext as bs
1272 let unqual = if bang then current_unqual else target_unqual
1274 mb_mod_info <- GHC.getModuleInfo modl
1276 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1277 GHC.moduleNameString (GHC.moduleName modl)))
1279 dflags <- getDynFlags
1281 | exports_only = GHC.modInfoExports mod_info
1282 | otherwise = GHC.modInfoTopLevelScope mod_info
1285 -- sort alphabetically name, but putting
1286 -- locally-defined identifiers first.
1287 -- We would like to improve this; see #1799.
1288 sorted_names = loc_sort local ++ occ_sort external
1290 (local,external) = ASSERT( all isExternalName names )
1291 partition ((==modl) . nameModule) names
1292 occ_sort = sortBy (compare `on` nameOccName)
1293 -- try to sort by src location. If the first name in
1294 -- our list has a good source location, then they all should.
1296 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1297 = sortBy (compare `on` nameSrcSpan) names
1301 mb_things <- mapM GHC.lookupName sorted_names
1302 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1304 rdr_env <- GHC.getGRE
1306 let pefas = dopt Opt_PrintExplicitForalls dflags
1307 things | bang = catMaybes mb_things
1308 | otherwise = filtered_things
1309 pretty | bang = pprTyThing
1310 | otherwise = pprTyThingInContext
1312 labels [] = text "-- not currently imported"
1313 labels l = text $ intercalate "\n" $ map qualifier l
1314 qualifier = maybe "-- defined locally"
1315 (("-- imported via "++) . intercalate ", "
1316 . map GHC.moduleNameString)
1317 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1318 modNames = map (importInfo . GHC.getName) things
1320 -- annotate groups of imports with their import modules
1321 -- the default ordering is somewhat arbitrary, so we group
1322 -- by header and sort groups; the names themselves should
1323 -- really come in order of source appearance.. (trac #1799)
1324 annotate mts = concatMap (\(m,ts)->labels m:ts)
1325 $ sortBy cmpQualifiers $ group mts
1326 where cmpQualifiers =
1327 compare `on` (map (fmap (map moduleNameFS)) . fst)
1329 group mts@((m,_):_) = (m,map snd g) : group ng
1330 where (g,ng) = partition ((==m).fst) mts
1332 let prettyThings = map (pretty pefas) things
1333 prettyThings' | bang = annotate $ zip modNames prettyThings
1334 | otherwise = prettyThings
1335 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1336 -- ToDo: modInfoInstances currently throws an exception for
1337 -- package modules. When it works, we can do this:
1338 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1340 -----------------------------------------------------------------------------
1341 -- Setting the module context
1343 setContext :: String -> GHCi ()
1345 | all sensible strs = do
1346 playCtxtCmd True (cmd, as, bs)
1348 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1349 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1351 (cmd, strs, as, bs) =
1353 '+':stuff -> rest AddModules stuff
1354 '-':stuff -> rest RemModules stuff
1355 stuff -> rest SetContext stuff
1357 rest cmd stuff = (cmd, strs, as, bs)
1358 where strs = words stuff
1359 (as,bs) = partitionWith starred strs
1361 sensible ('*':m) = looksLikeModuleName m
1362 sensible m = looksLikeModuleName m
1364 starred ('*':m) = Left m
1367 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1368 playCtxtCmd fail (cmd, as, bs)
1370 (as',bs') <- do_checks fail
1371 (prev_as,prev_bs) <- GHC.getContext
1375 prel_mod <- getPrelude
1376 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1380 let as_to_add = as' \\ (prev_as ++ prev_bs)
1381 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1382 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1384 let new_as = prev_as \\ (as' ++ bs')
1385 new_bs = prev_bs \\ (as' ++ bs')
1386 return (new_as, new_bs)
1387 GHC.setContext new_as new_bs
1390 as' <- mapM wantInterpretedModule as
1391 bs' <- mapM lookupModule bs
1393 do_checks False = do
1394 as' <- mapM (trymaybe . wantInterpretedModule) as
1395 bs' <- mapM (trymaybe . lookupModule) bs
1396 return (catMaybes as', catMaybes bs')
1401 Left _ -> return Nothing
1402 Right a -> return (Just a)
1404 ----------------------------------------------------------------------------
1407 -- set options in the interpreter. Syntax is exactly the same as the
1408 -- ghc command line, except that certain options aren't available (-C,
1411 -- This is pretty fragile: most options won't work as expected. ToDo:
1412 -- figure out which ones & disallow them.
1414 setCmd :: String -> GHCi ()
1416 = do st <- getGHCiState
1417 let opts = options st
1418 io $ putStrLn (showSDoc (
1419 text "options currently set: " <>
1422 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1424 dflags <- getDynFlags
1425 io $ putStrLn (showSDoc (
1426 vcat (text "GHCi-specific dynamic flag settings:"
1427 :map (flagSetting dflags) ghciFlags)
1429 io $ putStrLn (showSDoc (
1430 vcat (text "other dynamic, non-language, flag settings:"
1431 :map (flagSetting dflags) nonLanguageDynFlags)
1433 where flagSetting dflags (str, f, _)
1434 | dopt f dflags = text " " <> text "-f" <> text str
1435 | otherwise = text " " <> text "-fno-" <> text str
1436 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1438 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1440 flags = [Opt_PrintExplicitForalls
1441 ,Opt_PrintBindResult
1442 ,Opt_BreakOnException
1444 ,Opt_PrintEvldWithShow
1447 = case getCmd str of
1448 Right ("args", rest) ->
1450 Left err -> io (hPutStrLn stderr err)
1451 Right args -> setArgs args
1452 Right ("prog", rest) ->
1454 Right [prog] -> setProg prog
1455 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1456 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1457 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1458 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1459 _ -> case toArgs str of
1460 Left err -> io (hPutStrLn stderr err)
1461 Right wds -> setOptions wds
1463 setArgs, setOptions :: [String] -> GHCi ()
1464 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1468 setGHCiState st{ args = args }
1472 setGHCiState st{ progname = prog }
1476 setGHCiState st{ editor = cmd }
1478 setStop str@(c:_) | isDigit c
1479 = do let (nm_str,rest) = break (not.isDigit) str
1482 let old_breaks = breaks st
1483 if all ((/= nm) . fst) old_breaks
1484 then printForUser (text "Breakpoint" <+> ppr nm <+>
1485 text "does not exist")
1487 let new_breaks = map fn old_breaks
1488 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1489 | otherwise = (i,loc)
1490 setGHCiState st{ breaks = new_breaks }
1493 setGHCiState st{ stop = cmd }
1495 setPrompt value = do
1498 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1500 '\"' : _ -> case reads value of
1501 [(value', xs)] | all isSpace xs ->
1502 setGHCiState (st { prompt = value' })
1504 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1505 _ -> setGHCiState (st { prompt = value })
1508 do -- first, deal with the GHCi opts (+s, +t, etc.)
1509 let (plus_opts, minus_opts) = partitionWith isPlus wds
1510 mapM_ setOpt plus_opts
1511 -- then, dynamic flags
1512 newDynFlags minus_opts
1514 newDynFlags :: [String] -> GHCi ()
1515 newDynFlags minus_opts = do
1516 dflags <- getDynFlags
1517 let pkg_flags = packageFlags dflags
1518 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1519 handleFlagWarnings dflags' warns
1521 if (not (null leftovers))
1522 then ghcError $ errorsToGhcException leftovers
1525 new_pkgs <- setDynFlags dflags'
1527 -- if the package flags changed, we should reset the context
1528 -- and link the new packages.
1529 dflags <- getDynFlags
1530 when (packageFlags dflags /= pkg_flags) $ do
1531 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1533 GHC.load LoadAllTargets
1534 io (linkPackages dflags new_pkgs)
1535 -- package flags changed, we can't re-use any of the old context
1536 setContextAfterLoad ([],[]) False []
1540 unsetOptions :: String -> GHCi ()
1542 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1543 let opts = words str
1544 (minus_opts, rest1) = partition isMinus opts
1545 (plus_opts, rest2) = partitionWith isPlus rest1
1547 if (not (null rest2))
1548 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1551 mapM_ unsetOpt plus_opts
1553 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1554 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1556 no_flags <- mapM no_flag minus_opts
1557 newDynFlags no_flags
1559 isMinus :: String -> Bool
1560 isMinus ('-':_) = True
1563 isPlus :: String -> Either String String
1564 isPlus ('+':opt) = Left opt
1565 isPlus other = Right other
1567 setOpt, unsetOpt :: String -> GHCi ()
1570 = case strToGHCiOpt str of
1571 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1572 Just o -> setOption o
1575 = case strToGHCiOpt str of
1576 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1577 Just o -> unsetOption o
1579 strToGHCiOpt :: String -> (Maybe GHCiOption)
1580 strToGHCiOpt "s" = Just ShowTiming
1581 strToGHCiOpt "t" = Just ShowType
1582 strToGHCiOpt "r" = Just RevertCAFs
1583 strToGHCiOpt _ = Nothing
1585 optToStr :: GHCiOption -> String
1586 optToStr ShowTiming = "s"
1587 optToStr ShowType = "t"
1588 optToStr RevertCAFs = "r"
1590 -- ---------------------------------------------------------------------------
1593 showCmd :: String -> GHCi ()
1597 ["args"] -> io $ putStrLn (show (args st))
1598 ["prog"] -> io $ putStrLn (show (progname st))
1599 ["prompt"] -> io $ putStrLn (show (prompt st))
1600 ["editor"] -> io $ putStrLn (show (editor st))
1601 ["stop"] -> io $ putStrLn (show (stop st))
1602 ["modules" ] -> showModules
1603 ["bindings"] -> showBindings
1604 ["linker"] -> io showLinkerState
1605 ["breaks"] -> showBkptTable
1606 ["context"] -> showContext
1607 ["packages"] -> showPackages
1608 ["languages"] -> showLanguages
1609 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1610 " | breaks | context | packages | languages ]"))
1612 showModules :: GHCi ()
1614 loaded_mods <- getLoadedModules
1615 -- we want *loaded* modules only, see #1734
1616 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1617 mapM_ show_one loaded_mods
1619 getLoadedModules :: GHCi [GHC.ModSummary]
1620 getLoadedModules = do
1621 graph <- GHC.getModuleGraph
1622 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1624 showBindings :: GHCi ()
1626 bindings <- GHC.getBindings
1627 docs <- pprTypeAndContents
1628 [ id | AnId id <- sortBy compareTyThings bindings]
1629 printForUserPartWay docs
1631 compareTyThings :: TyThing -> TyThing -> Ordering
1632 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1634 printTyThing :: TyThing -> GHCi ()
1635 printTyThing tyth = do dflags <- getDynFlags
1636 let pefas = dopt Opt_PrintExplicitForalls dflags
1637 printForUser (pprTyThing pefas tyth)
1639 showBkptTable :: GHCi ()
1642 printForUser $ prettyLocations (breaks st)
1644 showContext :: GHCi ()
1646 resumes <- GHC.getResumeContext
1647 printForUser $ vcat (map pp_resume (reverse resumes))
1650 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1651 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1653 showPackages :: GHCi ()
1655 pkg_flags <- fmap packageFlags getDynFlags
1656 io $ putStrLn $ showSDoc $ vcat $
1657 text ("active package flags:"++if null pkg_flags then " none" else "")
1658 : map showFlag pkg_flags
1659 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1660 io $ putStrLn $ showSDoc $ vcat $
1661 text "packages currently loaded:"
1662 : map (nest 2 . text . packageIdString)
1663 (sortBy (compare `on` packageIdFS) pkg_ids)
1664 where showFlag (ExposePackage p) = text $ " -package " ++ p
1665 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1666 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1668 showLanguages :: GHCi ()
1670 dflags <- getDynFlags
1671 io $ putStrLn $ showSDoc $ vcat $
1672 text "active language flags:" :
1673 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1675 -- -----------------------------------------------------------------------------
1678 completeNone :: String -> IO [String]
1679 completeNone _w = return []
1681 completeMacro, completeIdentifier, completeModule,
1682 completeHomeModule, completeSetOptions, completeShowOptions,
1683 completeFilename, completeHomeModuleOrFile
1684 :: String -> IO [String]
1687 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1688 completeWord w start end = do
1689 line <- Readline.getLineBuffer
1690 let line_words = words (dropWhile isSpace line)
1692 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1694 | ((':':c) : _) <- line_words -> do
1695 completionVars <- lookupCompletionVars c
1696 case completionVars of
1697 (Nothing,complete) -> wrapCompleter complete w
1698 (Just breakChars,complete)
1699 -> let (n,w') = selectWord
1700 (words' (`elem` breakChars) 0 line)
1701 complete' w = do rets <- complete w
1702 return (map (drop n) rets)
1703 in wrapCompleter complete' w'
1704 | ("import" : _) <- line_words ->
1705 wrapCompleter completeModule w
1707 --printf "complete %s, start = %d, end = %d\n" w start end
1708 wrapCompleter completeIdentifier w
1709 where words' _ _ [] = []
1710 words' isBreak n str = let (w,r) = break isBreak str
1711 (s,r') = span isBreak r
1712 in (n,w):words' isBreak (n+length w+length s) r'
1713 -- In a Haskell expression we want to parse 'a-b' as three words
1714 -- where a compiler flag (e.g. -ddump-simpl) should
1715 -- only be a single word.
1716 selectWord [] = (0,w)
1717 selectWord ((offset,x):xs)
1718 | offset+length x >= start = (start-offset,take (end-offset) x)
1719 | otherwise = selectWord xs
1721 lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars,
1723 lookupCompletionVars c = do
1724 maybe_cmd <- lookupCommand' c
1726 Just (_,_,ws,f) -> return (ws,f)
1727 Nothing -> return (Just filenameWordBreakChars,
1731 completeCmd :: String -> IO [String]
1733 cmds <- readIORef macros_ref
1734 return (filter (w `isPrefixOf`) (map (':':)
1735 (map cmdName (builtin_commands ++ cmds))))
1737 completeMacro w = do
1738 cmds <- readIORef macros_ref
1739 return (filter (w `isPrefixOf`) (map cmdName cmds))
1741 completeIdentifier w = do
1742 rdrs <- withRestoredSession GHC.getRdrNamesInScope
1743 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1745 completeModule w = do
1746 dflags <- withRestoredSession GHC.getSessionDynFlags
1747 let pkg_mods = allExposedModules dflags
1748 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1750 completeHomeModule w = do
1751 g <- withRestoredSession GHC.getModuleGraph
1752 let home_mods = map GHC.ms_mod_name g
1753 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1755 completeSetOptions w = do
1756 return (filter (w `isPrefixOf`) options)
1757 where options = "args":"prog":"prompt":"editor":"stop":flagList
1758 flagList = map head $ group $ sort allFlags
1760 completeShowOptions w = do
1761 return (filter (w `isPrefixOf`) options)
1762 where options = ["args", "prog", "prompt", "editor", "stop",
1763 "modules", "bindings", "linker", "breaks",
1764 "context", "packages", "languages"]
1766 completeFilename w = do
1767 ws <- Readline.filenameCompletionFunction w
1769 -- If we only found one result, and it's a directory,
1770 -- add a trailing slash.
1772 isDir <- expandPathIO file >>= doesDirectoryExist
1773 if isDir && last file /= '/'
1774 then return [file ++ "/"]
1779 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1781 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1782 unionComplete f1 f2 w = do
1787 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1788 wrapCompleter fun w = do
1791 [] -> Readline.setAttemptedCompletionOver True >> return Nothing
1792 [x] -> -- Add a trailing space, unless it already has an appended slash.
1793 let appended = if last x == '/' then x else x ++ " "
1794 in return (Just (appended,[]))
1795 xs -> case getCommonPrefix xs of
1796 "" -> return (Just ("",xs))
1797 pref -> return (Just (pref,xs))
1799 getCommonPrefix :: [String] -> String
1800 getCommonPrefix [] = ""
1801 getCommonPrefix (s:ss) = foldl common s ss
1802 where common _s "" = ""
1804 common (c:cs) (d:ds)
1805 | c == d = c : common cs ds
1808 allExposedModules :: DynFlags -> [ModuleName]
1809 allExposedModules dflags
1810 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1812 pkg_db = pkgIdMap (pkgState dflags)
1814 completeMacro = completeNone
1815 completeIdentifier = completeNone
1816 completeModule = completeNone
1817 completeHomeModule = completeNone
1818 completeSetOptions = completeNone
1819 completeShowOptions = completeNone
1820 completeFilename = completeNone
1821 completeHomeModuleOrFile=completeNone
1824 -- ---------------------------------------------------------------------------
1825 -- User code exception handling
1827 -- This is the exception handler for exceptions generated by the
1828 -- user's code and exceptions coming from children sessions;
1829 -- it normally just prints out the exception. The
1830 -- handler must be recursive, in case showing the exception causes
1831 -- more exceptions to be raised.
1833 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1834 -- raising another exception. We therefore don't put the recursive
1835 -- handler arond the flushing operation, so if stderr is closed
1836 -- GHCi will just die gracefully rather than going into an infinite loop.
1837 handler :: SomeException -> GHCi Bool
1839 handler exception = do
1841 io installSignalHandlers
1842 ghciHandle handler (showException exception >> return False)
1844 showException :: SomeException -> GHCi ()
1846 io $ case fromException se of
1847 Just Interrupted -> putStrLn "Interrupted."
1848 -- omit the location for CmdLineError:
1849 Just (CmdLineError s) -> putStrLn s
1851 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1852 Just other_ghc_ex -> print other_ghc_ex
1853 Nothing -> putStrLn ("*** Exception: " ++ show se)
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 ->
1865 (\e -> unGHCi (ghciUnblock (h e)) s)
1867 ghciUnblock :: GHCi a -> GHCi a
1868 ghciUnblock (GHCi a) =
1869 GHCi $ \s -> reifyGhc $ \gs ->
1870 Exception.unblock (reflectGhc (a s) gs)
1872 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1873 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1875 -- ----------------------------------------------------------------------------
1878 expandPath :: String -> GHCi String
1879 expandPath path = io (expandPathIO path)
1881 expandPathIO :: String -> IO String
1883 case dropWhile isSpace path of
1885 tilde <- getHomeDirectory -- will fail if HOME not defined
1886 return (tilde ++ '/':d)
1890 wantInterpretedModule :: String -> GHCi Module
1891 wantInterpretedModule str = do
1892 modl <- lookupModule str
1893 dflags <- getDynFlags
1894 when (GHC.modulePackageId modl /= thisPackage dflags) $
1895 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1896 is_interpreted <- GHC.moduleIsInterpreted modl
1897 when (not is_interpreted) $
1898 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1901 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1902 -> (Name -> GHCi ())
1904 wantNameFromInterpretedModule noCanDo str and_then =
1905 handleSourceError (GHC.printExceptionAndWarnings) $ do
1906 names <- GHC.parseName str
1910 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1911 if not (GHC.isExternalName n)
1912 then noCanDo n $ ppr n <>
1913 text " is not defined in an interpreted module"
1915 is_interpreted <- GHC.moduleIsInterpreted modl
1916 if not is_interpreted
1917 then noCanDo n $ text "module " <> ppr modl <>
1918 text " is not interpreted"
1921 -- -----------------------------------------------------------------------------
1922 -- commands for debugger
1924 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1925 sprintCmd = pprintCommand False False
1926 printCmd = pprintCommand True False
1927 forceCmd = pprintCommand False True
1929 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1930 pprintCommand bind force str = do
1931 pprintClosureCommand bind force str
1933 stepCmd :: String -> GHCi ()
1934 stepCmd [] = doContinue (const True) GHC.SingleStep
1935 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1937 stepLocalCmd :: String -> GHCi ()
1938 stepLocalCmd [] = do
1939 mb_span <- getCurrentBreakSpan
1941 Nothing -> stepCmd []
1943 Just mod <- getCurrentBreakModule
1944 current_toplevel_decl <- enclosingTickSpan mod loc
1945 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1947 stepLocalCmd expression = stepCmd expression
1949 stepModuleCmd :: String -> GHCi ()
1950 stepModuleCmd [] = do
1951 mb_span <- getCurrentBreakSpan
1953 Nothing -> stepCmd []
1955 Just span <- getCurrentBreakSpan
1956 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1957 doContinue f GHC.SingleStep
1959 stepModuleCmd expression = stepCmd expression
1961 -- | Returns the span of the largest tick containing the srcspan given
1962 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1963 enclosingTickSpan mod src = do
1964 ticks <- getTickArray mod
1965 let line = srcSpanStartLine src
1966 ASSERT (inRange (bounds ticks) line) do
1967 let enclosing_spans = [ span | (_,span) <- ticks ! line
1968 , srcSpanEnd span >= srcSpanEnd src]
1969 return . head . sortBy leftmost_largest $ enclosing_spans
1971 traceCmd :: String -> GHCi ()
1972 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1973 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1975 continueCmd :: String -> GHCi ()
1976 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1978 -- doContinue :: SingleStep -> GHCi ()
1979 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1980 doContinue pred step = do
1981 runResult <- resume pred step
1982 afterRunStmt pred runResult
1985 abandonCmd :: String -> GHCi ()
1986 abandonCmd = noArgs $ do
1987 b <- GHC.abandon -- the prompt will change to indicate the new context
1988 when (not b) $ io $ putStrLn "There is no computation running."
1991 deleteCmd :: String -> GHCi ()
1992 deleteCmd argLine = do
1993 deleteSwitch $ words argLine
1995 deleteSwitch :: [String] -> GHCi ()
1997 io $ putStrLn "The delete command requires at least one argument."
1998 -- delete all break points
1999 deleteSwitch ("*":_rest) = discardActiveBreakPoints
2000 deleteSwitch idents = do
2001 mapM_ deleteOneBreak idents
2003 deleteOneBreak :: String -> GHCi ()
2005 | all isDigit str = deleteBreak (read str)
2006 | otherwise = return ()
2008 historyCmd :: String -> GHCi ()
2010 | null arg = history 20
2011 | all isDigit arg = history (read arg)
2012 | otherwise = io $ putStrLn "Syntax: :history [num]"
2015 resumes <- GHC.getResumeContext
2017 [] -> io $ putStrLn "Not stopped at a breakpoint"
2019 let hist = GHC.resumeHistory r
2020 (took,rest) = splitAt num hist
2022 [] -> io $ putStrLn $
2023 "Empty history. Perhaps you forgot to use :trace?"
2025 spans <- mapM GHC.getHistorySpan took
2026 let nums = map (printf "-%-3d:") [(1::Int)..]
2027 names = map GHC.historyEnclosingDecl took
2028 printForUser (vcat(zipWith3
2029 (\x y z -> x <+> y <+> z)
2031 (map (bold . ppr) names)
2032 (map (parens . ppr) spans)))
2033 io $ putStrLn $ if null rest then "<end of history>" else "..."
2035 bold :: SDoc -> SDoc
2036 bold c | do_bold = text start_bold <> c <> text end_bold
2039 backCmd :: String -> GHCi ()
2040 backCmd = noArgs $ do
2041 (names, _, span) <- GHC.back
2042 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
2043 printTypeOfNames names
2044 -- run the command set with ":set stop <cmd>"
2046 enqueueCommands [stop st]
2048 forwardCmd :: String -> GHCi ()
2049 forwardCmd = noArgs $ do
2050 (names, ix, span) <- GHC.forward
2051 printForUser $ (if (ix == 0)
2052 then ptext (sLit "Stopped at")
2053 else ptext (sLit "Logged breakpoint at")) <+> ppr span
2054 printTypeOfNames names
2055 -- run the command set with ":set stop <cmd>"
2057 enqueueCommands [stop st]
2059 -- handle the "break" command
2060 breakCmd :: String -> GHCi ()
2061 breakCmd argLine = do
2062 breakSwitch $ words argLine
2064 breakSwitch :: [String] -> GHCi ()
2066 io $ putStrLn "The break command requires at least one argument."
2067 breakSwitch (arg1:rest)
2068 | looksLikeModuleName arg1 && not (null rest) = do
2069 mod <- wantInterpretedModule arg1
2070 breakByModule mod rest
2071 | all isDigit arg1 = do
2072 (toplevel, _) <- GHC.getContext
2074 (mod : _) -> breakByModuleLine mod (read arg1) rest
2076 io $ putStrLn "Cannot find default module for breakpoint."
2077 io $ putStrLn "Perhaps no modules are loaded for debugging?"
2078 | otherwise = do -- try parsing it as an identifier
2079 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2080 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2081 if GHC.isGoodSrcLoc loc
2082 then ASSERT( isExternalName name )
2083 findBreakAndSet (GHC.nameModule name) $
2084 findBreakByCoord (Just (GHC.srcLocFile loc))
2085 (GHC.srcLocLine loc,
2087 else noCanDo name $ text "can't find its location: " <> ppr loc
2089 noCanDo n why = printForUser $
2090 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2092 breakByModule :: Module -> [String] -> GHCi ()
2093 breakByModule mod (arg1:rest)
2094 | all isDigit arg1 = do -- looks like a line number
2095 breakByModuleLine mod (read arg1) rest
2099 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2100 breakByModuleLine mod line args
2101 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2102 | [col] <- args, all isDigit col =
2103 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2104 | otherwise = breakSyntax
2107 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2109 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2110 findBreakAndSet mod lookupTickTree = do
2111 tickArray <- getTickArray mod
2112 (breakArray, _) <- getModBreak mod
2113 case lookupTickTree tickArray of
2114 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2115 Just (tick, span) -> do
2116 success <- io $ setBreakFlag True breakArray tick
2120 recordBreak $ BreakLocation
2127 text "Breakpoint " <> ppr nm <>
2129 then text " was already set at " <> ppr span
2130 else text " activated at " <> ppr span
2132 printForUser $ text "Breakpoint could not be activated at"
2135 -- When a line number is specified, the current policy for choosing
2136 -- the best breakpoint is this:
2137 -- - the leftmost complete subexpression on the specified line, or
2138 -- - the leftmost subexpression starting on the specified line, or
2139 -- - the rightmost subexpression enclosing the specified line
2141 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2142 findBreakByLine line arr
2143 | not (inRange (bounds arr) line) = Nothing
2145 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2146 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2147 listToMaybe (sortBy (rightmost `on` snd) ticks)
2151 starts_here = [ tick | tick@(_,span) <- ticks,
2152 GHC.srcSpanStartLine span == line ]
2154 (complete,incomplete) = partition ends_here starts_here
2155 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2157 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2158 -> Maybe (BreakIndex,SrcSpan)
2159 findBreakByCoord mb_file (line, col) arr
2160 | not (inRange (bounds arr) line) = Nothing
2162 listToMaybe (sortBy (rightmost `on` snd) contains ++
2163 sortBy (leftmost_smallest `on` snd) after_here)
2167 -- the ticks that span this coordinate
2168 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2169 is_correct_file span ]
2171 is_correct_file span
2172 | Just f <- mb_file = GHC.srcSpanFile span == f
2175 after_here = [ tick | tick@(_,span) <- ticks,
2176 GHC.srcSpanStartLine span == line,
2177 GHC.srcSpanStartCol span >= col ]
2179 -- For now, use ANSI bold on terminals that we know support it.
2180 -- Otherwise, we add a line of carets under the active expression instead.
2181 -- In particular, on Windows and when running the testsuite (which sets
2182 -- TERM to vt100 for other reasons) we get carets.
2183 -- We really ought to use a proper termcap/terminfo library.
2185 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2186 where mTerm = System.Environment.getEnv "TERM"
2187 `catchIO` \_ -> return "TERM not set"
2189 start_bold :: String
2190 start_bold = "\ESC[1m"
2192 end_bold = "\ESC[0m"
2194 listCmd :: String -> GHCi ()
2196 mb_span <- getCurrentBreakSpan
2199 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2201 | GHC.isGoodSrcSpan span -> io $ listAround span True
2203 do resumes <- GHC.getResumeContext
2205 [] -> panic "No resumes"
2207 do let traceIt = case GHC.resumeHistory r of
2208 [] -> text "rerunning with :trace,"
2210 doWhat = traceIt <+> text ":back then :list"
2211 printForUser (text "Unable to list source for" <+>
2213 $$ text "Try" <+> doWhat)
2214 listCmd str = list2 (words str)
2216 list2 :: [String] -> GHCi ()
2217 list2 [arg] | all isDigit arg = do
2218 (toplevel, _) <- GHC.getContext
2220 [] -> io $ putStrLn "No module to list"
2221 (mod : _) -> listModuleLine mod (read arg)
2222 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2223 mod <- wantInterpretedModule arg1
2224 listModuleLine mod (read arg2)
2226 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2227 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2228 if GHC.isGoodSrcLoc loc
2230 tickArray <- ASSERT( isExternalName name )
2231 getTickArray (GHC.nameModule name)
2232 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2233 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2236 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2237 Just (_,span) -> io $ listAround span False
2239 noCanDo name $ text "can't find its location: " <>
2242 noCanDo n why = printForUser $
2243 text "cannot list source code for " <> ppr n <> text ": " <> why
2245 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2247 listModuleLine :: Module -> Int -> GHCi ()
2248 listModuleLine modl line = do
2249 graph <- GHC.getModuleGraph
2250 let this = filter ((== modl) . GHC.ms_mod) graph
2252 [] -> panic "listModuleLine"
2254 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2255 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2256 io $ listAround (GHC.srcLocSpan loc) False
2258 -- | list a section of a source file around a particular SrcSpan.
2259 -- If the highlight flag is True, also highlight the span using
2260 -- start_bold\/end_bold.
2261 listAround :: SrcSpan -> Bool -> IO ()
2262 listAround span do_highlight = do
2263 contents <- BS.readFile (unpackFS file)
2265 lines = BS.split '\n' contents
2266 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2267 drop (line1 - 1 - pad_before) $ lines
2268 fst_line = max 1 (line1 - pad_before)
2269 line_nos = [ fst_line .. ]
2271 highlighted | do_highlight = zipWith highlight line_nos these_lines
2272 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2274 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2275 prefixed = zipWith ($) highlighted bs_line_nos
2277 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2279 file = GHC.srcSpanFile span
2280 line1 = GHC.srcSpanStartLine span
2281 col1 = GHC.srcSpanStartCol span
2282 line2 = GHC.srcSpanEndLine span
2283 col2 = GHC.srcSpanEndCol span
2285 pad_before | line1 == 1 = 0
2289 highlight | do_bold = highlight_bold
2290 | otherwise = highlight_carets
2292 highlight_bold no line prefix
2293 | no == line1 && no == line2
2294 = let (a,r) = BS.splitAt col1 line
2295 (b,c) = BS.splitAt (col2-col1) r
2297 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2299 = let (a,b) = BS.splitAt col1 line in
2300 BS.concat [prefix, a, BS.pack start_bold, b]
2302 = let (a,b) = BS.splitAt col2 line in
2303 BS.concat [prefix, a, BS.pack end_bold, b]
2304 | otherwise = BS.concat [prefix, line]
2306 highlight_carets no line prefix
2307 | no == line1 && no == line2
2308 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2309 BS.replicate (col2-col1) '^']
2311 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2314 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2316 | otherwise = BS.concat [prefix, line]
2318 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2319 nl = BS.singleton '\n'
2321 -- --------------------------------------------------------------------------
2324 getTickArray :: Module -> GHCi TickArray
2325 getTickArray modl = do
2327 let arrmap = tickarrays st
2328 case lookupModuleEnv arrmap modl of
2329 Just arr -> return arr
2331 (_breakArray, ticks) <- getModBreak modl
2332 let arr = mkTickArray (assocs ticks)
2333 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2336 discardTickArrays :: GHCi ()
2337 discardTickArrays = do
2339 setGHCiState st{tickarrays = emptyModuleEnv}
2341 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2343 = accumArray (flip (:)) [] (1, max_line)
2344 [ (line, (nm,span)) | (nm,span) <- ticks,
2345 line <- srcSpanLines span ]
2347 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2348 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2349 GHC.srcSpanEndLine span ]
2351 lookupModule :: String -> GHCi Module
2352 lookupModule modName
2353 = GHC.findModule (GHC.mkModuleName modName) Nothing
2355 -- don't reset the counter back to zero?
2356 discardActiveBreakPoints :: GHCi ()
2357 discardActiveBreakPoints = do
2359 mapM (turnOffBreak.snd) (breaks st)
2360 setGHCiState $ st { breaks = [] }
2362 deleteBreak :: Int -> GHCi ()
2363 deleteBreak identity = do
2365 let oldLocations = breaks st
2366 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2368 then printForUser (text "Breakpoint" <+> ppr identity <+>
2369 text "does not exist")
2371 mapM (turnOffBreak.snd) this
2372 setGHCiState $ st { breaks = rest }
2374 turnOffBreak :: BreakLocation -> GHCi Bool
2375 turnOffBreak loc = do
2376 (arr, _) <- getModBreak (breakModule loc)
2377 io $ setBreakFlag False arr (breakTick loc)
2379 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2380 getModBreak mod = do
2381 Just mod_info <- GHC.getModuleInfo mod
2382 let modBreaks = GHC.modInfoModBreaks mod_info
2383 let array = GHC.modBreaks_flags modBreaks
2384 let ticks = GHC.modBreaks_locs modBreaks
2385 return (array, ticks)
2387 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2388 setBreakFlag toggle array index
2389 | toggle = GHC.setBreakOn array index
2390 | otherwise = GHC.setBreakOff array index