1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
12 #include "HsVersions.h"
14 import qualified GhciMonad
15 import GhciMonad hiding (runStmt)
20 import qualified GHC hiding (resume, runStmt)
21 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
22 Module, ModuleName, TyThing(..), Phase,
23 BreakIndex, SrcSpan, Resume, SingleStep )
33 import HscTypes ( implicitTyThings )
34 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
35 import Outputable hiding (printForUser, printForUserPartWay)
36 import Module -- for ModuleEnv
40 -- Other random utilities
42 import BasicTypes hiding (isTopLevel)
43 import Panic hiding (showException)
49 import Maybes ( orElse )
53 #ifndef mingw32_HOST_OS
54 import System.Posix hiding (getEnv)
56 import GHC.ConsoleHandler ( flushConsole )
57 import qualified System.Win32
61 import Control.Concurrent ( yield ) -- Used in readline loop
62 import System.Console.Editline.Readline as Readline
67 import Control.Exception as Exception
68 -- import Control.Concurrent
70 import System.FilePath
71 import qualified Data.ByteString.Char8 as BS
75 import System.Environment
76 import System.Exit ( exitWith, ExitCode(..) )
77 import System.Directory
79 import System.IO.Error as IO
83 import Control.Monad as Monad
87 import GHC.Exts ( unsafeCoerce# )
88 import GHC.IOBase ( IOErrorType(InvalidArgument) )
91 import Data.IORef ( IORef, readIORef, writeIORef )
94 import System.Posix.Internals ( setNonBlockingFD )
97 -----------------------------------------------------------------------------
99 ghciWelcomeMsg :: String
100 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
101 ": http://www.haskell.org/ghc/ :? for help"
103 cmdName :: Command -> String
104 cmdName (n,_,_,_) = n
106 GLOBAL_VAR(macros_ref, [], [Command])
108 builtin_commands :: [Command]
110 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
111 ("?", keepGoing help, Nothing, completeNone),
112 ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename),
113 ("abandon", keepGoing abandonCmd, Nothing, completeNone),
114 ("break", keepGoing breakCmd, Nothing, completeIdentifier),
115 ("back", keepGoing backCmd, Nothing, completeNone),
116 ("browse", keepGoing (browseCmd False), Nothing, completeModule),
117 ("browse!", keepGoing (browseCmd True), Nothing, completeModule),
118 ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename),
119 ("check", keepGoing checkModule, Nothing, completeHomeModule),
120 ("continue", keepGoing continueCmd, Nothing, completeNone),
121 ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier),
122 ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename),
123 ("def", keepGoing (defineMacro False), Nothing, completeIdentifier),
124 ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier),
125 ("delete", keepGoing deleteCmd, Nothing, completeNone),
126 ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
127 ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
128 ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename),
129 ("force", keepGoing forceCmd, Nothing, completeIdentifier),
130 ("forward", keepGoing forwardCmd, Nothing, completeNone),
131 ("help", keepGoing help, Nothing, completeNone),
132 ("history", keepGoing historyCmd, Nothing, completeNone),
133 ("info", keepGoing info, Nothing, completeIdentifier),
134 ("kind", keepGoing kindOfType, Nothing, completeIdentifier),
135 ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile),
136 ("list", keepGoing listCmd, Nothing, completeNone),
137 ("module", keepGoing setContext, Nothing, completeModule),
138 ("main", keepGoing runMain, Nothing, completeIdentifier),
139 ("print", keepGoing printCmd, Nothing, completeIdentifier),
140 ("quit", quit, Nothing, completeNone),
141 ("reload", keepGoing reloadModule, Nothing, completeNone),
142 ("run", keepGoing runRun, Nothing, completeIdentifier),
143 ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions),
144 ("show", keepGoing showCmd, Nothing, completeNone),
145 ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier),
146 ("step", keepGoing stepCmd, Nothing, completeIdentifier),
147 ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier),
148 ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier),
149 ("type", keepGoing typeOfExpr, Nothing, completeIdentifier),
150 ("trace", keepGoing traceCmd, Nothing, completeIdentifier),
151 ("undef", keepGoing undefineMacro, Nothing, completeMacro),
152 ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions)
156 -- We initialize readline (in the interactiveUI function) to use
157 -- word_break_chars as the default set of completion word break characters.
158 -- This can be overridden for a particular command (for example, filename
159 -- expansion shouldn't consider '/' to be a word break) by setting the third
160 -- entry in the Command tuple above.
162 -- NOTE: in order for us to override the default correctly, any custom entry
163 -- must be a SUBSET of word_break_chars.
165 word_break_chars :: String
166 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
167 specials = "(),;[]`{}"
169 in spaces ++ specials ++ symbols
172 flagWordBreakChars, filenameWordBreakChars :: String
173 flagWordBreakChars = " \t\n"
174 filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults
177 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
178 keepGoing a str = a str >> return False
180 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
182 = do case toArgs str of
183 Left err -> io (hPutStrLn stderr err)
187 shortHelpText :: String
188 shortHelpText = "use :? for help.\n"
192 " Commands available from the prompt:\n" ++
194 " <statement> evaluate/run <statement>\n" ++
195 " : repeat last command\n" ++
196 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
197 " :add <filename> ... add module(s) to the current target set\n" ++
198 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
199 " (!: more details; *: all top-level names)\n" ++
200 " :cd <dir> change directory to <dir>\n" ++
201 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
202 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
203 " :def <cmd> <expr> define a command :<cmd>\n" ++
204 " :edit <file> edit file\n" ++
205 " :edit edit last module\n" ++
206 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
207 " :help, :? display this list of commands\n" ++
208 " :info [<name> ...] display information about the given names\n" ++
209 " :kind <type> show the kind of <type>\n" ++
210 " :load <filename> ... load module(s) and their dependents\n" ++
211 " :main [<arguments> ...] run the main function with the given arguments\n" ++
212 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
213 " :quit exit GHCi\n" ++
214 " :reload reload the current module set\n" ++
215 " :run function [<arguments> ...] run the function with the given arguments\n" ++
216 " :type <expr> show the type of <expr>\n" ++
217 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
218 " :!<command> run the shell command <command>\n" ++
220 " -- Commands for debugging:\n" ++
222 " :abandon at a breakpoint, abandon current computation\n" ++
223 " :back go back in the history (after :trace)\n" ++
224 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
225 " :break <name> set a breakpoint on the specified function\n" ++
226 " :continue resume after a breakpoint\n" ++
227 " :delete <number> delete the specified breakpoint\n" ++
228 " :delete * delete all breakpoints\n" ++
229 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
230 " :forward go forward in the history (after :back)\n" ++
231 " :history [<n>] after :trace, show the execution history\n" ++
232 " :list show the source code around current breakpoint\n" ++
233 " :list identifier show the source code for <identifier>\n" ++
234 " :list [<module>] <line> show the source code around line number <line>\n" ++
235 " :print [<name> ...] prints a value without forcing its computation\n" ++
236 " :sprint [<name> ...] simplifed version of :print\n" ++
237 " :step single-step after stopping at a breakpoint\n"++
238 " :step <expr> single-step into <expr>\n"++
239 " :steplocal single-step within the current top-level binding\n"++
240 " :stepmodule single-step restricted to the current module\n"++
241 " :trace trace after stopping at a breakpoint\n"++
242 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
245 " -- Commands for changing settings:\n" ++
247 " :set <option> ... set options\n" ++
248 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
249 " :set prog <progname> set the value returned by System.getProgName\n" ++
250 " :set prompt <prompt> set the prompt used in GHCi\n" ++
251 " :set editor <cmd> set the command used for :edit\n" ++
252 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
253 " :unset <option> ... unset options\n" ++
255 " Options for ':set' and ':unset':\n" ++
257 " +r revert top-level expressions after each evaluation\n" ++
258 " +s print timing/memory stats after each evaluation\n" ++
259 " +t print type after evaluation\n" ++
260 " -<flags> most GHC command line flags can also be set here\n" ++
261 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
262 " for GHCi-specific flags, see User's Guide,\n"++
263 " Flag reference, Interactive-mode options\n" ++
265 " -- Commands for displaying information:\n" ++
267 " :show bindings show the current bindings made at the prompt\n" ++
268 " :show breaks show the active breakpoints\n" ++
269 " :show context show the breakpoint context\n" ++
270 " :show modules show the currently loaded modules\n" ++
271 " :show packages show the currently active package flags\n" ++
272 " :show languages show the currently active language flags\n" ++
273 " :show <setting> show value of <setting>, which is one of\n" ++
274 " [args, prog, prompt, editor, stop]\n" ++
277 findEditor :: IO String
282 win <- System.Win32.getWindowsDirectory
283 return (win </> "notepad.exe")
288 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String]
290 interactiveUI session srcs maybe_exprs = do
291 -- HACK! If we happen to get into an infinite loop (eg the user
292 -- types 'let x=x in x' at the prompt), then the thread will block
293 -- on a blackhole, and become unreachable during GC. The GC will
294 -- detect that it is unreachable and send it the NonTermination
295 -- exception. However, since the thread is unreachable, everything
296 -- it refers to might be finalized, including the standard Handles.
297 -- This sounds like a bug, but we don't have a good solution right
303 -- Initialise buffering for the *interpreted* I/O system
304 initInterpBuffering session
306 when (isNothing maybe_exprs) $ do
307 -- Only for GHCi (not runghc and ghc -e):
309 -- Turn buffering off for the compiled program's stdout/stderr
311 -- Turn buffering off for GHCi's stdout
313 hSetBuffering stdout NoBuffering
314 -- We don't want the cmd line to buffer any input that might be
315 -- intended for the program, so unbuffer stdin.
316 hSetBuffering stdin NoBuffering
319 is_tty <- hIsTerminalDevice stdin
324 (\dir -> Readline.readHistory (dir </> "ghci_history"))
327 Readline.setAttemptedCompletionFunction (Just completeWord)
328 --Readline.parseAndBind "set show-all-if-ambiguous 1"
330 Readline.setBasicWordBreakCharacters word_break_chars
331 Readline.setCompleterWordBreakCharacters word_break_chars
332 Readline.setCompletionAppendCharacter Nothing
335 -- initial context is just the Prelude
336 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
338 GHC.setContext session [] [prel_mod]
340 default_editor <- findEditor
342 cwd <- getCurrentDirectory
344 startGHCi (runGHCi srcs maybe_exprs)
345 GHCiState{ progname = "<interactive>",
349 editor = default_editor,
355 tickarrays = emptyModuleEnv,
356 last_command = Nothing,
360 ghc_e = isJust maybe_exprs
364 Readline.stifleHistory 100
365 withGhcAppData (\dir -> Readline.writeHistory (dir </> "ghci_history"))
367 Readline.resetTerminal Nothing
372 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
373 withGhcAppData right left = do
374 either_dir <- IO.try (getAppUserDataDirectory "ghc")
376 Right dir -> right dir
380 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
381 runGHCi paths maybe_exprs = do
383 read_dot_files = not opt_IgnoreDotGhci
385 current_dir = return (Just ".ghci")
387 app_user_dir = io $ withGhcAppData
388 (\dir -> return (Just (dir </> "ghci.conf")))
392 either_dir <- io $ IO.try (getEnv "HOME")
394 Right home -> return (Just (home </> ".ghci"))
397 sourceConfigFile :: FilePath -> GHCi ()
398 sourceConfigFile file = do
399 exists <- io $ doesFileExist file
401 dir_ok <- io $ checkPerms (getDirectory file)
402 file_ok <- io $ checkPerms file
403 when (dir_ok && file_ok) $ do
404 either_hdl <- io $ IO.try (openFile file ReadMode)
407 Right hdl -> runCommands (fileLoop hdl False False)
409 getDirectory f = case takeDirectory f of "" -> "."; d -> d
411 when (read_dot_files) $ do
412 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
413 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
414 mapM_ sourceConfigFile (nub cfgs)
415 -- nub, because we don't want to read .ghci twice if the
418 -- Perform a :load for files given on the GHCi command line
419 -- When in -e mode, if the load fails then we want to stop
420 -- immediately rather than going on to evaluate the expression.
421 when (not (null paths)) $ do
422 ok <- ghciHandle (\e -> do showException e; return Failed) $
424 when (isJust maybe_exprs && failed ok) $
425 io (exitWith (ExitFailure 1))
427 -- if verbosity is greater than 0, or we are connected to a
428 -- terminal, display the prompt in the interactive loop.
429 is_tty <- io (hIsTerminalDevice stdin)
430 dflags <- getDynFlags
431 let show_prompt = verbosity dflags > 0 || is_tty
436 #if defined(mingw32_HOST_OS)
437 -- The win32 Console API mutates the first character of
438 -- type-ahead when reading from it in a non-buffered manner. Work
439 -- around this by flushing the input buffer of type-ahead characters,
440 -- but only if stdin is available.
441 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
443 Left err | isDoesNotExistError err -> return ()
444 | otherwise -> io (ioError err)
445 Right () -> return ()
447 -- enter the interactive loop
448 interactiveLoop is_tty show_prompt
450 -- just evaluate the expression we were given
451 enqueueCommands exprs
452 let handle e = do st <- getGHCiState
453 -- Jump through some hoops to get the
454 -- current progname in the exception text:
455 -- <progname>: <exception>
456 io $ withProgName (progname st)
457 -- this used to be topHandlerFastExit, see #2228
459 runCommands' handle (return Nothing)
462 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
464 interactiveLoop :: Bool -> Bool -> GHCi ()
465 interactiveLoop is_tty show_prompt =
466 -- Ignore ^C exceptions caught here
467 ghciHandleDyn (\e -> case e of
469 #if defined(mingw32_HOST_OS)
472 interactiveLoop is_tty show_prompt
473 _other -> return ()) $
475 ghciUnblock $ do -- unblock necessary if we recursed from the
476 -- exception handler above.
478 -- read commands from stdin
481 then runCommands readlineLoop
482 else runCommands (fileLoop stdin show_prompt is_tty)
484 runCommands (fileLoop stdin show_prompt is_tty)
488 -- NOTE: We only read .ghci files if they are owned by the current user,
489 -- and aren't world writable. Otherwise, we could be accidentally
490 -- running code planted by a malicious third party.
492 -- Furthermore, We only read ./.ghci if . is owned by the current user
493 -- and isn't writable by anyone else. I think this is sufficient: we
494 -- don't need to check .. and ../.. etc. because "." always refers to
495 -- the same directory while a process is running.
497 checkPerms :: String -> IO Bool
498 #ifdef mingw32_HOST_OS
503 Util.handle (\_ -> return False) $ do
504 st <- getFileStatus name
506 if fileOwner st /= me then do
507 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
510 let mode = fileMode st
511 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
512 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
514 putStrLn $ "*** WARNING: " ++ name ++
515 " is writable by someone else, IGNORING!"
520 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
521 fileLoop hdl show_prompt is_tty = do
522 when show_prompt $ do
525 l <- io (IO.try (hGetLine hdl))
527 Left e | isEOFError e -> return Nothing
528 | InvalidArgument <- etype -> return Nothing
529 | otherwise -> io (ioError e)
530 where etype = ioeGetErrorType e
531 -- treat InvalidArgument in the same way as EOF:
532 -- this can happen if the user closed stdin, or
533 -- perhaps did getContents which closes stdin at
536 str <- io $ consoleInputToUnicode is_tty l
539 #ifdef mingw32_HOST_OS
540 -- Convert the console input into Unicode according to the current code page.
541 -- The Windows console stores Unicode characters directly, so this is a
542 -- rather roundabout way of doing things... oh well.
543 -- See #782, #1483, #1649
544 consoleInputToUnicode :: Bool -> String -> IO String
545 consoleInputToUnicode is_tty str
547 cp <- System.Win32.getConsoleCP
548 System.Win32.stringToUnicode cp str
550 decodeStringAsUTF8 str
552 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
554 consoleInputToUnicode :: Bool -> String -> IO String
555 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
558 decodeStringAsUTF8 :: String -> IO String
559 decodeStringAsUTF8 str =
560 withCStringLen str $ \(cstr,len) ->
561 utf8DecodeString (castPtr cstr :: Ptr Word8) len
563 mkPrompt :: GHCi String
565 session <- getSession
566 (toplevs,exports) <- io (GHC.getContext session)
567 resumes <- io $ GHC.getResumeContext session
568 -- st <- getGHCiState
574 let ix = GHC.resumeHistoryIx r
576 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
578 let hist = GHC.resumeHistory r !! (ix-1)
579 span <- io$ GHC.getHistorySpan session hist
580 return (brackets (ppr (negate ix) <> char ':'
581 <+> ppr span) <> space)
583 dots | _:rs <- resumes, not (null rs) = text "... "
590 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
591 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
592 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
593 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
594 hsep (map (ppr . GHC.moduleName) exports)
596 deflt_prompt = dots <> context_bit <> modules_bit
598 f ('%':'s':xs) = deflt_prompt <> f xs
599 f ('%':'%':xs) = char '%' <> f xs
600 f (x:xs) = char x <> f xs
604 return (showSDoc (f (prompt st)))
608 readlineLoop :: GHCi (Maybe String)
611 saveSession -- for use by completion
613 l <- io (readline prompt `finally` setNonBlockingFD 0)
614 -- readline sometimes puts stdin into blocking mode,
615 -- so we need to put it back for the IO library
618 Nothing -> return Nothing
619 Just "" -> return (Just "") -- Don't put empty lines in the history
622 str <- io $ consoleInputToUnicode True l
626 queryQueue :: GHCi (Maybe String)
631 c:cs -> do setGHCiState st{ cmdqueue = cs }
634 runCommands :: GHCi (Maybe String) -> GHCi ()
635 runCommands = runCommands' handler
637 runCommands' :: (Exception -> GHCi Bool) -- Exception handler
638 -> GHCi (Maybe String) -> GHCi ()
639 runCommands' eh getCmd = do
640 mb_cmd <- noSpace queryQueue
641 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
645 b <- ghciHandle eh (doCommand c)
646 if b then return () else runCommands' eh getCmd
648 noSpace q = q >>= maybe (return Nothing)
649 (\c->case removeSpaces c of
651 ":{" -> multiLineCmd q
652 c -> return (Just c) )
656 setGHCiState st{ prompt = "%s| " }
657 mb_cmd <- collectCommand q ""
658 getGHCiState >>= \st->setGHCiState st{ prompt = p }
660 -- we can't use removeSpaces for the sublines here, so
661 -- multiline commands are somewhat more brittle against
662 -- fileformat errors (such as \r in dos input on unix),
663 -- we get rid of any extra spaces for the ":}" test;
664 -- we also avoid silent failure if ":}" is not found;
665 -- and since there is no (?) valid occurrence of \r (as
666 -- opposed to its String representation, "\r") inside a
667 -- ghci command, we replace any such with ' ' (argh:-(
668 collectCommand q c = q >>=
669 maybe (io (ioError collectError))
670 (\l->if removeSpaces l == ":}"
671 then return (Just $ removeSpaces c)
672 else collectCommand q (c++map normSpace l))
673 where normSpace '\r' = ' '
675 -- QUESTION: is userError the one to use here?
676 collectError = userError "unterminated multiline command :{ .. :}"
677 doCommand (':' : cmd) = specialCommand cmd
678 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
681 enqueueCommands :: [String] -> GHCi ()
682 enqueueCommands cmds = do
684 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
687 runStmt :: String -> SingleStep -> GHCi Bool
689 | null (filter (not.isSpace) stmt) = return False
690 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
692 = do result <- GhciMonad.runStmt stmt step
693 afterRunStmt (const True) result
695 --afterRunStmt :: GHC.RunResult -> GHCi Bool
696 -- False <=> the statement failed to compile
697 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
698 afterRunStmt _ (GHC.RunException e) = throw e
699 afterRunStmt step_here run_result = do
700 session <- getSession
701 resumes <- io $ GHC.getResumeContext session
703 GHC.RunOk names -> do
704 show_types <- isOptionSet ShowType
705 when show_types $ printTypeOfNames session names
706 GHC.RunBreak _ names mb_info
707 | isNothing mb_info ||
708 step_here (GHC.resumeSpan $ head resumes) -> do
709 printForUser $ ptext (sLit "Stopped at") <+>
710 ppr (GHC.resumeSpan $ head resumes)
711 -- printTypeOfNames session names
712 let namesSorted = sortBy compareNames names
713 tythings <- catMaybes `liftM`
714 io (mapM (GHC.lookupName session) namesSorted)
715 docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
716 printForUserPartWay docs
717 maybe (return ()) runBreakCmd mb_info
718 -- run the command set with ":set stop <cmd>"
720 enqueueCommands [stop st]
722 | otherwise -> resume GHC.SingleStep >>=
723 afterRunStmt step_here >> return ()
727 io installSignalHandlers
728 b <- isOptionSet RevertCAFs
731 return (case run_result of GHC.RunOk _ -> True; _ -> False)
733 runBreakCmd :: GHC.BreakInfo -> GHCi ()
734 runBreakCmd info = do
735 let mod = GHC.breakInfo_module info
736 nm = GHC.breakInfo_number info
738 case [ loc | (_,loc) <- breaks st,
739 breakModule loc == mod, breakTick loc == nm ] of
741 loc:_ | null cmd -> return ()
742 | otherwise -> do enqueueCommands [cmd]; return ()
743 where cmd = onBreakCmd loc
745 printTypeOfNames :: Session -> [Name] -> GHCi ()
746 printTypeOfNames session names
747 = mapM_ (printTypeOfName session) $ sortBy compareNames names
749 compareNames :: Name -> Name -> Ordering
750 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
751 where compareWith n = (getOccString n, getSrcSpan n)
753 printTypeOfName :: Session -> Name -> GHCi ()
754 printTypeOfName session n
755 = do maybe_tything <- io (GHC.lookupName session n)
756 case maybe_tything of
758 Just thing -> printTyThing thing
761 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
763 specialCommand :: String -> GHCi Bool
764 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
765 specialCommand str = do
766 let (cmd,rest) = break isSpace str
767 maybe_cmd <- lookupCommand cmd
769 GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
771 do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
775 do io $ hPutStr stdout ("there is no last command to perform\n"
779 lookupCommand :: String -> GHCi (MaybeCommand)
780 lookupCommand "" = do
782 case last_command st of
783 Just c -> return $ GotCommand c
784 Nothing -> return NoLastCommand
785 lookupCommand str = do
786 mc <- io $ lookupCommand' str
788 setGHCiState st{ last_command = mc }
790 Just c -> GotCommand c
791 Nothing -> BadCommand
793 lookupCommand' :: String -> IO (Maybe Command)
794 lookupCommand' str = do
795 macros <- readIORef macros_ref
796 let cmds = builtin_commands ++ macros
797 -- look for exact match first, then the first prefix match
798 return $ case [ c | c <- cmds, str == cmdName c ] of
800 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
804 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
805 getCurrentBreakSpan = do
806 session <- getSession
807 resumes <- io $ GHC.getResumeContext session
811 let ix = GHC.resumeHistoryIx r
813 then return (Just (GHC.resumeSpan r))
815 let hist = GHC.resumeHistory r !! (ix-1)
816 span <- io $ GHC.getHistorySpan session hist
819 getCurrentBreakModule :: GHCi (Maybe Module)
820 getCurrentBreakModule = do
821 session <- getSession
822 resumes <- io $ GHC.getResumeContext session
826 let ix = GHC.resumeHistoryIx r
828 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
830 let hist = GHC.resumeHistory r !! (ix-1)
831 return $ Just $ GHC.getHistoryModule hist
833 -----------------------------------------------------------------------------
836 noArgs :: GHCi () -> String -> GHCi ()
838 noArgs _ _ = io $ putStrLn "This command takes no arguments"
840 help :: String -> GHCi ()
841 help _ = io (putStr helpText)
843 info :: String -> GHCi ()
844 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
845 info s = do { let names = words s
846 ; session <- getSession
847 ; dflags <- getDynFlags
848 ; let pefas = dopt Opt_PrintExplicitForalls dflags
849 ; mapM_ (infoThing pefas session) names }
851 infoThing pefas session str = io $ do
852 names <- GHC.parseName session str
853 mb_stuffs <- mapM (GHC.getInfo session) names
854 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
855 unqual <- GHC.getPrintUnqual session
856 putStrLn (showSDocForUser unqual $
857 vcat (intersperse (text "") $
858 map (pprInfo pefas) filtered))
860 -- Filter out names whose parent is also there Good
861 -- example is '[]', which is both a type and data
862 -- constructor in the same type
863 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
864 filterOutChildren get_thing xs
865 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
867 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
869 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
870 pprInfo pefas (thing, fixity, insts)
871 = pprTyThingInContextLoc pefas thing
872 $$ show_fixity fixity
873 $$ vcat (map GHC.pprInstance insts)
876 | fix == GHC.defaultFixity = empty
877 | otherwise = ppr fix <+> ppr (GHC.getName thing)
879 runMain :: String -> GHCi ()
880 runMain s = case toArgs s of
881 Left err -> io (hPutStrLn stderr err)
883 do dflags <- getDynFlags
884 case mainFunIs dflags of
885 Nothing -> doWithArgs args "main"
886 Just f -> doWithArgs args f
888 runRun :: String -> GHCi ()
889 runRun s = case toCmdArgs s of
890 Left err -> io (hPutStrLn stderr err)
891 Right (cmd, args) -> doWithArgs args cmd
893 doWithArgs :: [String] -> String -> GHCi ()
894 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
895 show args ++ " (" ++ cmd ++ ")"]
897 addModule :: [FilePath] -> GHCi ()
899 revertCAFs -- always revert CAFs on load/add.
900 files <- mapM expandPath files
901 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
902 session <- getSession
903 io (mapM_ (GHC.addTarget session) targets)
904 prev_context <- io $ GHC.getContext session
905 ok <- io (GHC.load session LoadAllTargets)
906 afterLoad ok session False prev_context
908 changeDirectory :: String -> GHCi ()
909 changeDirectory "" = do
910 -- :cd on its own changes to the user's home directory
911 either_dir <- io (IO.try getHomeDirectory)
914 Right dir -> changeDirectory dir
915 changeDirectory dir = do
916 session <- getSession
917 graph <- io (GHC.getModuleGraph session)
918 when (not (null graph)) $
919 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
920 prev_context <- io $ GHC.getContext session
921 io (GHC.setTargets session [])
922 io (GHC.load session LoadAllTargets)
923 setContextAfterLoad session prev_context False []
924 io (GHC.workingDirectoryChanged session)
925 dir <- expandPath dir
926 io (setCurrentDirectory dir)
928 editFile :: String -> GHCi ()
930 do file <- if null str then chooseEditFile else return str
934 $ throwDyn (CmdLineError "editor not set, use :set editor")
935 io $ system (cmd ++ ' ':file)
938 -- The user didn't specify a file so we pick one for them.
939 -- Our strategy is to pick the first module that failed to load,
940 -- or otherwise the first target.
942 -- XXX: Can we figure out what happened if the depndecy analysis fails
943 -- (e.g., because the porgrammeer mistyped the name of a module)?
944 -- XXX: Can we figure out the location of an error to pass to the editor?
945 -- XXX: if we could figure out the list of errors that occured during the
946 -- last load/reaload, then we could start the editor focused on the first
948 chooseEditFile :: GHCi String
950 do session <- getSession
951 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
953 graph <- io (GHC.getModuleGraph session)
954 failed_graph <- filterM hasFailed graph
955 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
957 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
960 case pick (order failed_graph) of
961 Just file -> return file
963 do targets <- io (GHC.getTargets session)
964 case msum (map fromTarget targets) of
965 Just file -> return file
966 Nothing -> throwDyn (CmdLineError "No files to edit.")
968 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
969 fromTarget _ = Nothing -- when would we get a module target?
971 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
972 defineMacro overwrite s = do
973 let (macro_name, definition) = break isSpace s
974 macros <- io (readIORef macros_ref)
975 let defined = map cmdName macros
978 then io $ putStrLn "no macros defined"
979 else io $ putStr ("the following macros are defined:\n" ++
982 if (not overwrite && macro_name `elem` defined)
983 then throwDyn (CmdLineError
984 ("macro '" ++ macro_name ++ "' is already defined"))
987 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
989 -- give the expression a type signature, so we can be sure we're getting
990 -- something of the right type.
991 let new_expr = '(' : definition ++ ") :: String -> IO String"
993 -- compile the expression
995 maybe_hv <- io (GHC.compileExpr cms new_expr)
998 Just hv -> io (writeIORef macros_ref --
999 (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)]))
1001 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
1003 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
1004 enqueueCommands (lines str)
1007 undefineMacro :: String -> GHCi ()
1008 undefineMacro str = mapM_ undef (words str)
1009 where undef macro_name = do
1010 cmds <- io (readIORef macros_ref)
1011 if (macro_name `notElem` map cmdName cmds)
1012 then throwDyn (CmdLineError
1013 ("macro '" ++ macro_name ++ "' is not defined"))
1015 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
1017 cmdCmd :: String -> GHCi ()
1019 let expr = '(' : str ++ ") :: IO String"
1020 session <- getSession
1021 maybe_hv <- io (GHC.compileExpr session expr)
1023 Nothing -> return ()
1025 cmds <- io $ (unsafeCoerce# hv :: IO String)
1026 enqueueCommands (lines cmds)
1029 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1030 loadModule fs = timeIt (loadModule' fs)
1032 loadModule_ :: [FilePath] -> GHCi ()
1033 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
1035 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1036 loadModule' files = do
1037 session <- getSession
1038 prev_context <- io $ GHC.getContext session
1041 discardActiveBreakPoints
1042 io (GHC.setTargets session [])
1043 io (GHC.load session LoadAllTargets)
1046 let (filenames, phases) = unzip files
1047 exp_filenames <- mapM expandPath filenames
1048 let files' = zip exp_filenames phases
1049 targets <- io (mapM (uncurry GHC.guessTarget) files')
1051 -- NOTE: we used to do the dependency anal first, so that if it
1052 -- fails we didn't throw away the current set of modules. This would
1053 -- require some re-working of the GHC interface, so we'll leave it
1054 -- as a ToDo for now.
1056 io (GHC.setTargets session targets)
1057 doLoad session False prev_context LoadAllTargets
1059 checkModule :: String -> GHCi ()
1061 let modl = GHC.mkModuleName m
1062 session <- getSession
1063 prev_context <- io $ GHC.getContext session
1064 result <- io (GHC.checkModule session modl False)
1066 Nothing -> io $ putStrLn "Nothing"
1067 Just r -> io $ putStrLn (showSDoc (
1068 case GHC.checkedModuleInfo r of
1069 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1071 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1073 (text "global names: " <+> ppr global) $$
1074 (text "local names: " <+> ppr local)
1076 afterLoad (successIf (isJust result)) session False prev_context
1078 reloadModule :: String -> GHCi ()
1080 session <- getSession
1081 prev_context <- io $ GHC.getContext session
1082 doLoad session True prev_context $
1083 if null m then LoadAllTargets
1084 else LoadUpTo (GHC.mkModuleName m)
1087 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1088 doLoad session retain_context prev_context howmuch = do
1089 -- turn off breakpoints before we load: we can't turn them off later, because
1090 -- the ModBreaks will have gone away.
1091 discardActiveBreakPoints
1092 ok <- io (GHC.load session howmuch)
1093 afterLoad ok session retain_context prev_context
1096 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1097 afterLoad ok session retain_context prev_context = do
1098 revertCAFs -- always revert CAFs on load.
1100 loaded_mod_summaries <- getLoadedModules session
1101 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1102 loaded_mod_names = map GHC.moduleName loaded_mods
1103 modulesLoadedMsg ok loaded_mod_names
1105 setContextAfterLoad session prev_context retain_context loaded_mod_summaries
1108 setContextAfterLoad :: Session -> ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1109 setContextAfterLoad session prev keep_ctxt [] = do
1110 prel_mod <- getPrelude
1111 setContextKeepingPackageModules session prev keep_ctxt ([], [prel_mod])
1112 setContextAfterLoad session prev keep_ctxt ms = do
1113 -- load a target if one is available, otherwise load the topmost module.
1114 targets <- io (GHC.getTargets session)
1115 case [ m | Just m <- map (findTarget ms) targets ] of
1117 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1118 load_this (last graph')
1123 = case filter (`matches` t) ms of
1127 summary `matches` Target (TargetModule m) _
1128 = GHC.ms_mod_name summary == m
1129 summary `matches` Target (TargetFile f _) _
1130 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1134 load_this summary | m <- GHC.ms_mod summary = do
1135 b <- io (GHC.moduleIsInterpreted session m)
1136 if b then setContextKeepingPackageModules session prev keep_ctxt ([m], [])
1138 prel_mod <- getPrelude
1139 setContextKeepingPackageModules session prev keep_ctxt ([],[prel_mod,m])
1141 -- | Keep any package modules (except Prelude) when changing the context.
1142 setContextKeepingPackageModules
1144 -> ([Module],[Module]) -- previous context
1145 -> Bool -- re-execute :module commands
1146 -> ([Module],[Module]) -- new context
1148 setContextKeepingPackageModules session prev_context keep_ctxt (as,bs) = do
1149 let (_,bs0) = prev_context
1150 prel_mod <- getPrelude
1151 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1152 let bs1 = if null as then nub (prel_mod : bs) else bs
1153 io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1157 mapM_ (playCtxtCmd False) (remembered_ctx st)
1160 setGHCiState st{ remembered_ctx = [] }
1162 isHomeModule :: Module -> Bool
1163 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1165 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1166 modulesLoadedMsg ok mods = do
1167 dflags <- getDynFlags
1168 when (verbosity dflags > 0) $ do
1170 | null mods = text "none."
1171 | otherwise = hsep (
1172 punctuate comma (map ppr mods)) <> text "."
1175 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1177 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1180 typeOfExpr :: String -> GHCi ()
1182 = do cms <- getSession
1183 maybe_ty <- io (GHC.exprType cms str)
1185 Nothing -> return ()
1186 Just ty -> do dflags <- getDynFlags
1187 let pefas = dopt Opt_PrintExplicitForalls dflags
1188 printForUser $ text str <+> dcolon
1189 <+> pprTypeForUser pefas ty
1191 kindOfType :: String -> GHCi ()
1193 = do cms <- getSession
1194 maybe_ty <- io (GHC.typeKind cms str)
1196 Nothing -> return ()
1197 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1199 quit :: String -> GHCi Bool
1200 quit _ = return True
1202 shellEscape :: String -> GHCi Bool
1203 shellEscape str = io (system str >> return False)
1205 -----------------------------------------------------------------------------
1206 -- Browsing a module's contents
1208 browseCmd :: Bool -> String -> GHCi ()
1211 ['*':s] | looksLikeModuleName s -> do
1212 m <- wantInterpretedModule s
1213 browseModule bang m False
1214 [s] | looksLikeModuleName s -> do
1216 browseModule bang m True
1219 (as,bs) <- io $ GHC.getContext s
1220 -- Guess which module the user wants to browse. Pick
1221 -- modules that are interpreted first. The most
1222 -- recently-added module occurs last, it seems.
1224 (as@(_:_), _) -> browseModule bang (last as) True
1225 ([], bs@(_:_)) -> browseModule bang (last bs) True
1226 ([], []) -> throwDyn (CmdLineError ":browse: no current module")
1227 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1229 -- without bang, show items in context of their parents and omit children
1230 -- with bang, show class methods and data constructors separately, and
1231 -- indicate import modules, to aid qualifying unqualified names
1232 -- with sorted, sort items alphabetically
1233 browseModule :: Bool -> Module -> Bool -> GHCi ()
1234 browseModule bang modl exports_only = do
1236 -- :browse! reports qualifiers wrt current context
1237 current_unqual <- io (GHC.getPrintUnqual s)
1238 -- Temporarily set the context to the module we're interested in,
1239 -- just so we can get an appropriate PrintUnqualified
1240 (as,bs) <- io (GHC.getContext s)
1241 prel_mod <- getPrelude
1242 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1243 else GHC.setContext s [modl] [])
1244 target_unqual <- io (GHC.getPrintUnqual s)
1245 io (GHC.setContext s as bs)
1247 let unqual = if bang then current_unqual else target_unqual
1249 mb_mod_info <- io $ GHC.getModuleInfo s modl
1251 Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1252 GHC.moduleNameString (GHC.moduleName modl)))
1254 dflags <- getDynFlags
1256 | exports_only = GHC.modInfoExports mod_info
1257 | otherwise = GHC.modInfoTopLevelScope mod_info
1260 -- sort alphabetically name, but putting
1261 -- locally-defined identifiers first.
1262 -- We would like to improve this; see #1799.
1263 sorted_names = loc_sort local ++ occ_sort external
1265 (local,external) = partition ((==modl) . nameModule) names
1266 occ_sort = sortBy (compare `on` nameOccName)
1267 -- try to sort by src location. If the first name in
1268 -- our list has a good source location, then they all should.
1270 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1271 = sortBy (compare `on` nameSrcSpan) names
1275 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1276 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1278 rdr_env <- io $ GHC.getGRE s
1280 let pefas = dopt Opt_PrintExplicitForalls dflags
1281 things | bang = catMaybes mb_things
1282 | otherwise = filtered_things
1283 pretty | bang = pprTyThing
1284 | otherwise = pprTyThingInContext
1286 labels [] = text "-- not currently imported"
1287 labels l = text $ intercalate "\n" $ map qualifier l
1288 qualifier = maybe "-- defined locally"
1289 (("-- imported via "++) . intercalate ", "
1290 . map GHC.moduleNameString)
1291 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1292 modNames = map (importInfo . GHC.getName) things
1294 -- annotate groups of imports with their import modules
1295 -- the default ordering is somewhat arbitrary, so we group
1296 -- by header and sort groups; the names themselves should
1297 -- really come in order of source appearance.. (trac #1799)
1298 annotate mts = concatMap (\(m,ts)->labels m:ts)
1299 $ sortBy cmpQualifiers $ group mts
1300 where cmpQualifiers =
1301 compare `on` (map (fmap (map moduleNameFS)) . fst)
1303 group mts@((m,_):_) = (m,map snd g) : group ng
1304 where (g,ng) = partition ((==m).fst) mts
1306 let prettyThings = map (pretty pefas) things
1307 prettyThings' | bang = annotate $ zip modNames prettyThings
1308 | otherwise = prettyThings
1309 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1310 -- ToDo: modInfoInstances currently throws an exception for
1311 -- package modules. When it works, we can do this:
1312 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1314 -----------------------------------------------------------------------------
1315 -- Setting the module context
1317 setContext :: String -> GHCi ()
1319 | all sensible strs = do
1320 playCtxtCmd True (cmd, as, bs)
1322 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1323 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1325 (cmd, strs, as, bs) =
1327 '+':stuff -> rest AddModules stuff
1328 '-':stuff -> rest RemModules stuff
1329 stuff -> rest SetContext stuff
1331 rest cmd stuff = (cmd, strs, as, bs)
1332 where strs = words stuff
1333 (as,bs) = partitionWith starred strs
1335 sensible ('*':m) = looksLikeModuleName m
1336 sensible m = looksLikeModuleName m
1338 starred ('*':m) = Left m
1341 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1342 playCtxtCmd fail (cmd, as, bs)
1345 (as',bs') <- do_checks fail
1346 (prev_as,prev_bs) <- io $ GHC.getContext s
1350 prel_mod <- getPrelude
1351 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1355 let as_to_add = as' \\ (prev_as ++ prev_bs)
1356 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1357 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1359 let new_as = prev_as \\ (as' ++ bs')
1360 new_bs = prev_bs \\ (as' ++ bs')
1361 return (new_as, new_bs)
1362 io $ GHC.setContext s new_as new_bs
1365 as' <- mapM wantInterpretedModule as
1366 bs' <- mapM lookupModule bs
1368 do_checks False = do
1369 as' <- mapM (trymaybe . wantInterpretedModule) as
1370 bs' <- mapM (trymaybe . lookupModule) bs
1371 return (catMaybes as', catMaybes bs')
1376 Left _ -> return Nothing
1377 Right a -> return (Just a)
1379 ----------------------------------------------------------------------------
1382 -- set options in the interpreter. Syntax is exactly the same as the
1383 -- ghc command line, except that certain options aren't available (-C,
1386 -- This is pretty fragile: most options won't work as expected. ToDo:
1387 -- figure out which ones & disallow them.
1389 setCmd :: String -> GHCi ()
1391 = do st <- getGHCiState
1392 let opts = options st
1393 io $ putStrLn (showSDoc (
1394 text "options currently set: " <>
1397 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1399 dflags <- getDynFlags
1400 io $ putStrLn (showSDoc (
1401 vcat (text "GHCi-specific dynamic flag settings:"
1402 :map (flagSetting dflags) ghciFlags)
1404 io $ putStrLn (showSDoc (
1405 vcat (text "other dynamic, non-language, flag settings:"
1406 :map (flagSetting dflags) nonLanguageDynFlags)
1408 where flagSetting dflags (str,f)
1409 | dopt f dflags = text " " <> text "-f" <> text str
1410 | otherwise = text " " <> text "-fno-" <> text str
1411 (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
1413 nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1415 flags = [Opt_PrintExplicitForalls
1416 ,Opt_PrintBindResult
1417 ,Opt_BreakOnException
1419 ,Opt_PrintEvldWithShow
1422 = case getCmd str of
1423 Right ("args", rest) ->
1425 Left err -> io (hPutStrLn stderr err)
1426 Right args -> setArgs args
1427 Right ("prog", rest) ->
1429 Right [prog] -> setProg prog
1430 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1431 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1432 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1433 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1434 _ -> case toArgs str of
1435 Left err -> io (hPutStrLn stderr err)
1436 Right wds -> setOptions wds
1438 setArgs, setOptions :: [String] -> GHCi ()
1439 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1443 setGHCiState st{ args = args }
1447 setGHCiState st{ progname = prog }
1451 setGHCiState st{ editor = cmd }
1453 setStop str@(c:_) | isDigit c
1454 = do let (nm_str,rest) = break (not.isDigit) str
1457 let old_breaks = breaks st
1458 if all ((/= nm) . fst) old_breaks
1459 then printForUser (text "Breakpoint" <+> ppr nm <+>
1460 text "does not exist")
1462 let new_breaks = map fn old_breaks
1463 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1464 | otherwise = (i,loc)
1465 setGHCiState st{ breaks = new_breaks }
1468 setGHCiState st{ stop = cmd }
1470 setPrompt value = do
1473 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1474 else setGHCiState st{ prompt = remQuotes value }
1476 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1480 do -- first, deal with the GHCi opts (+s, +t, etc.)
1481 let (plus_opts, minus_opts) = partitionWith isPlus wds
1482 mapM_ setOpt plus_opts
1483 -- then, dynamic flags
1484 newDynFlags minus_opts
1486 newDynFlags :: [String] -> GHCi ()
1487 newDynFlags minus_opts = do
1488 dflags <- getDynFlags
1489 let pkg_flags = packageFlags dflags
1490 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1492 if (not (null leftovers))
1493 then throwDyn (CmdLineError ("unrecognised flags: " ++
1497 new_pkgs <- setDynFlags dflags'
1499 -- if the package flags changed, we should reset the context
1500 -- and link the new packages.
1501 dflags <- getDynFlags
1502 when (packageFlags dflags /= pkg_flags) $ do
1503 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1504 session <- getSession
1505 io (GHC.setTargets session [])
1506 io (GHC.load session LoadAllTargets)
1507 io (linkPackages dflags new_pkgs)
1508 -- package flags changed, we can't re-use any of the old context
1509 setContextAfterLoad session ([],[]) False []
1513 unsetOptions :: String -> GHCi ()
1515 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1516 let opts = words str
1517 (minus_opts, rest1) = partition isMinus opts
1518 (plus_opts, rest2) = partitionWith isPlus rest1
1520 if (not (null rest2))
1521 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1524 mapM_ unsetOpt plus_opts
1526 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1527 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1529 no_flags <- mapM no_flag minus_opts
1530 newDynFlags no_flags
1532 isMinus :: String -> Bool
1533 isMinus ('-':_) = True
1536 isPlus :: String -> Either String String
1537 isPlus ('+':opt) = Left opt
1538 isPlus other = Right other
1540 setOpt, unsetOpt :: String -> GHCi ()
1543 = case strToGHCiOpt str of
1544 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1545 Just o -> setOption o
1548 = case strToGHCiOpt str of
1549 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1550 Just o -> unsetOption o
1552 strToGHCiOpt :: String -> (Maybe GHCiOption)
1553 strToGHCiOpt "s" = Just ShowTiming
1554 strToGHCiOpt "t" = Just ShowType
1555 strToGHCiOpt "r" = Just RevertCAFs
1556 strToGHCiOpt _ = Nothing
1558 optToStr :: GHCiOption -> String
1559 optToStr ShowTiming = "s"
1560 optToStr ShowType = "t"
1561 optToStr RevertCAFs = "r"
1563 -- ---------------------------------------------------------------------------
1566 showCmd :: String -> GHCi ()
1570 ["args"] -> io $ putStrLn (show (args st))
1571 ["prog"] -> io $ putStrLn (show (progname st))
1572 ["prompt"] -> io $ putStrLn (show (prompt st))
1573 ["editor"] -> io $ putStrLn (show (editor st))
1574 ["stop"] -> io $ putStrLn (show (stop st))
1575 ["modules" ] -> showModules
1576 ["bindings"] -> showBindings
1577 ["linker"] -> io showLinkerState
1578 ["breaks"] -> showBkptTable
1579 ["context"] -> showContext
1580 ["packages"] -> showPackages
1581 ["languages"] -> showLanguages
1582 _ -> throwDyn (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1583 " | breaks | context | packages | languages ]"))
1585 showModules :: GHCi ()
1587 session <- getSession
1588 loaded_mods <- getLoadedModules session
1589 -- we want *loaded* modules only, see #1734
1590 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1591 mapM_ show_one loaded_mods
1593 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1594 getLoadedModules session = do
1595 graph <- io (GHC.getModuleGraph session)
1596 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1598 showBindings :: GHCi ()
1601 bindings <- io (GHC.getBindings s)
1602 docs <- io$ pprTypeAndContents s
1603 [ id | AnId id <- sortBy compareTyThings bindings]
1604 printForUserPartWay docs
1606 compareTyThings :: TyThing -> TyThing -> Ordering
1607 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1609 printTyThing :: TyThing -> GHCi ()
1610 printTyThing tyth = do dflags <- getDynFlags
1611 let pefas = dopt Opt_PrintExplicitForalls dflags
1612 printForUser (pprTyThing pefas tyth)
1614 showBkptTable :: GHCi ()
1617 printForUser $ prettyLocations (breaks st)
1619 showContext :: GHCi ()
1621 session <- getSession
1622 resumes <- io $ GHC.getResumeContext session
1623 printForUser $ vcat (map pp_resume (reverse resumes))
1626 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1627 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1629 showPackages :: GHCi ()
1631 pkg_flags <- fmap packageFlags getDynFlags
1632 io $ putStrLn $ showSDoc $ vcat $
1633 text ("active package flags:"++if null pkg_flags then " none" else "")
1634 : map showFlag pkg_flags
1635 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1636 io $ putStrLn $ showSDoc $ vcat $
1637 text "packages currently loaded:"
1638 : map (nest 2 . text . packageIdString)
1639 (sortBy (compare `on` packageIdFS) pkg_ids)
1640 where showFlag (ExposePackage p) = text $ " -package " ++ p
1641 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1642 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1644 showLanguages :: GHCi ()
1646 dflags <- getDynFlags
1647 io $ putStrLn $ showSDoc $ vcat $
1648 text "active language flags:" :
1649 [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1651 -- -----------------------------------------------------------------------------
1654 completeNone :: String -> IO [String]
1655 completeNone _w = return []
1657 completeMacro, completeIdentifier, completeModule,
1658 completeHomeModule, completeSetOptions, completeFilename,
1659 completeHomeModuleOrFile
1660 :: String -> IO [String]
1663 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1664 completeWord w start end = do
1665 line <- Readline.getLineBuffer
1666 let line_words = words (dropWhile isSpace line)
1668 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1670 | ((':':c) : _) <- line_words -> do
1671 completionVars <- lookupCompletionVars c
1672 case completionVars of
1673 (Nothing,complete) -> wrapCompleter complete w
1674 (Just breakChars,complete)
1675 -> let (n,w') = selectWord
1676 (words' (`elem` breakChars) 0 line)
1677 complete' w = do rets <- complete w
1678 return (map (drop n) rets)
1679 in wrapCompleter complete' w'
1680 | ("import" : _) <- line_words ->
1681 wrapCompleter completeModule w
1683 --printf "complete %s, start = %d, end = %d\n" w start end
1684 wrapCompleter completeIdentifier w
1685 where words' _ _ [] = []
1686 words' isBreak n str = let (w,r) = break isBreak str
1687 (s,r') = span isBreak r
1688 in (n,w):words' isBreak (n+length w+length s) r'
1689 -- In a Haskell expression we want to parse 'a-b' as three words
1690 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1691 -- only be a single word.
1692 selectWord [] = (0,w)
1693 selectWord ((offset,x):xs)
1694 | offset+length x >= start = (start-offset,take (end-offset) x)
1695 | otherwise = selectWord xs
1697 lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars,
1699 lookupCompletionVars c = do
1700 maybe_cmd <- lookupCommand' c
1702 Just (_,_,ws,f) -> return (ws,f)
1703 Nothing -> return (Just filenameWordBreakChars,
1707 completeCmd :: String -> IO [String]
1709 cmds <- readIORef macros_ref
1710 return (filter (w `isPrefixOf`) (map (':':)
1711 (map cmdName (builtin_commands ++ cmds))))
1713 completeMacro w = do
1714 cmds <- readIORef macros_ref
1715 return (filter (w `isPrefixOf`) (map cmdName cmds))
1717 completeIdentifier w = do
1719 rdrs <- GHC.getRdrNamesInScope s
1720 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1722 completeModule w = do
1724 dflags <- GHC.getSessionDynFlags s
1725 let pkg_mods = allExposedModules dflags
1726 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1728 completeHomeModule w = do
1730 g <- GHC.getModuleGraph s
1731 let home_mods = map GHC.ms_mod_name g
1732 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1734 completeSetOptions w = do
1735 return (filter (w `isPrefixOf`) options)
1736 where options = "args":"prog":allFlags
1738 completeFilename w = do
1739 ws <- Readline.filenameCompletionFunction w
1741 -- If we only found one result, and it's a directory,
1742 -- add a trailing slash.
1744 isDir <- expandPathIO file >>= doesDirectoryExist
1745 if isDir && last file /= '/'
1746 then return [file ++ "/"]
1751 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1753 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1754 unionComplete f1 f2 w = do
1759 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1760 wrapCompleter fun w = do
1763 [] -> Readline.setAttemptedCompletionOver True >> return Nothing
1764 [x] -> -- Add a trailing space, unless it already has an appended slash.
1765 let appended = if last x == '/' then x else x ++ " "
1766 in return (Just (appended,[]))
1767 xs -> case getCommonPrefix xs of
1768 "" -> return (Just ("",xs))
1769 pref -> return (Just (pref,xs))
1771 getCommonPrefix :: [String] -> String
1772 getCommonPrefix [] = ""
1773 getCommonPrefix (s:ss) = foldl common s ss
1774 where common _s "" = ""
1776 common (c:cs) (d:ds)
1777 | c == d = c : common cs ds
1780 allExposedModules :: DynFlags -> [ModuleName]
1781 allExposedModules dflags
1782 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1784 pkg_db = pkgIdMap (pkgState dflags)
1786 completeMacro = completeNone
1787 completeIdentifier = completeNone
1788 completeModule = completeNone
1789 completeHomeModule = completeNone
1790 completeSetOptions = completeNone
1791 completeFilename = completeNone
1792 completeHomeModuleOrFile=completeNone
1795 -- ---------------------------------------------------------------------------
1796 -- User code exception handling
1798 -- This is the exception handler for exceptions generated by the
1799 -- user's code and exceptions coming from children sessions;
1800 -- it normally just prints out the exception. The
1801 -- handler must be recursive, in case showing the exception causes
1802 -- more exceptions to be raised.
1804 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1805 -- raising another exception. We therefore don't put the recursive
1806 -- handler arond the flushing operation, so if stderr is closed
1807 -- GHCi will just die gracefully rather than going into an infinite loop.
1808 handler :: Exception -> GHCi Bool
1810 handler exception = do
1812 io installSignalHandlers
1813 ghciHandle handler (showException exception >> return False)
1815 showException :: Exception -> GHCi ()
1816 showException (DynException dyn) =
1817 case fromDynamic dyn of
1818 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1819 Just Interrupted -> io (putStrLn "Interrupted.")
1820 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1821 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1822 Just other_ghc_ex -> io (print other_ghc_ex)
1824 showException other_exception
1825 = io (putStrLn ("*** Exception: " ++ show other_exception))
1827 -----------------------------------------------------------------------------
1828 -- recursive exception handlers
1830 -- Don't forget to unblock async exceptions in the handler, or if we're
1831 -- in an exception loop (eg. let a = error a in a) the ^C exception
1832 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1834 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1835 ghciHandle h (GHCi m) = GHCi $ \s ->
1836 Exception.catch (m s)
1837 (\e -> unGHCi (ghciUnblock (h e)) s)
1839 ghciUnblock :: GHCi a -> GHCi a
1840 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1842 ghciTry :: GHCi a -> GHCi (Either Exception a)
1843 ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s)
1845 -- ----------------------------------------------------------------------------
1848 expandPath :: String -> GHCi String
1849 expandPath path = io (expandPathIO path)
1851 expandPathIO :: String -> IO String
1853 case dropWhile isSpace path of
1855 tilde <- getHomeDirectory -- will fail if HOME not defined
1856 return (tilde ++ '/':d)
1860 wantInterpretedModule :: String -> GHCi Module
1861 wantInterpretedModule str = do
1862 session <- getSession
1863 modl <- lookupModule str
1864 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1865 when (not is_interpreted) $
1866 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1869 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1870 -> (Name -> GHCi ())
1872 wantNameFromInterpretedModule noCanDo str and_then = do
1873 session <- getSession
1874 names <- io $ GHC.parseName session str
1878 let modl = GHC.nameModule n
1879 if not (GHC.isExternalName n)
1880 then noCanDo n $ ppr n <>
1881 text " is not defined in an interpreted module"
1883 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1884 if not is_interpreted
1885 then noCanDo n $ text "module " <> ppr modl <>
1886 text " is not interpreted"
1889 -- -----------------------------------------------------------------------------
1890 -- commands for debugger
1892 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1893 sprintCmd = pprintCommand False False
1894 printCmd = pprintCommand True False
1895 forceCmd = pprintCommand False True
1897 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1898 pprintCommand bind force str = do
1899 session <- getSession
1900 io $ pprintClosureCommand session bind force str
1902 stepCmd :: String -> GHCi ()
1903 stepCmd [] = doContinue (const True) GHC.SingleStep
1904 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1906 stepLocalCmd :: String -> GHCi ()
1907 stepLocalCmd [] = do
1908 mb_span <- getCurrentBreakSpan
1910 Nothing -> stepCmd []
1912 Just mod <- getCurrentBreakModule
1913 current_toplevel_decl <- enclosingTickSpan mod loc
1914 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1916 stepLocalCmd expression = stepCmd expression
1918 stepModuleCmd :: String -> GHCi ()
1919 stepModuleCmd [] = do
1920 mb_span <- getCurrentBreakSpan
1922 Nothing -> stepCmd []
1924 Just span <- getCurrentBreakSpan
1925 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1926 doContinue f GHC.SingleStep
1928 stepModuleCmd expression = stepCmd expression
1930 -- | Returns the span of the largest tick containing the srcspan given
1931 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1932 enclosingTickSpan mod src = do
1933 ticks <- getTickArray mod
1934 let line = srcSpanStartLine src
1935 ASSERT (inRange (bounds ticks) line) do
1936 let enclosing_spans = [ span | (_,span) <- ticks ! line
1937 , srcSpanEnd span >= srcSpanEnd src]
1938 return . head . sortBy leftmost_largest $ enclosing_spans
1940 traceCmd :: String -> GHCi ()
1941 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1942 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1944 continueCmd :: String -> GHCi ()
1945 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1947 -- doContinue :: SingleStep -> GHCi ()
1948 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1949 doContinue pred step = do
1950 runResult <- resume step
1951 afterRunStmt pred runResult
1954 abandonCmd :: String -> GHCi ()
1955 abandonCmd = noArgs $ do
1957 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1958 when (not b) $ io $ putStrLn "There is no computation running."
1961 deleteCmd :: String -> GHCi ()
1962 deleteCmd argLine = do
1963 deleteSwitch $ words argLine
1965 deleteSwitch :: [String] -> GHCi ()
1967 io $ putStrLn "The delete command requires at least one argument."
1968 -- delete all break points
1969 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1970 deleteSwitch idents = do
1971 mapM_ deleteOneBreak idents
1973 deleteOneBreak :: String -> GHCi ()
1975 | all isDigit str = deleteBreak (read str)
1976 | otherwise = return ()
1978 historyCmd :: String -> GHCi ()
1980 | null arg = history 20
1981 | all isDigit arg = history (read arg)
1982 | otherwise = io $ putStrLn "Syntax: :history [num]"
1986 resumes <- io $ GHC.getResumeContext s
1988 [] -> io $ putStrLn "Not stopped at a breakpoint"
1990 let hist = GHC.resumeHistory r
1991 (took,rest) = splitAt num hist
1993 [] -> io $ putStrLn $
1994 "Empty history. Perhaps you forgot to use :trace?"
1996 spans <- mapM (io . GHC.getHistorySpan s) took
1997 let nums = map (printf "-%-3d:") [(1::Int)..]
1998 names = map GHC.historyEnclosingDecl took
1999 printForUser (vcat(zipWith3
2000 (\x y z -> x <+> y <+> z)
2002 (map (bold . ppr) names)
2003 (map (parens . ppr) spans)))
2004 io $ putStrLn $ if null rest then "<end of history>" else "..."
2006 bold :: SDoc -> SDoc
2007 bold c | do_bold = text start_bold <> c <> text end_bold
2010 backCmd :: String -> GHCi ()
2011 backCmd = noArgs $ do
2013 (names, _, span) <- io $ GHC.back s
2014 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
2015 printTypeOfNames s names
2016 -- run the command set with ":set stop <cmd>"
2018 enqueueCommands [stop st]
2020 forwardCmd :: String -> GHCi ()
2021 forwardCmd = noArgs $ do
2023 (names, ix, span) <- io $ GHC.forward s
2024 printForUser $ (if (ix == 0)
2025 then ptext (sLit "Stopped at")
2026 else ptext (sLit "Logged breakpoint at")) <+> ppr span
2027 printTypeOfNames s names
2028 -- run the command set with ":set stop <cmd>"
2030 enqueueCommands [stop st]
2032 -- handle the "break" command
2033 breakCmd :: String -> GHCi ()
2034 breakCmd argLine = do
2035 session <- getSession
2036 breakSwitch session $ words argLine
2038 breakSwitch :: Session -> [String] -> GHCi ()
2039 breakSwitch _session [] = do
2040 io $ putStrLn "The break command requires at least one argument."
2041 breakSwitch session (arg1:rest)
2042 | looksLikeModuleName arg1 && not (null rest) = do
2043 mod <- wantInterpretedModule arg1
2044 breakByModule mod rest
2045 | all isDigit arg1 = do
2046 (toplevel, _) <- io $ GHC.getContext session
2048 (mod : _) -> breakByModuleLine mod (read arg1) rest
2050 io $ putStrLn "Cannot find default module for breakpoint."
2051 io $ putStrLn "Perhaps no modules are loaded for debugging?"
2052 | otherwise = do -- try parsing it as an identifier
2053 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2054 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2055 if GHC.isGoodSrcLoc loc
2056 then findBreakAndSet (GHC.nameModule name) $
2057 findBreakByCoord (Just (GHC.srcLocFile loc))
2058 (GHC.srcLocLine loc,
2060 else noCanDo name $ text "can't find its location: " <> ppr loc
2062 noCanDo n why = printForUser $
2063 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2065 breakByModule :: Module -> [String] -> GHCi ()
2066 breakByModule mod (arg1:rest)
2067 | all isDigit arg1 = do -- looks like a line number
2068 breakByModuleLine mod (read arg1) rest
2072 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2073 breakByModuleLine mod line args
2074 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2075 | [col] <- args, all isDigit col =
2076 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2077 | otherwise = breakSyntax
2080 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2082 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2083 findBreakAndSet mod lookupTickTree = do
2084 tickArray <- getTickArray mod
2085 (breakArray, _) <- getModBreak mod
2086 case lookupTickTree tickArray of
2087 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2088 Just (tick, span) -> do
2089 success <- io $ setBreakFlag True breakArray tick
2093 recordBreak $ BreakLocation
2100 text "Breakpoint " <> ppr nm <>
2102 then text " was already set at " <> ppr span
2103 else text " activated at " <> ppr span
2105 printForUser $ text "Breakpoint could not be activated at"
2108 -- When a line number is specified, the current policy for choosing
2109 -- the best breakpoint is this:
2110 -- - the leftmost complete subexpression on the specified line, or
2111 -- - the leftmost subexpression starting on the specified line, or
2112 -- - the rightmost subexpression enclosing the specified line
2114 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2115 findBreakByLine line arr
2116 | not (inRange (bounds arr) line) = Nothing
2118 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2119 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2120 listToMaybe (sortBy (rightmost `on` snd) ticks)
2124 starts_here = [ tick | tick@(_,span) <- ticks,
2125 GHC.srcSpanStartLine span == line ]
2127 (complete,incomplete) = partition ends_here starts_here
2128 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2130 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2131 -> Maybe (BreakIndex,SrcSpan)
2132 findBreakByCoord mb_file (line, col) arr
2133 | not (inRange (bounds arr) line) = Nothing
2135 listToMaybe (sortBy (rightmost `on` snd) contains ++
2136 sortBy (leftmost_smallest `on` snd) after_here)
2140 -- the ticks that span this coordinate
2141 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2142 is_correct_file span ]
2144 is_correct_file span
2145 | Just f <- mb_file = GHC.srcSpanFile span == f
2148 after_here = [ tick | tick@(_,span) <- ticks,
2149 GHC.srcSpanStartLine span == line,
2150 GHC.srcSpanStartCol span >= col ]
2152 -- For now, use ANSI bold on terminals that we know support it.
2153 -- Otherwise, we add a line of carets under the active expression instead.
2154 -- In particular, on Windows and when running the testsuite (which sets
2155 -- TERM to vt100 for other reasons) we get carets.
2156 -- We really ought to use a proper termcap/terminfo library.
2158 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2159 where mTerm = System.Environment.getEnv "TERM"
2160 `Exception.catch` \_ -> return "TERM not set"
2162 start_bold :: String
2163 start_bold = "\ESC[1m"
2165 end_bold = "\ESC[0m"
2167 listCmd :: String -> GHCi ()
2169 mb_span <- getCurrentBreakSpan
2172 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2174 | GHC.isGoodSrcSpan span -> io $ listAround span True
2177 resumes <- io $ GHC.getResumeContext s
2179 [] -> panic "No resumes"
2181 do let traceIt = case GHC.resumeHistory r of
2182 [] -> text "rerunning with :trace,"
2184 doWhat = traceIt <+> text ":back then :list"
2185 printForUser (text "Unable to list source for" <+>
2187 $$ text "Try" <+> doWhat)
2188 listCmd str = list2 (words str)
2190 list2 :: [String] -> GHCi ()
2191 list2 [arg] | all isDigit arg = do
2192 session <- getSession
2193 (toplevel, _) <- io $ GHC.getContext session
2195 [] -> io $ putStrLn "No module to list"
2196 (mod : _) -> listModuleLine mod (read arg)
2197 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2198 mod <- wantInterpretedModule arg1
2199 listModuleLine mod (read arg2)
2201 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2202 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2203 if GHC.isGoodSrcLoc loc
2205 tickArray <- getTickArray (GHC.nameModule name)
2206 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2207 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2210 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2211 Just (_,span) -> io $ listAround span False
2213 noCanDo name $ text "can't find its location: " <>
2216 noCanDo n why = printForUser $
2217 text "cannot list source code for " <> ppr n <> text ": " <> why
2219 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2221 listModuleLine :: Module -> Int -> GHCi ()
2222 listModuleLine modl line = do
2223 session <- getSession
2224 graph <- io (GHC.getModuleGraph session)
2225 let this = filter ((== modl) . GHC.ms_mod) graph
2227 [] -> panic "listModuleLine"
2229 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2230 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2231 io $ listAround (GHC.srcLocSpan loc) False
2233 -- | list a section of a source file around a particular SrcSpan.
2234 -- If the highlight flag is True, also highlight the span using
2235 -- start_bold/end_bold.
2236 listAround :: SrcSpan -> Bool -> IO ()
2237 listAround span do_highlight = do
2238 contents <- BS.readFile (unpackFS file)
2240 lines = BS.split '\n' contents
2241 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2242 drop (line1 - 1 - pad_before) $ lines
2243 fst_line = max 1 (line1 - pad_before)
2244 line_nos = [ fst_line .. ]
2246 highlighted | do_highlight = zipWith highlight line_nos these_lines
2247 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2249 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2250 prefixed = zipWith ($) highlighted bs_line_nos
2252 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2254 file = GHC.srcSpanFile span
2255 line1 = GHC.srcSpanStartLine span
2256 col1 = GHC.srcSpanStartCol span
2257 line2 = GHC.srcSpanEndLine span
2258 col2 = GHC.srcSpanEndCol span
2260 pad_before | line1 == 1 = 0
2264 highlight | do_bold = highlight_bold
2265 | otherwise = highlight_carets
2267 highlight_bold no line prefix
2268 | no == line1 && no == line2
2269 = let (a,r) = BS.splitAt col1 line
2270 (b,c) = BS.splitAt (col2-col1) r
2272 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2274 = let (a,b) = BS.splitAt col1 line in
2275 BS.concat [prefix, a, BS.pack start_bold, b]
2277 = let (a,b) = BS.splitAt col2 line in
2278 BS.concat [prefix, a, BS.pack end_bold, b]
2279 | otherwise = BS.concat [prefix, line]
2281 highlight_carets no line prefix
2282 | no == line1 && no == line2
2283 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2284 BS.replicate (col2-col1) '^']
2286 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2289 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2291 | otherwise = BS.concat [prefix, line]
2293 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2294 nl = BS.singleton '\n'
2296 -- --------------------------------------------------------------------------
2299 getTickArray :: Module -> GHCi TickArray
2300 getTickArray modl = do
2302 let arrmap = tickarrays st
2303 case lookupModuleEnv arrmap modl of
2304 Just arr -> return arr
2306 (_breakArray, ticks) <- getModBreak modl
2307 let arr = mkTickArray (assocs ticks)
2308 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2311 discardTickArrays :: GHCi ()
2312 discardTickArrays = do
2314 setGHCiState st{tickarrays = emptyModuleEnv}
2316 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2318 = accumArray (flip (:)) [] (1, max_line)
2319 [ (line, (nm,span)) | (nm,span) <- ticks,
2320 line <- srcSpanLines span ]
2322 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2323 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2324 GHC.srcSpanEndLine span ]
2326 lookupModule :: String -> GHCi Module
2327 lookupModule modName
2328 = do session <- getSession
2329 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2331 -- don't reset the counter back to zero?
2332 discardActiveBreakPoints :: GHCi ()
2333 discardActiveBreakPoints = do
2335 mapM (turnOffBreak.snd) (breaks st)
2336 setGHCiState $ st { breaks = [] }
2338 deleteBreak :: Int -> GHCi ()
2339 deleteBreak identity = do
2341 let oldLocations = breaks st
2342 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2344 then printForUser (text "Breakpoint" <+> ppr identity <+>
2345 text "does not exist")
2347 mapM (turnOffBreak.snd) this
2348 setGHCiState $ st { breaks = rest }
2350 turnOffBreak :: BreakLocation -> GHCi Bool
2351 turnOffBreak loc = do
2352 (arr, _) <- getModBreak (breakModule loc)
2353 io $ setBreakFlag False arr (breakTick loc)
2355 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2356 getModBreak mod = do
2357 session <- getSession
2358 Just mod_info <- io $ GHC.getModuleInfo session mod
2359 let modBreaks = GHC.modInfoModBreaks mod_info
2360 let array = GHC.modBreaks_flags modBreaks
2361 let ticks = GHC.modBreaks_locs modBreaks
2362 return (array, ticks)
2364 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2365 setBreakFlag toggle array index
2366 | toggle = GHC.setBreakOn array index
2367 | otherwise = GHC.setBreakOff array index