1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS -#include "Linker.h" #-}
5 -----------------------------------------------------------------------------
7 -- GHC Interactive User Interface
9 -- (c) The GHC Team 2005-2006
11 -----------------------------------------------------------------------------
13 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
15 #include "HsVersions.h"
17 import qualified GhciMonad
18 import GhciMonad hiding (runStmt)
23 import qualified GHC hiding (resume, runStmt)
24 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
25 Module, ModuleName, TyThing(..), Phase,
26 BreakIndex, SrcSpan, Resume, SingleStep )
36 import HscTypes ( implicitTyThings )
37 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
38 import Outputable hiding (printForUser, printForUserPartWay)
39 import Module -- for ModuleEnv
43 -- Other random utilities
47 import BasicTypes hiding (isTopLevel)
48 import Panic hiding (showException)
54 import Maybes ( orElse )
58 #ifndef mingw32_HOST_OS
59 import System.Posix hiding (getEnv)
61 import GHC.ConsoleHandler ( flushConsole )
62 import qualified System.Win32
66 import Control.Concurrent ( yield ) -- Used in readline loop
67 import System.Console.Editline.Readline as Readline
73 -- import Control.Concurrent
75 import System.FilePath
76 import qualified Data.ByteString.Char8 as BS
80 import System.Environment
81 import System.Exit ( exitWith, ExitCode(..) )
82 import System.Directory
84 import System.IO.Error as IO
88 import Control.Monad as Monad
92 import GHC.Exts ( unsafeCoerce# )
93 import GHC.IOBase ( IOErrorType(InvalidArgument) )
96 import Data.IORef ( IORef, readIORef, writeIORef )
99 import System.Posix.Internals ( setNonBlockingFD )
102 -----------------------------------------------------------------------------
104 ghciWelcomeMsg :: String
105 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
106 ": http://www.haskell.org/ghc/ :? for help"
108 cmdName :: Command -> String
109 cmdName (n,_,_,_) = n
111 GLOBAL_VAR(macros_ref, [], [Command])
113 builtin_commands :: [Command]
115 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
116 ("?", keepGoing help, Nothing, completeNone),
117 ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename),
118 ("abandon", keepGoing abandonCmd, Nothing, completeNone),
119 ("break", keepGoing breakCmd, Nothing, completeIdentifier),
120 ("back", keepGoing backCmd, Nothing, completeNone),
121 ("browse", keepGoing (browseCmd False), Nothing, completeModule),
122 ("browse!", keepGoing (browseCmd True), Nothing, completeModule),
123 ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename),
124 ("check", keepGoing checkModule, Nothing, completeHomeModule),
125 ("continue", keepGoing continueCmd, Nothing, completeNone),
126 ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier),
127 ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename),
128 ("def", keepGoing (defineMacro False), Nothing, completeIdentifier),
129 ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier),
130 ("delete", keepGoing deleteCmd, Nothing, completeNone),
131 ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
132 ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
133 ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename),
134 ("force", keepGoing forceCmd, Nothing, completeIdentifier),
135 ("forward", keepGoing forwardCmd, Nothing, completeNone),
136 ("help", keepGoing help, Nothing, completeNone),
137 ("history", keepGoing historyCmd, Nothing, completeNone),
138 ("info", keepGoing info, Nothing, completeIdentifier),
139 ("kind", keepGoing kindOfType, Nothing, completeIdentifier),
140 ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile),
141 ("list", keepGoing listCmd, Nothing, completeNone),
142 ("module", keepGoing setContext, Nothing, completeModule),
143 ("main", keepGoing runMain, Nothing, completeIdentifier),
144 ("print", keepGoing printCmd, Nothing, completeIdentifier),
145 ("quit", quit, Nothing, completeNone),
146 ("reload", keepGoing reloadModule, Nothing, completeNone),
147 ("run", keepGoing runRun, Nothing, completeIdentifier),
148 ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions),
149 ("show", keepGoing showCmd, Nothing, completeNone),
150 ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier),
151 ("step", keepGoing stepCmd, Nothing, completeIdentifier),
152 ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier),
153 ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier),
154 ("type", keepGoing typeOfExpr, Nothing, completeIdentifier),
155 ("trace", keepGoing traceCmd, Nothing, completeIdentifier),
156 ("undef", keepGoing undefineMacro, Nothing, completeMacro),
157 ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions)
161 -- We initialize readline (in the interactiveUI function) to use
162 -- word_break_chars as the default set of completion word break characters.
163 -- This can be overridden for a particular command (for example, filename
164 -- expansion shouldn't consider '/' to be a word break) by setting the third
165 -- entry in the Command tuple above.
167 -- NOTE: in order for us to override the default correctly, any custom entry
168 -- must be a SUBSET of word_break_chars.
170 word_break_chars :: String
171 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
172 specials = "(),;[]`{}"
174 in spaces ++ specials ++ symbols
177 flagWordBreakChars, filenameWordBreakChars :: String
178 flagWordBreakChars = " \t\n"
179 filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults
182 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
183 keepGoing a str = a str >> return False
185 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
187 = do case toArgs str of
188 Left err -> io (hPutStrLn stderr err)
192 shortHelpText :: String
193 shortHelpText = "use :? for help.\n"
197 " Commands available from the prompt:\n" ++
199 " <statement> evaluate/run <statement>\n" ++
200 " : repeat last command\n" ++
201 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
202 " :add [*]<module> ... add module(s) to the current target set\n" ++
203 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
204 " (!: more details; *: all top-level names)\n" ++
205 " :cd <dir> change directory to <dir>\n" ++
206 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
207 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
208 " :def <cmd> <expr> define a command :<cmd>\n" ++
209 " :edit <file> edit file\n" ++
210 " :edit edit last module\n" ++
211 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
212 " :help, :? display this list of commands\n" ++
213 " :info [<name> ...] display information about the given names\n" ++
214 " :kind <type> show the kind of <type>\n" ++
215 " :load [*]<module> ... load module(s) and their dependents\n" ++
216 " :main [<arguments> ...] run the main function with the given arguments\n" ++
217 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
218 " :quit exit GHCi\n" ++
219 " :reload reload the current module set\n" ++
220 " :run function [<arguments> ...] run the function with the given arguments\n" ++
221 " :type <expr> show the type of <expr>\n" ++
222 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
223 " :!<command> run the shell command <command>\n" ++
225 " -- Commands for debugging:\n" ++
227 " :abandon at a breakpoint, abandon current computation\n" ++
228 " :back go back in the history (after :trace)\n" ++
229 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
230 " :break <name> set a breakpoint on the specified function\n" ++
231 " :continue resume after a breakpoint\n" ++
232 " :delete <number> delete the specified breakpoint\n" ++
233 " :delete * delete all breakpoints\n" ++
234 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
235 " :forward go forward in the history (after :back)\n" ++
236 " :history [<n>] after :trace, show the execution history\n" ++
237 " :list show the source code around current breakpoint\n" ++
238 " :list identifier show the source code for <identifier>\n" ++
239 " :list [<module>] <line> show the source code around line number <line>\n" ++
240 " :print [<name> ...] prints a value without forcing its computation\n" ++
241 " :sprint [<name> ...] simplifed version of :print\n" ++
242 " :step single-step after stopping at a breakpoint\n"++
243 " :step <expr> single-step into <expr>\n"++
244 " :steplocal single-step within the current top-level binding\n"++
245 " :stepmodule single-step restricted to the current module\n"++
246 " :trace trace after stopping at a breakpoint\n"++
247 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
250 " -- Commands for changing settings:\n" ++
252 " :set <option> ... set options\n" ++
253 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
254 " :set prog <progname> set the value returned by System.getProgName\n" ++
255 " :set prompt <prompt> set the prompt used in GHCi\n" ++
256 " :set editor <cmd> set the command used for :edit\n" ++
257 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
258 " :unset <option> ... unset options\n" ++
260 " Options for ':set' and ':unset':\n" ++
262 " +r revert top-level expressions after each evaluation\n" ++
263 " +s print timing/memory stats after each evaluation\n" ++
264 " +t print type after evaluation\n" ++
265 " -<flags> most GHC command line flags can also be set here\n" ++
266 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
267 " for GHCi-specific flags, see User's Guide,\n"++
268 " Flag reference, Interactive-mode options\n" ++
270 " -- Commands for displaying information:\n" ++
272 " :show bindings show the current bindings made at the prompt\n" ++
273 " :show breaks show the active breakpoints\n" ++
274 " :show context show the breakpoint context\n" ++
275 " :show modules show the currently loaded modules\n" ++
276 " :show packages show the currently active package flags\n" ++
277 " :show languages show the currently active language flags\n" ++
278 " :show <setting> show value of <setting>, which is one of\n" ++
279 " [args, prog, prompt, editor, stop]\n" ++
282 findEditor :: IO String
287 win <- System.Win32.getWindowsDirectory
288 return (win </> "notepad.exe")
293 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String]
295 interactiveUI session srcs maybe_exprs = do
296 -- HACK! If we happen to get into an infinite loop (eg the user
297 -- types 'let x=x in x' at the prompt), then the thread will block
298 -- on a blackhole, and become unreachable during GC. The GC will
299 -- detect that it is unreachable and send it the NonTermination
300 -- exception. However, since the thread is unreachable, everything
301 -- it refers to might be finalized, including the standard Handles.
302 -- This sounds like a bug, but we don't have a good solution right
308 -- Initialise buffering for the *interpreted* I/O system
309 initInterpBuffering session
311 when (isNothing maybe_exprs) $ do
312 -- Only for GHCi (not runghc and ghc -e):
314 -- Turn buffering off for the compiled program's stdout/stderr
316 -- Turn buffering off for GHCi's stdout
318 hSetBuffering stdout NoBuffering
319 -- We don't want the cmd line to buffer any input that might be
320 -- intended for the program, so unbuffer stdin.
321 hSetBuffering stdin NoBuffering
324 is_tty <- hIsTerminalDevice stdin
325 when is_tty $ withReadline $ do
329 (\dir -> Readline.readHistory (dir </> "ghci_history"))
332 Readline.setAttemptedCompletionFunction (Just completeWord)
333 --Readline.parseAndBind "set show-all-if-ambiguous 1"
335 Readline.setBasicWordBreakCharacters word_break_chars
336 Readline.setCompleterWordBreakCharacters word_break_chars
337 Readline.setCompletionAppendCharacter Nothing
340 -- initial context is just the Prelude
341 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") Nothing
342 GHC.setContext session [] [prel_mod]
344 default_editor <- findEditor
346 cwd <- getCurrentDirectory
348 startGHCi (runGHCi srcs maybe_exprs)
349 GHCiState{ progname = "<interactive>",
353 editor = default_editor,
359 tickarrays = emptyModuleEnv,
360 last_command = Nothing,
364 ghc_e = isJust maybe_exprs
368 Readline.stifleHistory 100
369 withGhcAppData (\dir -> Readline.writeHistory (dir </> "ghci_history"))
371 Readline.resetTerminal Nothing
376 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
377 withGhcAppData right left = do
378 either_dir <- IO.try (getAppUserDataDirectory "ghc")
380 Right dir -> right dir
384 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
385 runGHCi paths maybe_exprs = do
387 read_dot_files = not opt_IgnoreDotGhci
389 current_dir = return (Just ".ghci")
391 app_user_dir = io $ withGhcAppData
392 (\dir -> return (Just (dir </> "ghci.conf")))
396 either_dir <- io $ IO.try (getEnv "HOME")
398 Right home -> return (Just (home </> ".ghci"))
401 sourceConfigFile :: FilePath -> GHCi ()
402 sourceConfigFile file = do
403 exists <- io $ doesFileExist file
405 dir_ok <- io $ checkPerms (getDirectory file)
406 file_ok <- io $ checkPerms file
407 when (dir_ok && file_ok) $ do
408 either_hdl <- io $ IO.try (openFile file ReadMode)
411 Right hdl -> runCommands (fileLoop hdl False False)
413 getDirectory f = case takeDirectory f of "" -> "."; d -> d
415 when (read_dot_files) $ do
416 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
417 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
418 mapM_ sourceConfigFile (nub cfgs)
419 -- nub, because we don't want to read .ghci twice if the
422 -- Perform a :load for files given on the GHCi command line
423 -- When in -e mode, if the load fails then we want to stop
424 -- immediately rather than going on to evaluate the expression.
425 when (not (null paths)) $ do
426 ok <- ghciHandle (\e -> do showException e; return Failed) $
428 when (isJust maybe_exprs && failed ok) $
429 io (exitWith (ExitFailure 1))
431 -- if verbosity is greater than 0, or we are connected to a
432 -- terminal, display the prompt in the interactive loop.
433 is_tty <- io (hIsTerminalDevice stdin)
434 dflags <- getDynFlags
435 let show_prompt = verbosity dflags > 0 || is_tty
440 #if defined(mingw32_HOST_OS)
441 -- The win32 Console API mutates the first character of
442 -- type-ahead when reading from it in a non-buffered manner. Work
443 -- around this by flushing the input buffer of type-ahead characters,
444 -- but only if stdin is available.
445 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
447 Left err | isDoesNotExistError err -> return ()
448 | otherwise -> io (ioError err)
449 Right () -> return ()
451 -- enter the interactive loop
452 interactiveLoop is_tty show_prompt
454 -- just evaluate the expression we were given
455 enqueueCommands exprs
456 let handle e = do st <- getGHCiState
457 -- Jump through some hoops to get the
458 -- current progname in the exception text:
459 -- <progname>: <exception>
460 io $ withProgName (progname st)
461 -- this used to be topHandlerFastExit, see #2228
463 runCommands' handle (return Nothing)
466 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
468 interactiveLoop :: Bool -> Bool -> GHCi ()
469 interactiveLoop is_tty show_prompt =
470 -- Ignore ^C exceptions caught here
471 ghciHandleGhcException (\e -> case e of
473 #if defined(mingw32_HOST_OS)
476 interactiveLoop is_tty show_prompt
477 _other -> return ()) $
479 ghciUnblock $ do -- unblock necessary if we recursed from the
480 -- exception handler above.
482 -- read commands from stdin
485 then runCommands readlineLoop
486 else runCommands (fileLoop stdin show_prompt is_tty)
488 runCommands (fileLoop stdin show_prompt is_tty)
492 -- NOTE: We only read .ghci files if they are owned by the current user,
493 -- and aren't world writable. Otherwise, we could be accidentally
494 -- running code planted by a malicious third party.
496 -- Furthermore, We only read ./.ghci if . is owned by the current user
497 -- and isn't writable by anyone else. I think this is sufficient: we
498 -- don't need to check .. and ../.. etc. because "." always refers to
499 -- the same directory while a process is running.
501 checkPerms :: String -> IO Bool
502 #ifdef mingw32_HOST_OS
507 handleIO (\_ -> return False) $ do
508 st <- getFileStatus name
510 if fileOwner st /= me then do
511 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
514 let mode = fileMode st
515 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
516 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
518 putStrLn $ "*** WARNING: " ++ name ++
519 " is writable by someone else, IGNORING!"
524 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
525 fileLoop hdl show_prompt is_tty = do
526 when show_prompt $ do
529 l <- io (IO.try (hGetLine hdl))
531 Left e | isEOFError e -> return Nothing
532 | InvalidArgument <- etype -> return Nothing
533 | otherwise -> io (ioError e)
534 where etype = ioeGetErrorType e
535 -- treat InvalidArgument in the same way as EOF:
536 -- this can happen if the user closed stdin, or
537 -- perhaps did getContents which closes stdin at
540 str <- io $ consoleInputToUnicode is_tty l
543 #ifdef mingw32_HOST_OS
544 -- Convert the console input into Unicode according to the current code page.
545 -- The Windows console stores Unicode characters directly, so this is a
546 -- rather roundabout way of doing things... oh well.
547 -- See #782, #1483, #1649
548 consoleInputToUnicode :: Bool -> String -> IO String
549 consoleInputToUnicode is_tty str
551 cp <- System.Win32.getConsoleCP
552 System.Win32.stringToUnicode cp str
554 decodeStringAsUTF8 str
556 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
558 consoleInputToUnicode :: Bool -> String -> IO String
559 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
562 decodeStringAsUTF8 :: String -> IO String
563 decodeStringAsUTF8 str =
564 withCStringLen str $ \(cstr,len) ->
565 utf8DecodeString (castPtr cstr :: Ptr Word8) len
567 mkPrompt :: GHCi String
569 session <- getSession
570 (toplevs,exports) <- io (GHC.getContext session)
571 resumes <- io $ GHC.getResumeContext session
572 -- st <- getGHCiState
578 let ix = GHC.resumeHistoryIx r
580 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
582 let hist = GHC.resumeHistory r !! (ix-1)
583 span <- io$ GHC.getHistorySpan session hist
584 return (brackets (ppr (negate ix) <> char ':'
585 <+> ppr span) <> space)
587 dots | _:rs <- resumes, not (null rs) = text "... "
594 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
595 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
596 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
597 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
598 hsep (map (ppr . GHC.moduleName) exports)
600 deflt_prompt = dots <> context_bit <> modules_bit
602 f ('%':'s':xs) = deflt_prompt <> f xs
603 f ('%':'%':xs) = char '%' <> f xs
604 f (x:xs) = char x <> f xs
608 return (showSDoc (f (prompt st)))
612 readlineLoop :: GHCi (Maybe String)
615 saveSession -- for use by completion
617 l <- io $ withReadline (readline prompt)
620 Nothing -> return Nothing
621 Just "" -> return (Just "") -- Don't put empty lines in the history
624 str <- io $ consoleInputToUnicode True l
627 withReadline :: IO a -> IO a
628 withReadline = bracket_ stopTimer (do startTimer; setNonBlockingFD 0)
629 -- Two problems are being worked around here:
630 -- 1. readline sometimes puts stdin into blocking mode,
631 -- so we need to put it back for the IO library
632 -- 2. editline doesn't handle some of its system calls returning
633 -- EINTR, so our timer signal confuses it, hence we turn off
634 -- the timer signal when making calls to editline. (#2277)
635 -- If editline is ever fixed, we can remove this.
637 -- These come from the RTS
638 foreign import ccall unsafe startTimer :: IO ()
639 foreign import ccall unsafe stopTimer :: IO ()
642 queryQueue :: GHCi (Maybe String)
647 c:cs -> do setGHCiState st{ cmdqueue = cs }
650 runCommands :: GHCi (Maybe String) -> GHCi ()
651 runCommands = runCommands' handler
653 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
654 -> GHCi (Maybe String) -> GHCi ()
655 runCommands' eh getCmd = do
656 mb_cmd <- noSpace queryQueue
657 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
661 b <- ghciHandle eh (doCommand c)
662 if b then return () else runCommands' eh getCmd
664 noSpace q = q >>= maybe (return Nothing)
665 (\c->case removeSpaces c of
667 ":{" -> multiLineCmd q
668 c -> return (Just c) )
672 setGHCiState st{ prompt = "%s| " }
673 mb_cmd <- collectCommand q ""
674 getGHCiState >>= \st->setGHCiState st{ prompt = p }
676 -- we can't use removeSpaces for the sublines here, so
677 -- multiline commands are somewhat more brittle against
678 -- fileformat errors (such as \r in dos input on unix),
679 -- we get rid of any extra spaces for the ":}" test;
680 -- we also avoid silent failure if ":}" is not found;
681 -- and since there is no (?) valid occurrence of \r (as
682 -- opposed to its String representation, "\r") inside a
683 -- ghci command, we replace any such with ' ' (argh:-(
684 collectCommand q c = q >>=
685 maybe (io (ioError collectError))
686 (\l->if removeSpaces l == ":}"
687 then return (Just $ removeSpaces c)
688 else collectCommand q (c++map normSpace l))
689 where normSpace '\r' = ' '
691 -- QUESTION: is userError the one to use here?
692 collectError = userError "unterminated multiline command :{ .. :}"
693 doCommand (':' : cmd) = specialCommand cmd
694 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
697 enqueueCommands :: [String] -> GHCi ()
698 enqueueCommands cmds = do
700 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
703 runStmt :: String -> SingleStep -> GHCi Bool
705 | null (filter (not.isSpace) stmt) = return False
706 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
708 = do result <- GhciMonad.runStmt stmt step
709 afterRunStmt (const True) result
711 --afterRunStmt :: GHC.RunResult -> GHCi Bool
712 -- False <=> the statement failed to compile
713 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
714 afterRunStmt _ (GHC.RunException e) = throw e
715 afterRunStmt step_here run_result = do
716 session <- getSession
717 resumes <- io $ GHC.getResumeContext session
719 GHC.RunOk names -> do
720 show_types <- isOptionSet ShowType
721 when show_types $ printTypeOfNames session names
722 GHC.RunBreak _ names mb_info
723 | isNothing mb_info ||
724 step_here (GHC.resumeSpan $ head resumes) -> do
725 printForUser $ ptext (sLit "Stopped at") <+>
726 ppr (GHC.resumeSpan $ head resumes)
727 -- printTypeOfNames session names
728 let namesSorted = sortBy compareNames names
729 tythings <- catMaybes `liftM`
730 io (mapM (GHC.lookupName session) namesSorted)
731 docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
732 printForUserPartWay docs
733 maybe (return ()) runBreakCmd mb_info
734 -- run the command set with ":set stop <cmd>"
736 enqueueCommands [stop st]
738 | otherwise -> resume GHC.SingleStep >>=
739 afterRunStmt step_here >> return ()
743 io installSignalHandlers
744 b <- isOptionSet RevertCAFs
747 return (case run_result of GHC.RunOk _ -> True; _ -> False)
749 runBreakCmd :: GHC.BreakInfo -> GHCi ()
750 runBreakCmd info = do
751 let mod = GHC.breakInfo_module info
752 nm = GHC.breakInfo_number info
754 case [ loc | (_,loc) <- breaks st,
755 breakModule loc == mod, breakTick loc == nm ] of
757 loc:_ | null cmd -> return ()
758 | otherwise -> do enqueueCommands [cmd]; return ()
759 where cmd = onBreakCmd loc
761 printTypeOfNames :: Session -> [Name] -> GHCi ()
762 printTypeOfNames session names
763 = mapM_ (printTypeOfName session) $ sortBy compareNames names
765 compareNames :: Name -> Name -> Ordering
766 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
767 where compareWith n = (getOccString n, getSrcSpan n)
769 printTypeOfName :: Session -> Name -> GHCi ()
770 printTypeOfName session n
771 = do maybe_tything <- io (GHC.lookupName session n)
772 case maybe_tything of
774 Just thing -> printTyThing thing
777 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
779 specialCommand :: String -> GHCi Bool
780 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
781 specialCommand str = do
782 let (cmd,rest) = break isSpace str
783 maybe_cmd <- lookupCommand cmd
785 GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
787 do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
791 do io $ hPutStr stdout ("there is no last command to perform\n"
795 lookupCommand :: String -> GHCi (MaybeCommand)
796 lookupCommand "" = do
798 case last_command st of
799 Just c -> return $ GotCommand c
800 Nothing -> return NoLastCommand
801 lookupCommand str = do
802 mc <- io $ lookupCommand' str
804 setGHCiState st{ last_command = mc }
806 Just c -> GotCommand c
807 Nothing -> BadCommand
809 lookupCommand' :: String -> IO (Maybe Command)
810 lookupCommand' str = do
811 macros <- readIORef macros_ref
812 let cmds = builtin_commands ++ macros
813 -- look for exact match first, then the first prefix match
814 return $ case [ c | c <- cmds, str == cmdName c ] of
816 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
820 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
821 getCurrentBreakSpan = do
822 session <- getSession
823 resumes <- io $ GHC.getResumeContext session
827 let ix = GHC.resumeHistoryIx r
829 then return (Just (GHC.resumeSpan r))
831 let hist = GHC.resumeHistory r !! (ix-1)
832 span <- io $ GHC.getHistorySpan session hist
835 getCurrentBreakModule :: GHCi (Maybe Module)
836 getCurrentBreakModule = do
837 session <- getSession
838 resumes <- io $ GHC.getResumeContext session
842 let ix = GHC.resumeHistoryIx r
844 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
846 let hist = GHC.resumeHistory r !! (ix-1)
847 return $ Just $ GHC.getHistoryModule hist
849 -----------------------------------------------------------------------------
852 noArgs :: GHCi () -> String -> GHCi ()
854 noArgs _ _ = io $ putStrLn "This command takes no arguments"
856 help :: String -> GHCi ()
857 help _ = io (putStr helpText)
859 info :: String -> GHCi ()
860 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
861 info s = do { let names = words s
862 ; session <- getSession
863 ; dflags <- getDynFlags
864 ; let pefas = dopt Opt_PrintExplicitForalls dflags
865 ; mapM_ (infoThing pefas session) names }
867 infoThing pefas session str = io $ do
868 names <- GHC.parseName session str
869 mb_stuffs <- mapM (GHC.getInfo session) names
870 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
871 unqual <- GHC.getPrintUnqual session
872 putStrLn (showSDocForUser unqual $
873 vcat (intersperse (text "") $
874 map (pprInfo pefas) filtered))
876 -- Filter out names whose parent is also there Good
877 -- example is '[]', which is both a type and data
878 -- constructor in the same type
879 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
880 filterOutChildren get_thing xs
881 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
883 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
885 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
886 pprInfo pefas (thing, fixity, insts)
887 = pprTyThingInContextLoc pefas thing
888 $$ show_fixity fixity
889 $$ vcat (map GHC.pprInstance insts)
892 | fix == GHC.defaultFixity = empty
893 | otherwise = ppr fix <+> ppr (GHC.getName thing)
895 runMain :: String -> GHCi ()
896 runMain s = case toArgs s of
897 Left err -> io (hPutStrLn stderr err)
899 do dflags <- getDynFlags
900 case mainFunIs dflags of
901 Nothing -> doWithArgs args "main"
902 Just f -> doWithArgs args f
904 runRun :: String -> GHCi ()
905 runRun s = case toCmdArgs s of
906 Left err -> io (hPutStrLn stderr err)
907 Right (cmd, args) -> doWithArgs args cmd
909 doWithArgs :: [String] -> String -> GHCi ()
910 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
911 show args ++ " (" ++ cmd ++ ")"]
913 addModule :: [FilePath] -> GHCi ()
915 revertCAFs -- always revert CAFs on load/add.
916 files <- mapM expandPath files
917 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
918 session <- getSession
919 -- remove old targets with the same id; e.g. for :add *M
920 io $ mapM_ (GHC.removeTarget session) [ tid | Target tid _ _ <- targets ]
921 io $ mapM_ (GHC.addTarget session) targets
922 prev_context <- io $ GHC.getContext session
923 ok <- io $ GHC.load session LoadAllTargets
924 afterLoad ok session False prev_context
926 changeDirectory :: String -> GHCi ()
927 changeDirectory "" = do
928 -- :cd on its own changes to the user's home directory
929 either_dir <- io (IO.try getHomeDirectory)
932 Right dir -> changeDirectory dir
933 changeDirectory dir = do
934 session <- getSession
935 graph <- io (GHC.getModuleGraph session)
936 when (not (null graph)) $
937 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
938 prev_context <- io $ GHC.getContext session
939 io (GHC.setTargets session [])
940 io (GHC.load session LoadAllTargets)
941 setContextAfterLoad session prev_context False []
942 io (GHC.workingDirectoryChanged session)
943 dir <- expandPath dir
944 io (setCurrentDirectory dir)
946 editFile :: String -> GHCi ()
948 do file <- if null str then chooseEditFile else return str
952 $ ghcError (CmdLineError "editor not set, use :set editor")
953 io $ system (cmd ++ ' ':file)
956 -- The user didn't specify a file so we pick one for them.
957 -- Our strategy is to pick the first module that failed to load,
958 -- or otherwise the first target.
960 -- XXX: Can we figure out what happened if the depndecy analysis fails
961 -- (e.g., because the porgrammeer mistyped the name of a module)?
962 -- XXX: Can we figure out the location of an error to pass to the editor?
963 -- XXX: if we could figure out the list of errors that occured during the
964 -- last load/reaload, then we could start the editor focused on the first
966 chooseEditFile :: GHCi String
968 do session <- getSession
969 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
971 graph <- io (GHC.getModuleGraph session)
972 failed_graph <- filterM hasFailed graph
973 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
975 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
978 case pick (order failed_graph) of
979 Just file -> return file
981 do targets <- io (GHC.getTargets session)
982 case msum (map fromTarget targets) of
983 Just file -> return file
984 Nothing -> ghcError (CmdLineError "No files to edit.")
986 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
987 fromTarget _ = Nothing -- when would we get a module target?
989 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
990 defineMacro overwrite s = do
991 let (macro_name, definition) = break isSpace s
992 macros <- io (readIORef macros_ref)
993 let defined = map cmdName macros
996 then io $ putStrLn "no macros defined"
997 else io $ putStr ("the following macros are defined:\n" ++
1000 if (not overwrite && macro_name `elem` defined)
1001 then ghcError (CmdLineError
1002 ("macro '" ++ macro_name ++ "' is already defined"))
1005 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
1007 -- give the expression a type signature, so we can be sure we're getting
1008 -- something of the right type.
1009 let new_expr = '(' : definition ++ ") :: String -> IO String"
1011 -- compile the expression
1013 maybe_hv <- io (GHC.compileExpr cms new_expr)
1015 Nothing -> return ()
1016 Just hv -> io (writeIORef macros_ref --
1017 (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)]))
1019 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
1021 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
1022 enqueueCommands (lines str)
1025 undefineMacro :: String -> GHCi ()
1026 undefineMacro str = mapM_ undef (words str)
1027 where undef macro_name = do
1028 cmds <- io (readIORef macros_ref)
1029 if (macro_name `notElem` map cmdName cmds)
1030 then ghcError (CmdLineError
1031 ("macro '" ++ macro_name ++ "' is not defined"))
1033 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
1035 cmdCmd :: String -> GHCi ()
1037 let expr = '(' : str ++ ") :: IO String"
1038 session <- getSession
1039 maybe_hv <- io (GHC.compileExpr session expr)
1041 Nothing -> return ()
1043 cmds <- io $ (unsafeCoerce# hv :: IO String)
1044 enqueueCommands (lines cmds)
1047 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1048 loadModule fs = timeIt (loadModule' fs)
1050 loadModule_ :: [FilePath] -> GHCi ()
1051 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
1053 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1054 loadModule' files = do
1055 session <- getSession
1056 prev_context <- io $ GHC.getContext session
1059 io $ GHC.abandonAll session
1060 discardActiveBreakPoints
1061 io (GHC.setTargets session [])
1062 io (GHC.load session LoadAllTargets)
1065 let (filenames, phases) = unzip files
1066 exp_filenames <- mapM expandPath filenames
1067 let files' = zip exp_filenames phases
1068 targets <- io (mapM (uncurry GHC.guessTarget) files')
1070 -- NOTE: we used to do the dependency anal first, so that if it
1071 -- fails we didn't throw away the current set of modules. This would
1072 -- require some re-working of the GHC interface, so we'll leave it
1073 -- as a ToDo for now.
1075 io (GHC.setTargets session targets)
1076 doLoad session False prev_context LoadAllTargets
1078 checkModule :: String -> GHCi ()
1080 let modl = GHC.mkModuleName m
1081 session <- getSession
1082 prev_context <- io $ GHC.getContext session
1083 result <- io (GHC.checkModule session modl False)
1085 Nothing -> io $ putStrLn "Nothing"
1086 Just r -> io $ putStrLn (showSDoc (
1087 case GHC.checkedModuleInfo r of
1088 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1090 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1092 (text "global names: " <+> ppr global) $$
1093 (text "local names: " <+> ppr local)
1095 afterLoad (successIf (isJust result)) session False prev_context
1097 reloadModule :: String -> GHCi ()
1099 session <- getSession
1100 prev_context <- io $ GHC.getContext session
1101 doLoad session True prev_context $
1102 if null m then LoadAllTargets
1103 else LoadUpTo (GHC.mkModuleName m)
1106 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1107 doLoad session retain_context prev_context howmuch = do
1108 -- turn off breakpoints before we load: we can't turn them off later, because
1109 -- the ModBreaks will have gone away.
1110 discardActiveBreakPoints
1111 ok <- io (GHC.load session howmuch)
1112 afterLoad ok session retain_context prev_context
1115 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1116 afterLoad ok session retain_context prev_context = do
1117 revertCAFs -- always revert CAFs on load.
1119 loaded_mod_summaries <- getLoadedModules session
1120 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1121 loaded_mod_names = map GHC.moduleName loaded_mods
1122 modulesLoadedMsg ok loaded_mod_names
1124 setContextAfterLoad session prev_context retain_context loaded_mod_summaries
1127 setContextAfterLoad :: Session -> ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1128 setContextAfterLoad session prev keep_ctxt [] = do
1129 prel_mod <- getPrelude
1130 setContextKeepingPackageModules session prev keep_ctxt ([], [prel_mod])
1131 setContextAfterLoad session prev keep_ctxt ms = do
1132 -- load a target if one is available, otherwise load the topmost module.
1133 targets <- io (GHC.getTargets session)
1134 case [ m | Just m <- map (findTarget ms) targets ] of
1136 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1137 load_this (last graph')
1142 = case filter (`matches` t) ms of
1146 summary `matches` Target (TargetModule m) _ _
1147 = GHC.ms_mod_name summary == m
1148 summary `matches` Target (TargetFile f _) _ _
1149 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1153 load_this summary | m <- GHC.ms_mod summary = do
1154 b <- io (GHC.moduleIsInterpreted session m)
1155 if b then setContextKeepingPackageModules session prev keep_ctxt ([m], [])
1157 prel_mod <- getPrelude
1158 setContextKeepingPackageModules session prev keep_ctxt ([],[prel_mod,m])
1160 -- | Keep any package modules (except Prelude) when changing the context.
1161 setContextKeepingPackageModules
1163 -> ([Module],[Module]) -- previous context
1164 -> Bool -- re-execute :module commands
1165 -> ([Module],[Module]) -- new context
1167 setContextKeepingPackageModules session prev_context keep_ctxt (as,bs) = do
1168 let (_,bs0) = prev_context
1169 prel_mod <- getPrelude
1170 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1171 let bs1 = if null as then nub (prel_mod : bs) else bs
1172 io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1176 mapM_ (playCtxtCmd False) (remembered_ctx st)
1179 setGHCiState st{ remembered_ctx = [] }
1181 isHomeModule :: Module -> Bool
1182 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1184 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1185 modulesLoadedMsg ok mods = do
1186 dflags <- getDynFlags
1187 when (verbosity dflags > 0) $ do
1189 | null mods = text "none."
1190 | otherwise = hsep (
1191 punctuate comma (map ppr mods)) <> text "."
1194 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1196 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1199 typeOfExpr :: String -> GHCi ()
1201 = do cms <- getSession
1202 maybe_ty <- io (GHC.exprType cms str)
1204 Nothing -> return ()
1205 Just ty -> do dflags <- getDynFlags
1206 let pefas = dopt Opt_PrintExplicitForalls dflags
1207 printForUser $ text str <+> dcolon
1208 <+> pprTypeForUser pefas ty
1210 kindOfType :: String -> GHCi ()
1212 = do cms <- getSession
1213 maybe_ty <- io (GHC.typeKind cms str)
1215 Nothing -> return ()
1216 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1218 quit :: String -> GHCi Bool
1219 quit _ = return True
1221 shellEscape :: String -> GHCi Bool
1222 shellEscape str = io (system str >> return False)
1224 -----------------------------------------------------------------------------
1225 -- Browsing a module's contents
1227 browseCmd :: Bool -> String -> GHCi ()
1230 ['*':s] | looksLikeModuleName s -> do
1231 m <- wantInterpretedModule s
1232 browseModule bang m False
1233 [s] | looksLikeModuleName s -> do
1235 browseModule bang m True
1238 (as,bs) <- io $ GHC.getContext s
1239 -- Guess which module the user wants to browse. Pick
1240 -- modules that are interpreted first. The most
1241 -- recently-added module occurs last, it seems.
1243 (as@(_:_), _) -> browseModule bang (last as) True
1244 ([], bs@(_:_)) -> browseModule bang (last bs) True
1245 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1246 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1248 -- without bang, show items in context of their parents and omit children
1249 -- with bang, show class methods and data constructors separately, and
1250 -- indicate import modules, to aid qualifying unqualified names
1251 -- with sorted, sort items alphabetically
1252 browseModule :: Bool -> Module -> Bool -> GHCi ()
1253 browseModule bang modl exports_only = do
1255 -- :browse! reports qualifiers wrt current context
1256 current_unqual <- io (GHC.getPrintUnqual s)
1257 -- Temporarily set the context to the module we're interested in,
1258 -- just so we can get an appropriate PrintUnqualified
1259 (as,bs) <- io (GHC.getContext s)
1260 prel_mod <- getPrelude
1261 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1262 else GHC.setContext s [modl] [])
1263 target_unqual <- io (GHC.getPrintUnqual s)
1264 io (GHC.setContext s as bs)
1266 let unqual = if bang then current_unqual else target_unqual
1268 mb_mod_info <- io $ GHC.getModuleInfo s modl
1270 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1271 GHC.moduleNameString (GHC.moduleName modl)))
1273 dflags <- getDynFlags
1275 | exports_only = GHC.modInfoExports mod_info
1276 | otherwise = GHC.modInfoTopLevelScope mod_info
1279 -- sort alphabetically name, but putting
1280 -- locally-defined identifiers first.
1281 -- We would like to improve this; see #1799.
1282 sorted_names = loc_sort local ++ occ_sort external
1284 (local,external) = partition ((==modl) . nameModule) names
1285 occ_sort = sortBy (compare `on` nameOccName)
1286 -- try to sort by src location. If the first name in
1287 -- our list has a good source location, then they all should.
1289 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1290 = sortBy (compare `on` nameSrcSpan) names
1294 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1295 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1297 rdr_env <- io $ GHC.getGRE s
1299 let pefas = dopt Opt_PrintExplicitForalls dflags
1300 things | bang = catMaybes mb_things
1301 | otherwise = filtered_things
1302 pretty | bang = pprTyThing
1303 | otherwise = pprTyThingInContext
1305 labels [] = text "-- not currently imported"
1306 labels l = text $ intercalate "\n" $ map qualifier l
1307 qualifier = maybe "-- defined locally"
1308 (("-- imported via "++) . intercalate ", "
1309 . map GHC.moduleNameString)
1310 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1311 modNames = map (importInfo . GHC.getName) things
1313 -- annotate groups of imports with their import modules
1314 -- the default ordering is somewhat arbitrary, so we group
1315 -- by header and sort groups; the names themselves should
1316 -- really come in order of source appearance.. (trac #1799)
1317 annotate mts = concatMap (\(m,ts)->labels m:ts)
1318 $ sortBy cmpQualifiers $ group mts
1319 where cmpQualifiers =
1320 compare `on` (map (fmap (map moduleNameFS)) . fst)
1322 group mts@((m,_):_) = (m,map snd g) : group ng
1323 where (g,ng) = partition ((==m).fst) mts
1325 let prettyThings = map (pretty pefas) things
1326 prettyThings' | bang = annotate $ zip modNames prettyThings
1327 | otherwise = prettyThings
1328 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1329 -- ToDo: modInfoInstances currently throws an exception for
1330 -- package modules. When it works, we can do this:
1331 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1333 -----------------------------------------------------------------------------
1334 -- Setting the module context
1336 setContext :: String -> GHCi ()
1338 | all sensible strs = do
1339 playCtxtCmd True (cmd, as, bs)
1341 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1342 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1344 (cmd, strs, as, bs) =
1346 '+':stuff -> rest AddModules stuff
1347 '-':stuff -> rest RemModules stuff
1348 stuff -> rest SetContext stuff
1350 rest cmd stuff = (cmd, strs, as, bs)
1351 where strs = words stuff
1352 (as,bs) = partitionWith starred strs
1354 sensible ('*':m) = looksLikeModuleName m
1355 sensible m = looksLikeModuleName m
1357 starred ('*':m) = Left m
1360 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1361 playCtxtCmd fail (cmd, as, bs)
1364 (as',bs') <- do_checks fail
1365 (prev_as,prev_bs) <- io $ GHC.getContext s
1369 prel_mod <- getPrelude
1370 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1374 let as_to_add = as' \\ (prev_as ++ prev_bs)
1375 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1376 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1378 let new_as = prev_as \\ (as' ++ bs')
1379 new_bs = prev_bs \\ (as' ++ bs')
1380 return (new_as, new_bs)
1381 io $ GHC.setContext s new_as new_bs
1384 as' <- mapM wantInterpretedModule as
1385 bs' <- mapM lookupModule bs
1387 do_checks False = do
1388 as' <- mapM (trymaybe . wantInterpretedModule) as
1389 bs' <- mapM (trymaybe . lookupModule) bs
1390 return (catMaybes as', catMaybes bs')
1395 Left _ -> return Nothing
1396 Right a -> return (Just a)
1398 ----------------------------------------------------------------------------
1401 -- set options in the interpreter. Syntax is exactly the same as the
1402 -- ghc command line, except that certain options aren't available (-C,
1405 -- This is pretty fragile: most options won't work as expected. ToDo:
1406 -- figure out which ones & disallow them.
1408 setCmd :: String -> GHCi ()
1410 = do st <- getGHCiState
1411 let opts = options st
1412 io $ putStrLn (showSDoc (
1413 text "options currently set: " <>
1416 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1418 dflags <- getDynFlags
1419 io $ putStrLn (showSDoc (
1420 vcat (text "GHCi-specific dynamic flag settings:"
1421 :map (flagSetting dflags) ghciFlags)
1423 io $ putStrLn (showSDoc (
1424 vcat (text "other dynamic, non-language, flag settings:"
1425 :map (flagSetting dflags) nonLanguageDynFlags)
1427 where flagSetting dflags (str, f, _)
1428 | dopt f dflags = text " " <> text "-f" <> text str
1429 | otherwise = text " " <> text "-fno-" <> text str
1430 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1432 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1434 flags = [Opt_PrintExplicitForalls
1435 ,Opt_PrintBindResult
1436 ,Opt_BreakOnException
1438 ,Opt_PrintEvldWithShow
1441 = case getCmd str of
1442 Right ("args", rest) ->
1444 Left err -> io (hPutStrLn stderr err)
1445 Right args -> setArgs args
1446 Right ("prog", rest) ->
1448 Right [prog] -> setProg prog
1449 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1450 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1451 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1452 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1453 _ -> case toArgs str of
1454 Left err -> io (hPutStrLn stderr err)
1455 Right wds -> setOptions wds
1457 setArgs, setOptions :: [String] -> GHCi ()
1458 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1462 setGHCiState st{ args = args }
1466 setGHCiState st{ progname = prog }
1470 setGHCiState st{ editor = cmd }
1472 setStop str@(c:_) | isDigit c
1473 = do let (nm_str,rest) = break (not.isDigit) str
1476 let old_breaks = breaks st
1477 if all ((/= nm) . fst) old_breaks
1478 then printForUser (text "Breakpoint" <+> ppr nm <+>
1479 text "does not exist")
1481 let new_breaks = map fn old_breaks
1482 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1483 | otherwise = (i,loc)
1484 setGHCiState st{ breaks = new_breaks }
1487 setGHCiState st{ stop = cmd }
1489 setPrompt value = do
1492 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1493 else setGHCiState st{ prompt = remQuotes value }
1495 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1499 do -- first, deal with the GHCi opts (+s, +t, etc.)
1500 let (plus_opts, minus_opts) = partitionWith isPlus wds
1501 mapM_ setOpt plus_opts
1502 -- then, dynamic flags
1503 newDynFlags minus_opts
1505 newDynFlags :: [String] -> GHCi ()
1506 newDynFlags minus_opts = do
1507 dflags <- getDynFlags
1508 let pkg_flags = packageFlags dflags
1509 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1510 io $ handleFlagWarnings dflags' warns
1512 if (not (null leftovers))
1513 then ghcError $ errorsToGhcException leftovers
1516 new_pkgs <- setDynFlags dflags'
1518 -- if the package flags changed, we should reset the context
1519 -- and link the new packages.
1520 dflags <- getDynFlags
1521 when (packageFlags dflags /= pkg_flags) $ do
1522 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1523 session <- getSession
1524 io (GHC.setTargets session [])
1525 io (GHC.load session LoadAllTargets)
1526 io (linkPackages dflags new_pkgs)
1527 -- package flags changed, we can't re-use any of the old context
1528 setContextAfterLoad session ([],[]) False []
1532 unsetOptions :: String -> GHCi ()
1534 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1535 let opts = words str
1536 (minus_opts, rest1) = partition isMinus opts
1537 (plus_opts, rest2) = partitionWith isPlus rest1
1539 if (not (null rest2))
1540 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1543 mapM_ unsetOpt plus_opts
1545 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1546 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1548 no_flags <- mapM no_flag minus_opts
1549 newDynFlags no_flags
1551 isMinus :: String -> Bool
1552 isMinus ('-':_) = True
1555 isPlus :: String -> Either String String
1556 isPlus ('+':opt) = Left opt
1557 isPlus other = Right other
1559 setOpt, unsetOpt :: String -> GHCi ()
1562 = case strToGHCiOpt str of
1563 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1564 Just o -> setOption o
1567 = case strToGHCiOpt str of
1568 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1569 Just o -> unsetOption o
1571 strToGHCiOpt :: String -> (Maybe GHCiOption)
1572 strToGHCiOpt "s" = Just ShowTiming
1573 strToGHCiOpt "t" = Just ShowType
1574 strToGHCiOpt "r" = Just RevertCAFs
1575 strToGHCiOpt _ = Nothing
1577 optToStr :: GHCiOption -> String
1578 optToStr ShowTiming = "s"
1579 optToStr ShowType = "t"
1580 optToStr RevertCAFs = "r"
1582 -- ---------------------------------------------------------------------------
1585 showCmd :: String -> GHCi ()
1589 ["args"] -> io $ putStrLn (show (args st))
1590 ["prog"] -> io $ putStrLn (show (progname st))
1591 ["prompt"] -> io $ putStrLn (show (prompt st))
1592 ["editor"] -> io $ putStrLn (show (editor st))
1593 ["stop"] -> io $ putStrLn (show (stop st))
1594 ["modules" ] -> showModules
1595 ["bindings"] -> showBindings
1596 ["linker"] -> io showLinkerState
1597 ["breaks"] -> showBkptTable
1598 ["context"] -> showContext
1599 ["packages"] -> showPackages
1600 ["languages"] -> showLanguages
1601 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1602 " | breaks | context | packages | languages ]"))
1604 showModules :: GHCi ()
1606 session <- getSession
1607 loaded_mods <- getLoadedModules session
1608 -- we want *loaded* modules only, see #1734
1609 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1610 mapM_ show_one loaded_mods
1612 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1613 getLoadedModules session = do
1614 graph <- io (GHC.getModuleGraph session)
1615 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1617 showBindings :: GHCi ()
1620 bindings <- io (GHC.getBindings s)
1621 docs <- io$ pprTypeAndContents s
1622 [ id | AnId id <- sortBy compareTyThings bindings]
1623 printForUserPartWay docs
1625 compareTyThings :: TyThing -> TyThing -> Ordering
1626 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1628 printTyThing :: TyThing -> GHCi ()
1629 printTyThing tyth = do dflags <- getDynFlags
1630 let pefas = dopt Opt_PrintExplicitForalls dflags
1631 printForUser (pprTyThing pefas tyth)
1633 showBkptTable :: GHCi ()
1636 printForUser $ prettyLocations (breaks st)
1638 showContext :: GHCi ()
1640 session <- getSession
1641 resumes <- io $ GHC.getResumeContext session
1642 printForUser $ vcat (map pp_resume (reverse resumes))
1645 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1646 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1648 showPackages :: GHCi ()
1650 pkg_flags <- fmap packageFlags getDynFlags
1651 io $ putStrLn $ showSDoc $ vcat $
1652 text ("active package flags:"++if null pkg_flags then " none" else "")
1653 : map showFlag pkg_flags
1654 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1655 io $ putStrLn $ showSDoc $ vcat $
1656 text "packages currently loaded:"
1657 : map (nest 2 . text . packageIdString)
1658 (sortBy (compare `on` packageIdFS) pkg_ids)
1659 where showFlag (ExposePackage p) = text $ " -package " ++ p
1660 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1661 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1663 showLanguages :: GHCi ()
1665 dflags <- getDynFlags
1666 io $ putStrLn $ showSDoc $ vcat $
1667 text "active language flags:" :
1668 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1670 -- -----------------------------------------------------------------------------
1673 completeNone :: String -> IO [String]
1674 completeNone _w = return []
1676 completeMacro, completeIdentifier, completeModule,
1677 completeHomeModule, completeSetOptions, completeFilename,
1678 completeHomeModuleOrFile
1679 :: String -> IO [String]
1682 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1683 completeWord w start end = do
1684 line <- Readline.getLineBuffer
1685 let line_words = words (dropWhile isSpace line)
1687 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1689 | ((':':c) : _) <- line_words -> do
1690 completionVars <- lookupCompletionVars c
1691 case completionVars of
1692 (Nothing,complete) -> wrapCompleter complete w
1693 (Just breakChars,complete)
1694 -> let (n,w') = selectWord
1695 (words' (`elem` breakChars) 0 line)
1696 complete' w = do rets <- complete w
1697 return (map (drop n) rets)
1698 in wrapCompleter complete' w'
1699 | ("import" : _) <- line_words ->
1700 wrapCompleter completeModule w
1702 --printf "complete %s, start = %d, end = %d\n" w start end
1703 wrapCompleter completeIdentifier w
1704 where words' _ _ [] = []
1705 words' isBreak n str = let (w,r) = break isBreak str
1706 (s,r') = span isBreak r
1707 in (n,w):words' isBreak (n+length w+length s) r'
1708 -- In a Haskell expression we want to parse 'a-b' as three words
1709 -- where a compiler flag (e.g. -ddump-simpl) should
1710 -- only be a single word.
1711 selectWord [] = (0,w)
1712 selectWord ((offset,x):xs)
1713 | offset+length x >= start = (start-offset,take (end-offset) x)
1714 | otherwise = selectWord xs
1716 lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars,
1718 lookupCompletionVars c = do
1719 maybe_cmd <- lookupCommand' c
1721 Just (_,_,ws,f) -> return (ws,f)
1722 Nothing -> return (Just filenameWordBreakChars,
1726 completeCmd :: String -> IO [String]
1728 cmds <- readIORef macros_ref
1729 return (filter (w `isPrefixOf`) (map (':':)
1730 (map cmdName (builtin_commands ++ cmds))))
1732 completeMacro w = do
1733 cmds <- readIORef macros_ref
1734 return (filter (w `isPrefixOf`) (map cmdName cmds))
1736 completeIdentifier w = do
1738 rdrs <- GHC.getRdrNamesInScope s
1739 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1741 completeModule w = do
1743 dflags <- GHC.getSessionDynFlags s
1744 let pkg_mods = allExposedModules dflags
1745 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1747 completeHomeModule w = do
1749 g <- GHC.getModuleGraph s
1750 let home_mods = map GHC.ms_mod_name g
1751 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1753 completeSetOptions w = do
1754 return (filter (w `isPrefixOf`) options)
1755 where options = "args":"prog":allFlags
1757 completeFilename w = do
1758 ws <- Readline.filenameCompletionFunction w
1760 -- If we only found one result, and it's a directory,
1761 -- add a trailing slash.
1763 isDir <- expandPathIO file >>= doesDirectoryExist
1764 if isDir && last file /= '/'
1765 then return [file ++ "/"]
1770 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1772 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1773 unionComplete f1 f2 w = do
1778 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1779 wrapCompleter fun w = do
1782 [] -> Readline.setAttemptedCompletionOver True >> return Nothing
1783 [x] -> -- Add a trailing space, unless it already has an appended slash.
1784 let appended = if last x == '/' then x else x ++ " "
1785 in return (Just (appended,[]))
1786 xs -> case getCommonPrefix xs of
1787 "" -> return (Just ("",xs))
1788 pref -> return (Just (pref,xs))
1790 getCommonPrefix :: [String] -> String
1791 getCommonPrefix [] = ""
1792 getCommonPrefix (s:ss) = foldl common s ss
1793 where common _s "" = ""
1795 common (c:cs) (d:ds)
1796 | c == d = c : common cs ds
1799 allExposedModules :: DynFlags -> [ModuleName]
1800 allExposedModules dflags
1801 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1803 pkg_db = pkgIdMap (pkgState dflags)
1805 completeMacro = completeNone
1806 completeIdentifier = completeNone
1807 completeModule = completeNone
1808 completeHomeModule = completeNone
1809 completeSetOptions = completeNone
1810 completeFilename = completeNone
1811 completeHomeModuleOrFile=completeNone
1814 -- ---------------------------------------------------------------------------
1815 -- User code exception handling
1817 -- This is the exception handler for exceptions generated by the
1818 -- user's code and exceptions coming from children sessions;
1819 -- it normally just prints out the exception. The
1820 -- handler must be recursive, in case showing the exception causes
1821 -- more exceptions to be raised.
1823 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1824 -- raising another exception. We therefore don't put the recursive
1825 -- handler arond the flushing operation, so if stderr is closed
1826 -- GHCi will just die gracefully rather than going into an infinite loop.
1827 handler :: SomeException -> GHCi Bool
1829 handler exception = do
1831 io installSignalHandlers
1832 ghciHandle handler (showException exception >> return False)
1834 showException :: SomeException -> GHCi ()
1835 #if __GLASGOW_HASKELL__ < 609
1836 showException (DynException dyn) =
1837 case fromDynamic dyn of
1838 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1839 Just Interrupted -> io (putStrLn "Interrupted.")
1840 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1841 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1842 Just other_ghc_ex -> io (print other_ghc_ex)
1844 showException other_exception
1845 = io (putStrLn ("*** Exception: " ++ show other_exception))
1847 showException (SomeException e) =
1849 Just Interrupted -> putStrLn "Interrupted."
1850 -- omit the location for CmdLineError:
1851 Just (CmdLineError s) -> putStrLn s
1853 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1854 Just other_ghc_ex -> print other_ghc_ex
1855 Nothing -> putStrLn ("*** Exception: " ++ show e)
1858 -----------------------------------------------------------------------------
1859 -- recursive exception handlers
1861 -- Don't forget to unblock async exceptions in the handler, or if we're
1862 -- in an exception loop (eg. let a = error a in a) the ^C exception
1863 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1865 ghciHandle :: (SomeException -> GHCi a) -> GHCi a -> GHCi a
1866 ghciHandle h (GHCi m) = GHCi $ \s ->
1867 Exception.catch (m s)
1868 (\e -> unGHCi (ghciUnblock (h e)) s)
1870 ghciUnblock :: GHCi a -> GHCi a
1871 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1873 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1874 ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s)
1876 -- ----------------------------------------------------------------------------
1879 expandPath :: String -> GHCi String
1880 expandPath path = io (expandPathIO path)
1882 expandPathIO :: String -> IO String
1884 case dropWhile isSpace path of
1886 tilde <- getHomeDirectory -- will fail if HOME not defined
1887 return (tilde ++ '/':d)
1891 wantInterpretedModule :: String -> GHCi Module
1892 wantInterpretedModule str = do
1893 session <- getSession
1894 modl <- lookupModule str
1895 dflags <- getDynFlags
1896 when (GHC.modulePackageId modl /= thisPackage dflags) $
1897 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1898 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1899 when (not is_interpreted) $
1900 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1903 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1904 -> (Name -> GHCi ())
1906 wantNameFromInterpretedModule noCanDo str and_then = do
1907 session <- getSession
1908 names <- io $ GHC.parseName session str
1912 let modl = GHC.nameModule n
1913 if not (GHC.isExternalName n)
1914 then noCanDo n $ ppr n <>
1915 text " is not defined in an interpreted module"
1917 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1918 if not is_interpreted
1919 then noCanDo n $ text "module " <> ppr modl <>
1920 text " is not interpreted"
1923 -- -----------------------------------------------------------------------------
1924 -- commands for debugger
1926 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1927 sprintCmd = pprintCommand False False
1928 printCmd = pprintCommand True False
1929 forceCmd = pprintCommand False True
1931 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1932 pprintCommand bind force str = do
1933 session <- getSession
1934 io $ pprintClosureCommand session bind force str
1936 stepCmd :: String -> GHCi ()
1937 stepCmd [] = doContinue (const True) GHC.SingleStep
1938 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1940 stepLocalCmd :: String -> GHCi ()
1941 stepLocalCmd [] = do
1942 mb_span <- getCurrentBreakSpan
1944 Nothing -> stepCmd []
1946 Just mod <- getCurrentBreakModule
1947 current_toplevel_decl <- enclosingTickSpan mod loc
1948 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1950 stepLocalCmd expression = stepCmd expression
1952 stepModuleCmd :: String -> GHCi ()
1953 stepModuleCmd [] = do
1954 mb_span <- getCurrentBreakSpan
1956 Nothing -> stepCmd []
1958 Just span <- getCurrentBreakSpan
1959 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1960 doContinue f GHC.SingleStep
1962 stepModuleCmd expression = stepCmd expression
1964 -- | Returns the span of the largest tick containing the srcspan given
1965 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1966 enclosingTickSpan mod src = do
1967 ticks <- getTickArray mod
1968 let line = srcSpanStartLine src
1969 ASSERT (inRange (bounds ticks) line) do
1970 let enclosing_spans = [ span | (_,span) <- ticks ! line
1971 , srcSpanEnd span >= srcSpanEnd src]
1972 return . head . sortBy leftmost_largest $ enclosing_spans
1974 traceCmd :: String -> GHCi ()
1975 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1976 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1978 continueCmd :: String -> GHCi ()
1979 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1981 -- doContinue :: SingleStep -> GHCi ()
1982 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1983 doContinue pred step = do
1984 runResult <- resume step
1985 afterRunStmt pred runResult
1988 abandonCmd :: String -> GHCi ()
1989 abandonCmd = noArgs $ do
1991 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1992 when (not b) $ io $ putStrLn "There is no computation running."
1995 deleteCmd :: String -> GHCi ()
1996 deleteCmd argLine = do
1997 deleteSwitch $ words argLine
1999 deleteSwitch :: [String] -> GHCi ()
2001 io $ putStrLn "The delete command requires at least one argument."
2002 -- delete all break points
2003 deleteSwitch ("*":_rest) = discardActiveBreakPoints
2004 deleteSwitch idents = do
2005 mapM_ deleteOneBreak idents
2007 deleteOneBreak :: String -> GHCi ()
2009 | all isDigit str = deleteBreak (read str)
2010 | otherwise = return ()
2012 historyCmd :: String -> GHCi ()
2014 | null arg = history 20
2015 | all isDigit arg = history (read arg)
2016 | otherwise = io $ putStrLn "Syntax: :history [num]"
2020 resumes <- io $ GHC.getResumeContext s
2022 [] -> io $ putStrLn "Not stopped at a breakpoint"
2024 let hist = GHC.resumeHistory r
2025 (took,rest) = splitAt num hist
2027 [] -> io $ putStrLn $
2028 "Empty history. Perhaps you forgot to use :trace?"
2030 spans <- mapM (io . GHC.getHistorySpan s) took
2031 let nums = map (printf "-%-3d:") [(1::Int)..]
2032 names = map GHC.historyEnclosingDecl took
2033 printForUser (vcat(zipWith3
2034 (\x y z -> x <+> y <+> z)
2036 (map (bold . ppr) names)
2037 (map (parens . ppr) spans)))
2038 io $ putStrLn $ if null rest then "<end of history>" else "..."
2040 bold :: SDoc -> SDoc
2041 bold c | do_bold = text start_bold <> c <> text end_bold
2044 backCmd :: String -> GHCi ()
2045 backCmd = noArgs $ do
2047 (names, _, span) <- io $ GHC.back s
2048 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
2049 printTypeOfNames s names
2050 -- run the command set with ":set stop <cmd>"
2052 enqueueCommands [stop st]
2054 forwardCmd :: String -> GHCi ()
2055 forwardCmd = noArgs $ do
2057 (names, ix, span) <- io $ GHC.forward s
2058 printForUser $ (if (ix == 0)
2059 then ptext (sLit "Stopped at")
2060 else ptext (sLit "Logged breakpoint at")) <+> ppr span
2061 printTypeOfNames s names
2062 -- run the command set with ":set stop <cmd>"
2064 enqueueCommands [stop st]
2066 -- handle the "break" command
2067 breakCmd :: String -> GHCi ()
2068 breakCmd argLine = do
2069 session <- getSession
2070 breakSwitch session $ words argLine
2072 breakSwitch :: Session -> [String] -> GHCi ()
2073 breakSwitch _session [] = do
2074 io $ putStrLn "The break command requires at least one argument."
2075 breakSwitch session (arg1:rest)
2076 | looksLikeModuleName arg1 && not (null rest) = do
2077 mod <- wantInterpretedModule arg1
2078 breakByModule mod rest
2079 | all isDigit arg1 = do
2080 (toplevel, _) <- io $ GHC.getContext session
2082 (mod : _) -> breakByModuleLine mod (read arg1) rest
2084 io $ putStrLn "Cannot find default module for breakpoint."
2085 io $ putStrLn "Perhaps no modules are loaded for debugging?"
2086 | otherwise = do -- try parsing it as an identifier
2087 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2088 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2089 if GHC.isGoodSrcLoc loc
2090 then findBreakAndSet (GHC.nameModule name) $
2091 findBreakByCoord (Just (GHC.srcLocFile loc))
2092 (GHC.srcLocLine loc,
2094 else noCanDo name $ text "can't find its location: " <> ppr loc
2096 noCanDo n why = printForUser $
2097 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2099 breakByModule :: Module -> [String] -> GHCi ()
2100 breakByModule mod (arg1:rest)
2101 | all isDigit arg1 = do -- looks like a line number
2102 breakByModuleLine mod (read arg1) rest
2106 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2107 breakByModuleLine mod line args
2108 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2109 | [col] <- args, all isDigit col =
2110 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2111 | otherwise = breakSyntax
2114 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2116 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2117 findBreakAndSet mod lookupTickTree = do
2118 tickArray <- getTickArray mod
2119 (breakArray, _) <- getModBreak mod
2120 case lookupTickTree tickArray of
2121 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2122 Just (tick, span) -> do
2123 success <- io $ setBreakFlag True breakArray tick
2127 recordBreak $ BreakLocation
2134 text "Breakpoint " <> ppr nm <>
2136 then text " was already set at " <> ppr span
2137 else text " activated at " <> ppr span
2139 printForUser $ text "Breakpoint could not be activated at"
2142 -- When a line number is specified, the current policy for choosing
2143 -- the best breakpoint is this:
2144 -- - the leftmost complete subexpression on the specified line, or
2145 -- - the leftmost subexpression starting on the specified line, or
2146 -- - the rightmost subexpression enclosing the specified line
2148 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2149 findBreakByLine line arr
2150 | not (inRange (bounds arr) line) = Nothing
2152 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2153 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2154 listToMaybe (sortBy (rightmost `on` snd) ticks)
2158 starts_here = [ tick | tick@(_,span) <- ticks,
2159 GHC.srcSpanStartLine span == line ]
2161 (complete,incomplete) = partition ends_here starts_here
2162 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2164 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2165 -> Maybe (BreakIndex,SrcSpan)
2166 findBreakByCoord mb_file (line, col) arr
2167 | not (inRange (bounds arr) line) = Nothing
2169 listToMaybe (sortBy (rightmost `on` snd) contains ++
2170 sortBy (leftmost_smallest `on` snd) after_here)
2174 -- the ticks that span this coordinate
2175 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2176 is_correct_file span ]
2178 is_correct_file span
2179 | Just f <- mb_file = GHC.srcSpanFile span == f
2182 after_here = [ tick | tick@(_,span) <- ticks,
2183 GHC.srcSpanStartLine span == line,
2184 GHC.srcSpanStartCol span >= col ]
2186 -- For now, use ANSI bold on terminals that we know support it.
2187 -- Otherwise, we add a line of carets under the active expression instead.
2188 -- In particular, on Windows and when running the testsuite (which sets
2189 -- TERM to vt100 for other reasons) we get carets.
2190 -- We really ought to use a proper termcap/terminfo library.
2192 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2193 where mTerm = System.Environment.getEnv "TERM"
2194 `catchIO` \_ -> return "TERM not set"
2196 start_bold :: String
2197 start_bold = "\ESC[1m"
2199 end_bold = "\ESC[0m"
2201 listCmd :: String -> GHCi ()
2203 mb_span <- getCurrentBreakSpan
2206 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2208 | GHC.isGoodSrcSpan span -> io $ listAround span True
2211 resumes <- io $ GHC.getResumeContext s
2213 [] -> panic "No resumes"
2215 do let traceIt = case GHC.resumeHistory r of
2216 [] -> text "rerunning with :trace,"
2218 doWhat = traceIt <+> text ":back then :list"
2219 printForUser (text "Unable to list source for" <+>
2221 $$ text "Try" <+> doWhat)
2222 listCmd str = list2 (words str)
2224 list2 :: [String] -> GHCi ()
2225 list2 [arg] | all isDigit arg = do
2226 session <- getSession
2227 (toplevel, _) <- io $ GHC.getContext session
2229 [] -> io $ putStrLn "No module to list"
2230 (mod : _) -> listModuleLine mod (read arg)
2231 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2232 mod <- wantInterpretedModule arg1
2233 listModuleLine mod (read arg2)
2235 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2236 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2237 if GHC.isGoodSrcLoc loc
2239 tickArray <- getTickArray (GHC.nameModule name)
2240 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2241 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2244 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2245 Just (_,span) -> io $ listAround span False
2247 noCanDo name $ text "can't find its location: " <>
2250 noCanDo n why = printForUser $
2251 text "cannot list source code for " <> ppr n <> text ": " <> why
2253 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2255 listModuleLine :: Module -> Int -> GHCi ()
2256 listModuleLine modl line = do
2257 session <- getSession
2258 graph <- io (GHC.getModuleGraph session)
2259 let this = filter ((== modl) . GHC.ms_mod) graph
2261 [] -> panic "listModuleLine"
2263 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2264 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2265 io $ listAround (GHC.srcLocSpan loc) False
2267 -- | list a section of a source file around a particular SrcSpan.
2268 -- If the highlight flag is True, also highlight the span using
2269 -- start_bold\/end_bold.
2270 listAround :: SrcSpan -> Bool -> IO ()
2271 listAround span do_highlight = do
2272 contents <- BS.readFile (unpackFS file)
2274 lines = BS.split '\n' contents
2275 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2276 drop (line1 - 1 - pad_before) $ lines
2277 fst_line = max 1 (line1 - pad_before)
2278 line_nos = [ fst_line .. ]
2280 highlighted | do_highlight = zipWith highlight line_nos these_lines
2281 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2283 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2284 prefixed = zipWith ($) highlighted bs_line_nos
2286 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2288 file = GHC.srcSpanFile span
2289 line1 = GHC.srcSpanStartLine span
2290 col1 = GHC.srcSpanStartCol span
2291 line2 = GHC.srcSpanEndLine span
2292 col2 = GHC.srcSpanEndCol span
2294 pad_before | line1 == 1 = 0
2298 highlight | do_bold = highlight_bold
2299 | otherwise = highlight_carets
2301 highlight_bold no line prefix
2302 | no == line1 && no == line2
2303 = let (a,r) = BS.splitAt col1 line
2304 (b,c) = BS.splitAt (col2-col1) r
2306 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2308 = let (a,b) = BS.splitAt col1 line in
2309 BS.concat [prefix, a, BS.pack start_bold, b]
2311 = let (a,b) = BS.splitAt col2 line in
2312 BS.concat [prefix, a, BS.pack end_bold, b]
2313 | otherwise = BS.concat [prefix, line]
2315 highlight_carets no line prefix
2316 | no == line1 && no == line2
2317 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2318 BS.replicate (col2-col1) '^']
2320 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2323 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2325 | otherwise = BS.concat [prefix, line]
2327 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2328 nl = BS.singleton '\n'
2330 -- --------------------------------------------------------------------------
2333 getTickArray :: Module -> GHCi TickArray
2334 getTickArray modl = do
2336 let arrmap = tickarrays st
2337 case lookupModuleEnv arrmap modl of
2338 Just arr -> return arr
2340 (_breakArray, ticks) <- getModBreak modl
2341 let arr = mkTickArray (assocs ticks)
2342 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2345 discardTickArrays :: GHCi ()
2346 discardTickArrays = do
2348 setGHCiState st{tickarrays = emptyModuleEnv}
2350 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2352 = accumArray (flip (:)) [] (1, max_line)
2353 [ (line, (nm,span)) | (nm,span) <- ticks,
2354 line <- srcSpanLines span ]
2356 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2357 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2358 GHC.srcSpanEndLine span ]
2360 lookupModule :: String -> GHCi Module
2361 lookupModule modName
2362 = do session <- getSession
2363 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2365 -- don't reset the counter back to zero?
2366 discardActiveBreakPoints :: GHCi ()
2367 discardActiveBreakPoints = do
2369 mapM (turnOffBreak.snd) (breaks st)
2370 setGHCiState $ st { breaks = [] }
2372 deleteBreak :: Int -> GHCi ()
2373 deleteBreak identity = do
2375 let oldLocations = breaks st
2376 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2378 then printForUser (text "Breakpoint" <+> ppr identity <+>
2379 text "does not exist")
2381 mapM (turnOffBreak.snd) this
2382 setGHCiState $ st { breaks = rest }
2384 turnOffBreak :: BreakLocation -> GHCi Bool
2385 turnOffBreak loc = do
2386 (arr, _) <- getModBreak (breakModule loc)
2387 io $ setBreakFlag False arr (breakTick loc)
2389 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2390 getModBreak mod = do
2391 session <- getSession
2392 Just mod_info <- io $ GHC.getModuleInfo session mod
2393 let modBreaks = GHC.modInfoModBreaks mod_info
2394 let array = GHC.modBreaks_flags modBreaks
2395 let ticks = GHC.modBreaks_locs modBreaks
2396 return (array, ticks)
2398 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2399 setBreakFlag toggle array index
2400 | toggle = GHC.setBreakOn array index
2401 | otherwise = GHC.setBreakOff array index