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"
20 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
21 Module, ModuleName, TyThing(..), Phase,
22 BreakIndex, SrcSpan, Resume, SingleStep )
32 import HscTypes ( implicitTyThings )
33 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
34 import Outputable hiding (printForUser, printForUserPartWay)
35 import Module -- for ModuleEnv
39 -- Other random utilities
41 import BasicTypes hiding (isTopLevel)
42 import Panic hiding (showException)
48 import Maybes ( orElse )
52 #ifndef mingw32_HOST_OS
53 import System.Posix hiding (getEnv)
55 import GHC.ConsoleHandler ( flushConsole )
56 import qualified System.Win32
60 import Control.Concurrent ( yield ) -- Used in readline loop
61 import System.Console.Readline as Readline
66 import Control.Exception as Exception
67 -- import Control.Concurrent
69 import System.FilePath
70 import qualified Data.ByteString.Char8 as BS
74 import System.Environment
75 import System.Exit ( exitWith, ExitCode(..) )
76 import System.Directory
78 import System.IO.Error as IO
82 import Control.Monad as Monad
86 import GHC.Exts ( unsafeCoerce# )
87 import GHC.IOBase ( IOErrorType(InvalidArgument) )
90 import Data.IORef ( IORef, readIORef, writeIORef )
93 import System.Posix.Internals ( setNonBlockingFD )
96 -----------------------------------------------------------------------------
98 ghciWelcomeMsg :: String
99 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
100 ": http://www.haskell.org/ghc/ :? for help"
102 cmdName :: Command -> String
103 cmdName (n,_,_,_) = n
105 macros_ref :: IORef [Command]
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 " :print [<name> ...] prints a value without forcing its computation\n" ++
233 " :sprint [<name> ...] simplifed version of :print\n" ++
234 " :step single-step after stopping at a breakpoint\n"++
235 " :step <expr> single-step into <expr>\n"++
236 " :steplocal single-step within the current top-level binding\n"++
237 " :stepmodule single-step restricted to the current module\n"++
238 " :trace trace after stopping at a breakpoint\n"++
239 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
242 " -- Commands for changing settings:\n" ++
244 " :set <option> ... set options\n" ++
245 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
246 " :set prog <progname> set the value returned by System.getProgName\n" ++
247 " :set prompt <prompt> set the prompt used in GHCi\n" ++
248 " :set editor <cmd> set the command used for :edit\n" ++
249 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
250 " :unset <option> ... unset options\n" ++
252 " Options for ':set' and ':unset':\n" ++
254 " +r revert top-level expressions after each evaluation\n" ++
255 " +s print timing/memory stats after each evaluation\n" ++
256 " +t print type after evaluation\n" ++
257 " -<flags> most GHC command line flags can also be set here\n" ++
258 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
259 " for GHCi-specific flags, see User's Guide,\n"++
260 " Flag reference, Interactive-mode options\n" ++
262 " -- Commands for displaying information:\n" ++
264 " :show bindings show the current bindings made at the prompt\n" ++
265 " :show breaks show the active breakpoints\n" ++
266 " :show context show the breakpoint context\n" ++
267 " :show modules show the currently loaded modules\n" ++
268 " :show packages show the currently active package flags\n" ++
269 " :show languages show the currently active language flags\n" ++
270 " :show <setting> show value of <setting>, which is one of\n" ++
271 " [args, prog, prompt, editor, stop]\n" ++
274 findEditor :: IO String
279 win <- System.Win32.getWindowsDirectory
280 return (win </> "notepad.exe")
285 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String]
287 interactiveUI session srcs maybe_exprs = do
288 -- HACK! If we happen to get into an infinite loop (eg the user
289 -- types 'let x=x in x' at the prompt), then the thread will block
290 -- on a blackhole, and become unreachable during GC. The GC will
291 -- detect that it is unreachable and send it the NonTermination
292 -- exception. However, since the thread is unreachable, everything
293 -- it refers to might be finalized, including the standard Handles.
294 -- This sounds like a bug, but we don't have a good solution right
300 -- Initialise buffering for the *interpreted* I/O system
301 initInterpBuffering session
303 when (isNothing maybe_exprs) $ do
304 -- Only for GHCi (not runghc and ghc -e):
306 -- Turn buffering off for the compiled program's stdout/stderr
308 -- Turn buffering off for GHCi's stdout
310 hSetBuffering stdout NoBuffering
311 -- We don't want the cmd line to buffer any input that might be
312 -- intended for the program, so unbuffer stdin.
313 hSetBuffering stdin NoBuffering
316 is_tty <- hIsTerminalDevice stdin
319 Readline.setAttemptedCompletionFunction (Just completeWord)
320 --Readline.parseAndBind "set show-all-if-ambiguous 1"
322 Readline.setBasicWordBreakCharacters word_break_chars
323 Readline.setCompleterWordBreakCharacters word_break_chars
324 Readline.setCompletionAppendCharacter Nothing
327 -- initial context is just the Prelude
328 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
330 GHC.setContext session [] [prel_mod]
332 default_editor <- findEditor
334 startGHCi (runGHCi srcs maybe_exprs)
335 GHCiState{ progname = "<interactive>",
339 editor = default_editor,
345 tickarrays = emptyModuleEnv,
346 last_command = Nothing,
352 Readline.resetTerminal Nothing
357 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
358 runGHCi paths maybe_exprs = do
360 read_dot_files = not opt_IgnoreDotGhci
362 current_dir = return (Just ".ghci")
365 either_dir <- io $ IO.try (getAppUserDataDirectory "ghc")
367 Right dir -> return (Just (dir </> "ghci.conf"))
371 either_dir <- io $ IO.try (getEnv "HOME")
373 Right home -> return (Just (home </> ".ghci"))
376 sourceConfigFile :: FilePath -> GHCi ()
377 sourceConfigFile file = do
378 exists <- io $ doesFileExist file
380 dir_ok <- io $ checkPerms (getDirectory file)
381 file_ok <- io $ checkPerms file
382 when (dir_ok && file_ok) $ do
383 either_hdl <- io $ IO.try (openFile file ReadMode)
386 Right hdl -> runCommands (fileLoop hdl False False)
388 getDirectory f = case takeDirectory f of "" -> "."; d -> d
390 when (read_dot_files) $ do
391 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
392 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
393 mapM_ sourceConfigFile (nub cfgs)
394 -- nub, because we don't want to read .ghci twice if the
397 -- Perform a :load for files given on the GHCi command line
398 -- When in -e mode, if the load fails then we want to stop
399 -- immediately rather than going on to evaluate the expression.
400 when (not (null paths)) $ do
401 ok <- ghciHandle (\e -> do showException e; return Failed) $
403 when (isJust maybe_exprs && failed ok) $
404 io (exitWith (ExitFailure 1))
406 -- if verbosity is greater than 0, or we are connected to a
407 -- terminal, display the prompt in the interactive loop.
408 is_tty <- io (hIsTerminalDevice stdin)
409 dflags <- getDynFlags
410 let show_prompt = verbosity dflags > 0 || is_tty
415 #if defined(mingw32_HOST_OS)
416 -- The win32 Console API mutates the first character of
417 -- type-ahead when reading from it in a non-buffered manner. Work
418 -- around this by flushing the input buffer of type-ahead characters,
419 -- but only if stdin is available.
420 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
422 Left err | isDoesNotExistError err -> return ()
423 | otherwise -> io (ioError err)
424 Right () -> return ()
426 -- enter the interactive loop
427 interactiveLoop is_tty show_prompt
429 -- just evaluate the expression we were given
430 enqueueCommands exprs
431 let handle e = do st <- getGHCiState
432 -- Jump through some hoops to get the
433 -- current progname in the exception text:
434 -- <progname>: <exception>
435 io $ withProgName (progname st)
436 -- The "fast exit" part just calls exit()
437 -- directly instead of doing an orderly
438 -- runtime shutdown, otherwise the main
439 -- GHCi thread will complain about being
441 $ topHandlerFastExit e
442 runCommands' handle (return Nothing)
445 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
447 interactiveLoop :: Bool -> Bool -> GHCi ()
448 interactiveLoop is_tty show_prompt =
449 -- Ignore ^C exceptions caught here
450 ghciHandleDyn (\e -> case e of
452 #if defined(mingw32_HOST_OS)
455 interactiveLoop is_tty show_prompt
456 _other -> return ()) $
458 ghciUnblock $ do -- unblock necessary if we recursed from the
459 -- exception handler above.
461 -- read commands from stdin
464 then runCommands readlineLoop
465 else runCommands (fileLoop stdin show_prompt is_tty)
467 runCommands (fileLoop stdin show_prompt is_tty)
471 -- NOTE: We only read .ghci files if they are owned by the current user,
472 -- and aren't world writable. Otherwise, we could be accidentally
473 -- running code planted by a malicious third party.
475 -- Furthermore, We only read ./.ghci if . is owned by the current user
476 -- and isn't writable by anyone else. I think this is sufficient: we
477 -- don't need to check .. and ../.. etc. because "." always refers to
478 -- the same directory while a process is running.
480 checkPerms :: String -> IO Bool
481 #ifdef mingw32_HOST_OS
486 Util.handle (\_ -> return False) $ do
487 st <- getFileStatus name
489 if fileOwner st /= me then do
490 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
493 let mode = fileMode st
494 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
495 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
497 putStrLn $ "*** WARNING: " ++ name ++
498 " is writable by someone else, IGNORING!"
503 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
504 fileLoop hdl show_prompt is_tty = do
505 when show_prompt $ do
508 l <- io (IO.try (hGetLine hdl))
510 Left e | isEOFError e -> return Nothing
511 | InvalidArgument <- etype -> return Nothing
512 | otherwise -> io (ioError e)
513 where etype = ioeGetErrorType e
514 -- treat InvalidArgument in the same way as EOF:
515 -- this can happen if the user closed stdin, or
516 -- perhaps did getContents which closes stdin at
519 str <- io $ consoleInputToUnicode is_tty l
522 #ifdef mingw32_HOST_OS
523 -- Convert the console input into Unicode according to the current code page.
524 -- The Windows console stores Unicode characters directly, so this is a
525 -- rather roundabout way of doing things... oh well.
526 -- See #782, #1483, #1649
527 consoleInputToUnicode :: Bool -> String -> IO String
528 consoleInputToUnicode is_tty str
530 cp <- System.Win32.getConsoleCP
531 System.Win32.stringToUnicode cp str
533 decodeStringAsUTF8 str
535 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
537 consoleInputToUnicode :: Bool -> String -> IO String
538 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
541 decodeStringAsUTF8 :: String -> IO String
542 decodeStringAsUTF8 str =
543 withCStringLen str $ \(cstr,len) ->
544 utf8DecodeString (castPtr cstr :: Ptr Word8) len
546 mkPrompt :: GHCi String
548 session <- getSession
549 (toplevs,exports) <- io (GHC.getContext session)
550 resumes <- io $ GHC.getResumeContext session
551 -- st <- getGHCiState
557 let ix = GHC.resumeHistoryIx r
559 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
561 let hist = GHC.resumeHistory r !! (ix-1)
562 span <- io$ GHC.getHistorySpan session hist
563 return (brackets (ppr (negate ix) <> char ':'
564 <+> ppr span) <> space)
566 dots | _:rs <- resumes, not (null rs) = text "... "
573 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
574 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
575 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
576 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
577 hsep (map (ppr . GHC.moduleName) exports)
579 deflt_prompt = dots <> context_bit <> modules_bit
581 f ('%':'s':xs) = deflt_prompt <> f xs
582 f ('%':'%':xs) = char '%' <> f xs
583 f (x:xs) = char x <> f xs
587 return (showSDoc (f (prompt st)))
591 readlineLoop :: GHCi (Maybe String)
594 saveSession -- for use by completion
596 l <- io (readline prompt `finally` setNonBlockingFD 0)
597 -- readline sometimes puts stdin into blocking mode,
598 -- so we need to put it back for the IO library
601 Nothing -> return Nothing
604 str <- io $ consoleInputToUnicode True l
608 queryQueue :: GHCi (Maybe String)
613 c:cs -> do setGHCiState st{ cmdqueue = cs }
616 runCommands :: GHCi (Maybe String) -> GHCi ()
617 runCommands = runCommands' handler
619 runCommands' :: (Exception -> GHCi Bool) -- Exception handler
620 -> GHCi (Maybe String) -> GHCi ()
621 runCommands' eh getCmd = do
622 mb_cmd <- noSpace queryQueue
623 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
627 b <- ghciHandle eh (doCommand c)
628 if b then return () else runCommands' eh getCmd
630 noSpace q = q >>= maybe (return Nothing)
631 (\c->case removeSpaces c of
633 ":{" -> multiLineCmd q
634 c -> return (Just c) )
638 setGHCiState st{ prompt = "%s| " }
639 mb_cmd <- collectCommand q ""
640 getGHCiState >>= \st->setGHCiState st{ prompt = p }
642 -- we can't use removeSpaces for the sublines here, so
643 -- multiline commands are somewhat more brittle against
644 -- fileformat errors (such as \r in dos input on unix),
645 -- we get rid of any extra spaces for the ":}" test;
646 -- we also avoid silent failure if ":}" is not found;
647 -- and since there is no (?) valid occurrence of \r (as
648 -- opposed to its String representation, "\r") inside a
649 -- ghci command, we replace any such with ' ' (argh:-(
650 collectCommand q c = q >>=
651 maybe (io (ioError collectError))
652 (\l->if removeSpaces l == ":}"
653 then return (Just $ removeSpaces c)
654 else collectCommand q (c++map normSpace l))
655 where normSpace '\r' = ' '
657 -- QUESTION: is userError the one to use here?
658 collectError = userError "unterminated multiline command :{ .. :}"
659 doCommand (':' : cmd) = specialCommand cmd
660 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
663 enqueueCommands :: [String] -> GHCi ()
664 enqueueCommands cmds = do
666 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
669 runStmt :: String -> SingleStep -> GHCi Bool
671 | null (filter (not.isSpace) stmt) = return False
672 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
674 = do st <- getGHCiState
675 session <- getSession
676 result <- io $ withProgName (progname st) $ withArgs (args st) $
677 GHC.runStmt session stmt step
678 afterRunStmt (const True) result
681 --afterRunStmt :: GHC.RunResult -> GHCi Bool
682 -- False <=> the statement failed to compile
683 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
684 afterRunStmt _ (GHC.RunException e) = throw e
685 afterRunStmt step_here run_result = do
686 session <- getSession
687 resumes <- io $ GHC.getResumeContext session
689 GHC.RunOk names -> do
690 show_types <- isOptionSet ShowType
691 when show_types $ printTypeOfNames session names
692 GHC.RunBreak _ names mb_info
693 | isNothing mb_info ||
694 step_here (GHC.resumeSpan $ head resumes) -> do
695 printForUser $ ptext SLIT("Stopped at") <+>
696 ppr (GHC.resumeSpan $ head resumes)
697 -- printTypeOfNames session names
698 let namesSorted = sortBy compareNames names
699 tythings <- catMaybes `liftM`
700 io (mapM (GHC.lookupName session) namesSorted)
701 docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
702 printForUserPartWay docs
703 maybe (return ()) runBreakCmd mb_info
704 -- run the command set with ":set stop <cmd>"
706 enqueueCommands [stop st]
708 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
709 afterRunStmt step_here >> return ()
713 io installSignalHandlers
714 b <- isOptionSet RevertCAFs
715 io (when b revertCAFs)
717 return (case run_result of GHC.RunOk _ -> True; _ -> False)
719 runBreakCmd :: GHC.BreakInfo -> GHCi ()
720 runBreakCmd info = do
721 let mod = GHC.breakInfo_module info
722 nm = GHC.breakInfo_number info
724 case [ loc | (_,loc) <- breaks st,
725 breakModule loc == mod, breakTick loc == nm ] of
727 loc:_ | null cmd -> return ()
728 | otherwise -> do enqueueCommands [cmd]; return ()
729 where cmd = onBreakCmd loc
731 printTypeOfNames :: Session -> [Name] -> GHCi ()
732 printTypeOfNames session names
733 = mapM_ (printTypeOfName session) $ sortBy compareNames names
735 compareNames :: Name -> Name -> Ordering
736 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
737 where compareWith n = (getOccString n, getSrcSpan n)
739 printTypeOfName :: Session -> Name -> GHCi ()
740 printTypeOfName session n
741 = do maybe_tything <- io (GHC.lookupName session n)
742 case maybe_tything of
744 Just thing -> printTyThing thing
747 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
749 specialCommand :: String -> GHCi Bool
750 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
751 specialCommand str = do
752 let (cmd,rest) = break isSpace str
753 maybe_cmd <- lookupCommand cmd
755 GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
757 do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
761 do io $ hPutStr stdout ("there is no last command to perform\n"
765 lookupCommand :: String -> GHCi (MaybeCommand)
766 lookupCommand "" = do
768 case last_command st of
769 Just c -> return $ GotCommand c
770 Nothing -> return NoLastCommand
771 lookupCommand str = do
772 mc <- io $ lookupCommand' str
774 setGHCiState st{ last_command = mc }
776 Just c -> GotCommand c
777 Nothing -> BadCommand
779 lookupCommand' :: String -> IO (Maybe Command)
780 lookupCommand' str = do
781 macros <- readIORef macros_ref
782 let cmds = builtin_commands ++ macros
783 -- look for exact match first, then the first prefix match
784 return $ case [ c | c <- cmds, str == cmdName c ] of
786 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
790 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
791 getCurrentBreakSpan = do
792 session <- getSession
793 resumes <- io $ GHC.getResumeContext session
797 let ix = GHC.resumeHistoryIx r
799 then return (Just (GHC.resumeSpan r))
801 let hist = GHC.resumeHistory r !! (ix-1)
802 span <- io $ GHC.getHistorySpan session hist
805 getCurrentBreakModule :: GHCi (Maybe Module)
806 getCurrentBreakModule = do
807 session <- getSession
808 resumes <- io $ GHC.getResumeContext session
812 let ix = GHC.resumeHistoryIx r
814 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
816 let hist = GHC.resumeHistory r !! (ix-1)
817 return $ Just $ GHC.getHistoryModule hist
819 -----------------------------------------------------------------------------
822 noArgs :: GHCi () -> String -> GHCi ()
824 noArgs _ _ = io $ putStrLn "This command takes no arguments"
826 help :: String -> GHCi ()
827 help _ = io (putStr helpText)
829 info :: String -> GHCi ()
830 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
831 info s = do { let names = words s
832 ; session <- getSession
833 ; dflags <- getDynFlags
834 ; let pefas = dopt Opt_PrintExplicitForalls dflags
835 ; mapM_ (infoThing pefas session) names }
837 infoThing pefas session str = io $ do
838 names <- GHC.parseName session str
839 mb_stuffs <- mapM (GHC.getInfo session) names
840 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
841 unqual <- GHC.getPrintUnqual session
842 putStrLn (showSDocForUser unqual $
843 vcat (intersperse (text "") $
844 map (pprInfo pefas) filtered))
846 -- Filter out names whose parent is also there Good
847 -- example is '[]', which is both a type and data
848 -- constructor in the same type
849 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
850 filterOutChildren get_thing xs
851 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
853 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
855 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
856 pprInfo pefas (thing, fixity, insts)
857 = pprTyThingInContextLoc pefas thing
858 $$ show_fixity fixity
859 $$ vcat (map GHC.pprInstance insts)
862 | fix == GHC.defaultFixity = empty
863 | otherwise = ppr fix <+> ppr (GHC.getName thing)
865 runMain :: String -> GHCi ()
866 runMain s = case toArgs s of
867 Left err -> io (hPutStrLn stderr err)
869 do dflags <- getDynFlags
870 case mainFunIs dflags of
871 Nothing -> doWithArgs args "main"
872 Just f -> doWithArgs args f
874 runRun :: String -> GHCi ()
875 runRun s = case toCmdArgs s of
876 Left err -> io (hPutStrLn stderr err)
877 Right (cmd, args) -> doWithArgs args cmd
879 doWithArgs :: [String] -> String -> GHCi ()
880 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
881 show args ++ " (" ++ cmd ++ ")"]
883 addModule :: [FilePath] -> GHCi ()
885 io (revertCAFs) -- always revert CAFs on load/add.
886 files <- mapM expandPath files
887 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
888 session <- getSession
889 io (mapM_ (GHC.addTarget session) targets)
890 prev_context <- io $ GHC.getContext session
891 ok <- io (GHC.load session LoadAllTargets)
892 afterLoad ok session False prev_context
894 changeDirectory :: String -> GHCi ()
895 changeDirectory "" = do
896 -- :cd on its own changes to the user's home directory
897 either_dir <- io (IO.try getHomeDirectory)
900 Right dir -> changeDirectory dir
901 changeDirectory dir = do
902 session <- getSession
903 graph <- io (GHC.getModuleGraph session)
904 when (not (null graph)) $
905 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
906 prev_context <- io $ GHC.getContext session
907 io (GHC.setTargets session [])
908 io (GHC.load session LoadAllTargets)
909 setContextAfterLoad session prev_context False []
910 io (GHC.workingDirectoryChanged session)
911 dir <- expandPath dir
912 io (setCurrentDirectory dir)
914 editFile :: String -> GHCi ()
916 do file <- if null str then chooseEditFile else return str
920 $ throwDyn (CmdLineError "editor not set, use :set editor")
921 io $ system (cmd ++ ' ':file)
924 -- The user didn't specify a file so we pick one for them.
925 -- Our strategy is to pick the first module that failed to load,
926 -- or otherwise the first target.
928 -- XXX: Can we figure out what happened if the depndecy analysis fails
929 -- (e.g., because the porgrammeer mistyped the name of a module)?
930 -- XXX: Can we figure out the location of an error to pass to the editor?
931 -- XXX: if we could figure out the list of errors that occured during the
932 -- last load/reaload, then we could start the editor focused on the first
934 chooseEditFile :: GHCi String
936 do session <- getSession
937 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
939 graph <- io (GHC.getModuleGraph session)
940 failed_graph <- filterM hasFailed graph
941 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
943 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
946 case pick (order failed_graph) of
947 Just file -> return file
949 do targets <- io (GHC.getTargets session)
950 case msum (map fromTarget targets) of
951 Just file -> return file
952 Nothing -> throwDyn (CmdLineError "No files to edit.")
954 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
955 fromTarget _ = Nothing -- when would we get a module target?
957 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
958 defineMacro overwrite s = do
959 let (macro_name, definition) = break isSpace s
960 macros <- io (readIORef macros_ref)
961 let defined = map cmdName macros
964 then io $ putStrLn "no macros defined"
965 else io $ putStr ("the following macros are defined:\n" ++
968 if (not overwrite && macro_name `elem` defined)
969 then throwDyn (CmdLineError
970 ("macro '" ++ macro_name ++ "' is already defined"))
973 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
975 -- give the expression a type signature, so we can be sure we're getting
976 -- something of the right type.
977 let new_expr = '(' : definition ++ ") :: String -> IO String"
979 -- compile the expression
981 maybe_hv <- io (GHC.compileExpr cms new_expr)
984 Just hv -> io (writeIORef macros_ref --
985 (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)]))
987 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
989 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
990 enqueueCommands (lines str)
993 undefineMacro :: String -> GHCi ()
994 undefineMacro str = mapM_ undef (words str)
995 where undef macro_name = do
996 cmds <- io (readIORef macros_ref)
997 if (macro_name `notElem` map cmdName cmds)
998 then throwDyn (CmdLineError
999 ("macro '" ++ macro_name ++ "' is not defined"))
1001 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
1003 cmdCmd :: String -> GHCi ()
1005 let expr = '(' : str ++ ") :: IO String"
1006 session <- getSession
1007 maybe_hv <- io (GHC.compileExpr session expr)
1009 Nothing -> return ()
1011 cmds <- io $ (unsafeCoerce# hv :: IO String)
1012 enqueueCommands (lines cmds)
1015 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1016 loadModule fs = timeIt (loadModule' fs)
1018 loadModule_ :: [FilePath] -> GHCi ()
1019 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
1021 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1022 loadModule' files = do
1023 session <- getSession
1024 prev_context <- io $ GHC.getContext session
1027 discardActiveBreakPoints
1028 io (GHC.setTargets session [])
1029 io (GHC.load session LoadAllTargets)
1032 let (filenames, phases) = unzip files
1033 exp_filenames <- mapM expandPath filenames
1034 let files' = zip exp_filenames phases
1035 targets <- io (mapM (uncurry GHC.guessTarget) files')
1037 -- NOTE: we used to do the dependency anal first, so that if it
1038 -- fails we didn't throw away the current set of modules. This would
1039 -- require some re-working of the GHC interface, so we'll leave it
1040 -- as a ToDo for now.
1042 io (GHC.setTargets session targets)
1043 doLoad session False prev_context LoadAllTargets
1045 checkModule :: String -> GHCi ()
1047 let modl = GHC.mkModuleName m
1048 session <- getSession
1049 prev_context <- io $ GHC.getContext session
1050 result <- io (GHC.checkModule session modl False)
1052 Nothing -> io $ putStrLn "Nothing"
1053 Just r -> io $ putStrLn (showSDoc (
1054 case GHC.checkedModuleInfo r of
1055 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1057 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1059 (text "global names: " <+> ppr global) $$
1060 (text "local names: " <+> ppr local)
1062 afterLoad (successIf (isJust result)) session False prev_context
1064 reloadModule :: String -> GHCi ()
1066 session <- getSession
1067 prev_context <- io $ GHC.getContext session
1068 doLoad session True prev_context $
1069 if null m then LoadAllTargets
1070 else LoadUpTo (GHC.mkModuleName m)
1073 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1074 doLoad session retain_context prev_context howmuch = do
1075 -- turn off breakpoints before we load: we can't turn them off later, because
1076 -- the ModBreaks will have gone away.
1077 discardActiveBreakPoints
1078 ok <- io (GHC.load session howmuch)
1079 afterLoad ok session retain_context prev_context
1082 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1083 afterLoad ok session retain_context prev_context = do
1084 io (revertCAFs) -- always revert CAFs on load.
1086 loaded_mod_summaries <- getLoadedModules session
1087 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1088 loaded_mod_names = map GHC.moduleName loaded_mods
1089 modulesLoadedMsg ok loaded_mod_names
1091 setContextAfterLoad session prev_context retain_context loaded_mod_summaries
1094 setContextAfterLoad :: Session -> ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1095 setContextAfterLoad session prev keep_ctxt [] = do
1096 prel_mod <- getPrelude
1097 setContextKeepingPackageModules session prev keep_ctxt ([], [prel_mod])
1098 setContextAfterLoad session prev keep_ctxt ms = do
1099 -- load a target if one is available, otherwise load the topmost module.
1100 targets <- io (GHC.getTargets session)
1101 case [ m | Just m <- map (findTarget ms) targets ] of
1103 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1104 load_this (last graph')
1109 = case filter (`matches` t) ms of
1113 summary `matches` Target (TargetModule m) _
1114 = GHC.ms_mod_name summary == m
1115 summary `matches` Target (TargetFile f _) _
1116 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1120 load_this summary | m <- GHC.ms_mod summary = do
1121 b <- io (GHC.moduleIsInterpreted session m)
1122 if b then setContextKeepingPackageModules session prev keep_ctxt ([m], [])
1124 prel_mod <- getPrelude
1125 setContextKeepingPackageModules session prev keep_ctxt ([],[prel_mod,m])
1127 -- | Keep any package modules (except Prelude) when changing the context.
1128 setContextKeepingPackageModules
1130 -> ([Module],[Module]) -- previous context
1131 -> Bool -- re-execute :module commands
1132 -> ([Module],[Module]) -- new context
1134 setContextKeepingPackageModules session prev_context keep_ctxt (as,bs) = do
1135 let (_,bs0) = prev_context
1136 prel_mod <- getPrelude
1137 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1138 let bs1 = if null as then nub (prel_mod : bs) else bs
1139 io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1143 mapM_ (playCtxtCmd False) (remembered_ctx st)
1146 setGHCiState st{ remembered_ctx = [] }
1148 isHomeModule :: Module -> Bool
1149 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1151 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1152 modulesLoadedMsg ok mods = do
1153 dflags <- getDynFlags
1154 when (verbosity dflags > 0) $ do
1156 | null mods = text "none."
1157 | otherwise = hsep (
1158 punctuate comma (map ppr mods)) <> text "."
1161 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1163 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1166 typeOfExpr :: String -> GHCi ()
1168 = do cms <- getSession
1169 maybe_ty <- io (GHC.exprType cms str)
1171 Nothing -> return ()
1172 Just ty -> do dflags <- getDynFlags
1173 let pefas = dopt Opt_PrintExplicitForalls dflags
1174 printForUser $ text str <+> dcolon
1175 <+> pprTypeForUser pefas ty
1177 kindOfType :: String -> GHCi ()
1179 = do cms <- getSession
1180 maybe_ty <- io (GHC.typeKind cms str)
1182 Nothing -> return ()
1183 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1185 quit :: String -> GHCi Bool
1186 quit _ = return True
1188 shellEscape :: String -> GHCi Bool
1189 shellEscape str = io (system str >> return False)
1191 -----------------------------------------------------------------------------
1192 -- Browsing a module's contents
1194 browseCmd :: Bool -> String -> GHCi ()
1197 ['*':s] | looksLikeModuleName s -> do
1198 m <- wantInterpretedModule s
1199 browseModule bang m False
1200 [s] | looksLikeModuleName s -> do
1202 browseModule bang m True
1205 (as,bs) <- io $ GHC.getContext s
1206 -- Guess which module the user wants to browse. Pick
1207 -- modules that are interpreted first. The most
1208 -- recently-added module occurs last, it seems.
1210 (as@(_:_), _) -> browseModule bang (last as) True
1211 ([], bs@(_:_)) -> browseModule bang (last bs) True
1212 ([], []) -> throwDyn (CmdLineError ":browse: no current module")
1213 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1215 -- without bang, show items in context of their parents and omit children
1216 -- with bang, show class methods and data constructors separately, and
1217 -- indicate import modules, to aid qualifying unqualified names
1218 -- with sorted, sort items alphabetically
1219 browseModule :: Bool -> Module -> Bool -> GHCi ()
1220 browseModule bang modl exports_only = do
1222 -- :browse! reports qualifiers wrt current context
1223 current_unqual <- io (GHC.getPrintUnqual s)
1224 -- Temporarily set the context to the module we're interested in,
1225 -- just so we can get an appropriate PrintUnqualified
1226 (as,bs) <- io (GHC.getContext s)
1227 prel_mod <- getPrelude
1228 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1229 else GHC.setContext s [modl] [])
1230 target_unqual <- io (GHC.getPrintUnqual s)
1231 io (GHC.setContext s as bs)
1233 let unqual = if bang then current_unqual else target_unqual
1235 mb_mod_info <- io $ GHC.getModuleInfo s modl
1237 Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1238 GHC.moduleNameString (GHC.moduleName modl)))
1240 dflags <- getDynFlags
1242 | exports_only = GHC.modInfoExports mod_info
1243 | otherwise = GHC.modInfoTopLevelScope mod_info
1246 -- sort alphabetically name, but putting
1247 -- locally-defined identifiers first.
1248 -- We would like to improve this; see #1799.
1249 sorted_names = loc_sort local ++ occ_sort external
1251 (local,external) = partition ((==modl) . nameModule) names
1252 occ_sort = sortBy (compare `on` nameOccName)
1253 -- try to sort by src location. If the first name in
1254 -- our list has a good source location, then they all should.
1256 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1257 = sortBy (compare `on` nameSrcSpan) names
1261 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1262 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1264 rdr_env <- io $ GHC.getGRE s
1266 let pefas = dopt Opt_PrintExplicitForalls dflags
1267 things | bang = catMaybes mb_things
1268 | otherwise = filtered_things
1269 pretty | bang = pprTyThing
1270 | otherwise = pprTyThingInContext
1272 labels [] = text "-- not currently imported"
1273 labels l = text $ intercalate "\n" $ map qualifier l
1274 qualifier = maybe "-- defined locally"
1275 (("-- imported via "++) . intercalate ", "
1276 . map GHC.moduleNameString)
1277 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1278 modNames = map (importInfo . GHC.getName) things
1280 -- annotate groups of imports with their import modules
1281 -- the default ordering is somewhat arbitrary, so we group
1282 -- by header and sort groups; the names themselves should
1283 -- really come in order of source appearance.. (trac #1799)
1284 annotate mts = concatMap (\(m,ts)->labels m:ts)
1285 $ sortBy cmpQualifiers $ group mts
1286 where cmpQualifiers =
1287 compare `on` (map (fmap (map moduleNameFS)) . fst)
1289 group mts@((m,_):_) = (m,map snd g) : group ng
1290 where (g,ng) = partition ((==m).fst) mts
1292 let prettyThings = map (pretty pefas) things
1293 prettyThings' | bang = annotate $ zip modNames prettyThings
1294 | otherwise = prettyThings
1295 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1296 -- ToDo: modInfoInstances currently throws an exception for
1297 -- package modules. When it works, we can do this:
1298 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1300 -----------------------------------------------------------------------------
1301 -- Setting the module context
1303 setContext :: String -> GHCi ()
1305 | all sensible strs = do
1306 playCtxtCmd True (cmd, as, bs)
1308 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1309 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1311 (cmd, strs, as, bs) =
1313 '+':stuff -> rest AddModules stuff
1314 '-':stuff -> rest RemModules stuff
1315 stuff -> rest SetContext stuff
1317 rest cmd stuff = (cmd, strs, as, bs)
1318 where strs = words stuff
1319 (as,bs) = partitionWith starred strs
1321 sensible ('*':m) = looksLikeModuleName m
1322 sensible m = looksLikeModuleName m
1324 starred ('*':m) = Left m
1327 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1328 playCtxtCmd fail (cmd, as, bs)
1331 (as',bs') <- do_checks fail
1332 (prev_as,prev_bs) <- io $ GHC.getContext s
1336 prel_mod <- getPrelude
1337 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1341 let as_to_add = as' \\ (prev_as ++ prev_bs)
1342 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1343 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1345 let new_as = prev_as \\ (as' ++ bs')
1346 new_bs = prev_bs \\ (as' ++ bs')
1347 return (new_as, new_bs)
1348 io $ GHC.setContext s new_as new_bs
1351 as' <- mapM wantInterpretedModule as
1352 bs' <- mapM lookupModule bs
1354 do_checks False = do
1355 as' <- mapM (trymaybe . wantInterpretedModule) as
1356 bs' <- mapM (trymaybe . lookupModule) bs
1357 return (catMaybes as', catMaybes bs')
1362 Left _ -> return Nothing
1363 Right a -> return (Just a)
1365 ----------------------------------------------------------------------------
1368 -- set options in the interpreter. Syntax is exactly the same as the
1369 -- ghc command line, except that certain options aren't available (-C,
1372 -- This is pretty fragile: most options won't work as expected. ToDo:
1373 -- figure out which ones & disallow them.
1375 setCmd :: String -> GHCi ()
1377 = do st <- getGHCiState
1378 let opts = options st
1379 io $ putStrLn (showSDoc (
1380 text "options currently set: " <>
1383 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1385 dflags <- getDynFlags
1386 io $ putStrLn (showSDoc (
1387 vcat (text "GHCi-specific dynamic flag settings:"
1388 :map (flagSetting dflags) ghciFlags)
1390 io $ putStrLn (showSDoc (
1391 vcat (text "other dynamic, non-language, flag settings:"
1392 :map (flagSetting dflags) nonLanguageDynFlags)
1394 where flagSetting dflags (str,f)
1395 | dopt f dflags = text " " <> text "-f" <> text str
1396 | otherwise = text " " <> text "-fno-" <> text str
1397 (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
1399 nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1401 flags = [Opt_PrintExplicitForalls
1402 ,Opt_PrintBindResult
1403 ,Opt_BreakOnException
1405 ,Opt_PrintEvldWithShow
1408 = case getCmd str of
1409 Right ("args", rest) ->
1411 Left err -> io (hPutStrLn stderr err)
1412 Right args -> setArgs args
1413 Right ("prog", rest) ->
1415 Right [prog] -> setProg prog
1416 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1417 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1418 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1419 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1420 _ -> case toArgs str of
1421 Left err -> io (hPutStrLn stderr err)
1422 Right wds -> setOptions wds
1424 setArgs, setOptions :: [String] -> GHCi ()
1425 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1429 setGHCiState st{ args = args }
1433 setGHCiState st{ progname = prog }
1437 setGHCiState st{ editor = cmd }
1439 setStop str@(c:_) | isDigit c
1440 = do let (nm_str,rest) = break (not.isDigit) str
1443 let old_breaks = breaks st
1444 if all ((/= nm) . fst) old_breaks
1445 then printForUser (text "Breakpoint" <+> ppr nm <+>
1446 text "does not exist")
1448 let new_breaks = map fn old_breaks
1449 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1450 | otherwise = (i,loc)
1451 setGHCiState st{ breaks = new_breaks }
1454 setGHCiState st{ stop = cmd }
1456 setPrompt value = do
1459 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1460 else setGHCiState st{ prompt = remQuotes value }
1462 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1466 do -- first, deal with the GHCi opts (+s, +t, etc.)
1467 let (plus_opts, minus_opts) = partitionWith isPlus wds
1468 mapM_ setOpt plus_opts
1469 -- then, dynamic flags
1470 newDynFlags minus_opts
1472 newDynFlags :: [String] -> GHCi ()
1473 newDynFlags minus_opts = do
1474 dflags <- getDynFlags
1475 let pkg_flags = packageFlags dflags
1476 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1478 if (not (null leftovers))
1479 then throwDyn (CmdLineError ("unrecognised flags: " ++
1483 new_pkgs <- setDynFlags dflags'
1485 -- if the package flags changed, we should reset the context
1486 -- and link the new packages.
1487 dflags <- getDynFlags
1488 when (packageFlags dflags /= pkg_flags) $ do
1489 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1490 session <- getSession
1491 io (GHC.setTargets session [])
1492 io (GHC.load session LoadAllTargets)
1493 io (linkPackages dflags new_pkgs)
1494 -- package flags changed, we can't re-use any of the old context
1495 setContextAfterLoad session ([],[]) False []
1499 unsetOptions :: String -> GHCi ()
1501 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1502 let opts = words str
1503 (minus_opts, rest1) = partition isMinus opts
1504 (plus_opts, rest2) = partitionWith isPlus rest1
1506 if (not (null rest2))
1507 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1510 mapM_ unsetOpt plus_opts
1512 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1513 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1515 no_flags <- mapM no_flag minus_opts
1516 newDynFlags no_flags
1518 isMinus :: String -> Bool
1519 isMinus ('-':_) = True
1522 isPlus :: String -> Either String String
1523 isPlus ('+':opt) = Left opt
1524 isPlus other = Right other
1526 setOpt, unsetOpt :: String -> GHCi ()
1529 = case strToGHCiOpt str of
1530 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1531 Just o -> setOption o
1534 = case strToGHCiOpt str of
1535 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1536 Just o -> unsetOption o
1538 strToGHCiOpt :: String -> (Maybe GHCiOption)
1539 strToGHCiOpt "s" = Just ShowTiming
1540 strToGHCiOpt "t" = Just ShowType
1541 strToGHCiOpt "r" = Just RevertCAFs
1542 strToGHCiOpt _ = Nothing
1544 optToStr :: GHCiOption -> String
1545 optToStr ShowTiming = "s"
1546 optToStr ShowType = "t"
1547 optToStr RevertCAFs = "r"
1549 -- ---------------------------------------------------------------------------
1552 showCmd :: String -> GHCi ()
1556 ["args"] -> io $ putStrLn (show (args st))
1557 ["prog"] -> io $ putStrLn (show (progname st))
1558 ["prompt"] -> io $ putStrLn (show (prompt st))
1559 ["editor"] -> io $ putStrLn (show (editor st))
1560 ["stop"] -> io $ putStrLn (show (stop st))
1561 ["modules" ] -> showModules
1562 ["bindings"] -> showBindings
1563 ["linker"] -> io showLinkerState
1564 ["breaks"] -> showBkptTable
1565 ["context"] -> showContext
1566 ["packages"] -> showPackages
1567 ["languages"] -> showLanguages
1568 _ -> throwDyn (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1569 " | breaks | context | packages | languages ]"))
1571 showModules :: GHCi ()
1573 session <- getSession
1574 loaded_mods <- getLoadedModules session
1575 -- we want *loaded* modules only, see #1734
1576 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1577 mapM_ show_one loaded_mods
1579 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1580 getLoadedModules session = do
1581 graph <- io (GHC.getModuleGraph session)
1582 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1584 showBindings :: GHCi ()
1587 bindings <- io (GHC.getBindings s)
1588 docs <- io$ pprTypeAndContents s
1589 [ id | AnId id <- sortBy compareTyThings bindings]
1590 printForUserPartWay docs
1592 compareTyThings :: TyThing -> TyThing -> Ordering
1593 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1595 printTyThing :: TyThing -> GHCi ()
1596 printTyThing tyth = do dflags <- getDynFlags
1597 let pefas = dopt Opt_PrintExplicitForalls dflags
1598 printForUser (pprTyThing pefas tyth)
1600 showBkptTable :: GHCi ()
1603 printForUser $ prettyLocations (breaks st)
1605 showContext :: GHCi ()
1607 session <- getSession
1608 resumes <- io $ GHC.getResumeContext session
1609 printForUser $ vcat (map pp_resume (reverse resumes))
1612 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1613 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1615 showPackages :: GHCi ()
1617 pkg_flags <- fmap packageFlags getDynFlags
1618 io $ putStrLn $ showSDoc $ vcat $
1619 text ("active package flags:"++if null pkg_flags then " none" else "")
1620 : map showFlag pkg_flags
1621 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1622 io $ putStrLn $ showSDoc $ vcat $
1623 text "packages currently loaded:"
1624 : map (nest 2 . text . packageIdString) pkg_ids
1625 where showFlag (ExposePackage p) = text $ " -package " ++ p
1626 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1627 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1629 showLanguages :: GHCi ()
1631 dflags <- getDynFlags
1632 io $ putStrLn $ showSDoc $ vcat $
1633 text "active language flags:" :
1634 [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1636 -- -----------------------------------------------------------------------------
1639 completeNone :: String -> IO [String]
1640 completeNone _w = return []
1642 completeMacro, completeIdentifier, completeModule,
1643 completeHomeModule, completeSetOptions, completeFilename,
1644 completeHomeModuleOrFile
1645 :: String -> IO [String]
1648 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1649 completeWord w start end = do
1650 line <- Readline.getLineBuffer
1651 let line_words = words (dropWhile isSpace line)
1653 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1655 | ((':':c) : _) <- line_words -> do
1656 completionVars <- lookupCompletionVars c
1657 case completionVars of
1658 (Nothing,complete) -> wrapCompleter complete w
1659 (Just breakChars,complete)
1660 -> let (n,w') = selectWord
1661 (words' (`elem` breakChars) 0 line)
1662 complete' w = do rets <- complete w
1663 return (map (drop n) rets)
1664 in wrapCompleter complete' w'
1665 | ("import" : _) <- line_words ->
1666 wrapCompleter completeModule w
1668 --printf "complete %s, start = %d, end = %d\n" w start end
1669 wrapCompleter completeIdentifier w
1670 where words' _ _ [] = []
1671 words' isBreak n str = let (w,r) = break isBreak str
1672 (s,r') = span isBreak r
1673 in (n,w):words' isBreak (n+length w+length s) r'
1674 -- In a Haskell expression we want to parse 'a-b' as three words
1675 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1676 -- only be a single word.
1677 selectWord [] = (0,w)
1678 selectWord ((offset,x):xs)
1679 | offset+length x >= start = (start-offset,take (end-offset) x)
1680 | otherwise = selectWord xs
1682 lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars,
1684 lookupCompletionVars c = do
1685 maybe_cmd <- lookupCommand' c
1687 Just (_,_,ws,f) -> return (ws,f)
1688 Nothing -> return (Just filenameWordBreakChars,
1692 completeCmd :: String -> IO [String]
1694 cmds <- readIORef macros_ref
1695 return (filter (w `isPrefixOf`) (map (':':)
1696 (map cmdName (builtin_commands ++ cmds))))
1698 completeMacro w = do
1699 cmds <- readIORef macros_ref
1700 return (filter (w `isPrefixOf`) (map cmdName cmds))
1702 completeIdentifier w = do
1704 rdrs <- GHC.getRdrNamesInScope s
1705 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1707 completeModule w = do
1709 dflags <- GHC.getSessionDynFlags s
1710 let pkg_mods = allExposedModules dflags
1711 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1713 completeHomeModule w = do
1715 g <- GHC.getModuleGraph s
1716 let home_mods = map GHC.ms_mod_name g
1717 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1719 completeSetOptions w = do
1720 return (filter (w `isPrefixOf`) options)
1721 where options = "args":"prog":allFlags
1723 completeFilename w = do
1724 ws <- Readline.filenameCompletionFunction w
1726 -- If we only found one result, and it's a directory,
1727 -- add a trailing slash.
1729 isDir <- expandPathIO file >>= doesDirectoryExist
1730 if isDir && last file /= '/'
1731 then return [file ++ "/"]
1736 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1738 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1739 unionComplete f1 f2 w = do
1744 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1745 wrapCompleter fun w = do
1748 [] -> Readline.setAttemptedCompletionOver True >> return Nothing
1749 [x] -> -- Add a trailing space, unless it already has an appended slash.
1750 let appended = if last x == '/' then x else x ++ " "
1751 in return (Just (appended,[]))
1752 xs -> case getCommonPrefix xs of
1753 "" -> return (Just ("",xs))
1754 pref -> return (Just (pref,xs))
1756 getCommonPrefix :: [String] -> String
1757 getCommonPrefix [] = ""
1758 getCommonPrefix (s:ss) = foldl common s ss
1759 where common _s "" = ""
1761 common (c:cs) (d:ds)
1762 | c == d = c : common cs ds
1765 allExposedModules :: DynFlags -> [ModuleName]
1766 allExposedModules dflags
1767 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1769 pkg_db = pkgIdMap (pkgState dflags)
1771 completeMacro = completeNone
1772 completeIdentifier = completeNone
1773 completeModule = completeNone
1774 completeHomeModule = completeNone
1775 completeSetOptions = completeNone
1776 completeFilename = completeNone
1777 completeHomeModuleOrFile=completeNone
1780 -- ---------------------------------------------------------------------------
1781 -- User code exception handling
1783 -- This is the exception handler for exceptions generated by the
1784 -- user's code and exceptions coming from children sessions;
1785 -- it normally just prints out the exception. The
1786 -- handler must be recursive, in case showing the exception causes
1787 -- more exceptions to be raised.
1789 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1790 -- raising another exception. We therefore don't put the recursive
1791 -- handler arond the flushing operation, so if stderr is closed
1792 -- GHCi will just die gracefully rather than going into an infinite loop.
1793 handler :: Exception -> GHCi Bool
1795 handler exception = do
1797 io installSignalHandlers
1798 ghciHandle handler (showException exception >> return False)
1800 showException :: Exception -> GHCi ()
1801 showException (DynException dyn) =
1802 case fromDynamic dyn of
1803 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1804 Just Interrupted -> io (putStrLn "Interrupted.")
1805 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1806 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1807 Just other_ghc_ex -> io (print other_ghc_ex)
1809 showException other_exception
1810 = io (putStrLn ("*** Exception: " ++ show other_exception))
1812 -----------------------------------------------------------------------------
1813 -- recursive exception handlers
1815 -- Don't forget to unblock async exceptions in the handler, or if we're
1816 -- in an exception loop (eg. let a = error a in a) the ^C exception
1817 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1819 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1820 ghciHandle h (GHCi m) = GHCi $ \s ->
1821 Exception.catch (m s)
1822 (\e -> unGHCi (ghciUnblock (h e)) s)
1824 ghciUnblock :: GHCi a -> GHCi a
1825 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1827 ghciTry :: GHCi a -> GHCi (Either Exception a)
1828 ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s)
1830 -- ----------------------------------------------------------------------------
1833 expandPath :: String -> GHCi String
1834 expandPath path = io (expandPathIO path)
1836 expandPathIO :: String -> IO String
1838 case dropWhile isSpace path of
1840 tilde <- getHomeDirectory -- will fail if HOME not defined
1841 return (tilde ++ '/':d)
1845 wantInterpretedModule :: String -> GHCi Module
1846 wantInterpretedModule str = do
1847 session <- getSession
1848 modl <- lookupModule str
1849 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1850 when (not is_interpreted) $
1851 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1854 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1855 -> (Name -> GHCi ())
1857 wantNameFromInterpretedModule noCanDo str and_then = do
1858 session <- getSession
1859 names <- io $ GHC.parseName session str
1863 let modl = GHC.nameModule n
1864 if not (GHC.isExternalName n)
1865 then noCanDo n $ ppr n <>
1866 text " is not defined in an interpreted module"
1868 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1869 if not is_interpreted
1870 then noCanDo n $ text "module " <> ppr modl <>
1871 text " is not interpreted"
1874 -- -----------------------------------------------------------------------------
1875 -- commands for debugger
1877 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1878 sprintCmd = pprintCommand False False
1879 printCmd = pprintCommand True False
1880 forceCmd = pprintCommand False True
1882 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1883 pprintCommand bind force str = do
1884 session <- getSession
1885 io $ pprintClosureCommand session bind force str
1887 stepCmd :: String -> GHCi ()
1888 stepCmd [] = doContinue (const True) GHC.SingleStep
1889 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1891 stepLocalCmd :: String -> GHCi ()
1892 stepLocalCmd [] = do
1893 mb_span <- getCurrentBreakSpan
1895 Nothing -> stepCmd []
1897 Just mod <- getCurrentBreakModule
1898 current_toplevel_decl <- enclosingTickSpan mod loc
1899 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1901 stepLocalCmd expression = stepCmd expression
1903 stepModuleCmd :: String -> GHCi ()
1904 stepModuleCmd [] = do
1905 mb_span <- getCurrentBreakSpan
1907 Nothing -> stepCmd []
1909 Just span <- getCurrentBreakSpan
1910 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1911 doContinue f GHC.SingleStep
1913 stepModuleCmd expression = stepCmd expression
1915 -- | Returns the span of the largest tick containing the srcspan given
1916 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1917 enclosingTickSpan mod src = do
1918 ticks <- getTickArray mod
1919 let line = srcSpanStartLine src
1920 ASSERT (inRange (bounds ticks) line) do
1921 let enclosing_spans = [ span | (_,span) <- ticks ! line
1922 , srcSpanEnd span >= srcSpanEnd src]
1923 return . head . sortBy leftmost_largest $ enclosing_spans
1925 traceCmd :: String -> GHCi ()
1926 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1927 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1929 continueCmd :: String -> GHCi ()
1930 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1932 -- doContinue :: SingleStep -> GHCi ()
1933 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1934 doContinue pred step = do
1935 session <- getSession
1936 runResult <- io $ GHC.resume session step
1937 afterRunStmt pred runResult
1940 abandonCmd :: String -> GHCi ()
1941 abandonCmd = noArgs $ do
1943 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1944 when (not b) $ io $ putStrLn "There is no computation running."
1947 deleteCmd :: String -> GHCi ()
1948 deleteCmd argLine = do
1949 deleteSwitch $ words argLine
1951 deleteSwitch :: [String] -> GHCi ()
1953 io $ putStrLn "The delete command requires at least one argument."
1954 -- delete all break points
1955 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1956 deleteSwitch idents = do
1957 mapM_ deleteOneBreak idents
1959 deleteOneBreak :: String -> GHCi ()
1961 | all isDigit str = deleteBreak (read str)
1962 | otherwise = return ()
1964 historyCmd :: String -> GHCi ()
1966 | null arg = history 20
1967 | all isDigit arg = history (read arg)
1968 | otherwise = io $ putStrLn "Syntax: :history [num]"
1972 resumes <- io $ GHC.getResumeContext s
1974 [] -> io $ putStrLn "Not stopped at a breakpoint"
1976 let hist = GHC.resumeHistory r
1977 (took,rest) = splitAt num hist
1979 [] -> io $ putStrLn $
1980 "Empty history. Perhaps you forgot to use :trace?"
1982 spans <- mapM (io . GHC.getHistorySpan s) took
1983 let nums = map (printf "-%-3d:") [(1::Int)..]
1984 names = map GHC.historyEnclosingDecl took
1985 printForUser (vcat(zipWith3
1986 (\x y z -> x <+> y <+> z)
1988 (map (bold . ppr) names)
1989 (map (parens . ppr) spans)))
1990 io $ putStrLn $ if null rest then "<end of history>" else "..."
1992 bold :: SDoc -> SDoc
1993 bold c | do_bold = text start_bold <> c <> text end_bold
1996 backCmd :: String -> GHCi ()
1997 backCmd = noArgs $ do
1999 (names, _, span) <- io $ GHC.back s
2000 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
2001 printTypeOfNames s names
2002 -- run the command set with ":set stop <cmd>"
2004 enqueueCommands [stop st]
2006 forwardCmd :: String -> GHCi ()
2007 forwardCmd = noArgs $ do
2009 (names, ix, span) <- io $ GHC.forward s
2010 printForUser $ (if (ix == 0)
2011 then ptext SLIT("Stopped at")
2012 else ptext SLIT("Logged breakpoint at")) <+> ppr span
2013 printTypeOfNames s names
2014 -- run the command set with ":set stop <cmd>"
2016 enqueueCommands [stop st]
2018 -- handle the "break" command
2019 breakCmd :: String -> GHCi ()
2020 breakCmd argLine = do
2021 session <- getSession
2022 breakSwitch session $ words argLine
2024 breakSwitch :: Session -> [String] -> GHCi ()
2025 breakSwitch _session [] = do
2026 io $ putStrLn "The break command requires at least one argument."
2027 breakSwitch session (arg1:rest)
2028 | looksLikeModuleName arg1 = do
2029 mod <- wantInterpretedModule arg1
2030 breakByModule mod rest
2031 | all isDigit arg1 = do
2032 (toplevel, _) <- io $ GHC.getContext session
2034 (mod : _) -> breakByModuleLine mod (read arg1) rest
2036 io $ putStrLn "Cannot find default module for breakpoint."
2037 io $ putStrLn "Perhaps no modules are loaded for debugging?"
2038 | otherwise = do -- try parsing it as an identifier
2039 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2040 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2041 if GHC.isGoodSrcLoc loc
2042 then findBreakAndSet (GHC.nameModule name) $
2043 findBreakByCoord (Just (GHC.srcLocFile loc))
2044 (GHC.srcLocLine loc,
2046 else noCanDo name $ text "can't find its location: " <> ppr loc
2048 noCanDo n why = printForUser $
2049 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2051 breakByModule :: Module -> [String] -> GHCi ()
2052 breakByModule mod (arg1:rest)
2053 | all isDigit arg1 = do -- looks like a line number
2054 breakByModuleLine mod (read arg1) rest
2058 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2059 breakByModuleLine mod line args
2060 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2061 | [col] <- args, all isDigit col =
2062 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2063 | otherwise = breakSyntax
2066 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2068 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2069 findBreakAndSet mod lookupTickTree = do
2070 tickArray <- getTickArray mod
2071 (breakArray, _) <- getModBreak mod
2072 case lookupTickTree tickArray of
2073 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2074 Just (tick, span) -> do
2075 success <- io $ setBreakFlag True breakArray tick
2079 recordBreak $ BreakLocation
2086 text "Breakpoint " <> ppr nm <>
2088 then text " was already set at " <> ppr span
2089 else text " activated at " <> ppr span
2091 printForUser $ text "Breakpoint could not be activated at"
2094 -- When a line number is specified, the current policy for choosing
2095 -- the best breakpoint is this:
2096 -- - the leftmost complete subexpression on the specified line, or
2097 -- - the leftmost subexpression starting on the specified line, or
2098 -- - the rightmost subexpression enclosing the specified line
2100 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2101 findBreakByLine line arr
2102 | not (inRange (bounds arr) line) = Nothing
2104 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2105 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2106 listToMaybe (sortBy (rightmost `on` snd) ticks)
2110 starts_here = [ tick | tick@(_,span) <- ticks,
2111 GHC.srcSpanStartLine span == line ]
2113 (complete,incomplete) = partition ends_here starts_here
2114 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2116 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2117 -> Maybe (BreakIndex,SrcSpan)
2118 findBreakByCoord mb_file (line, col) arr
2119 | not (inRange (bounds arr) line) = Nothing
2121 listToMaybe (sortBy (rightmost `on` snd) contains ++
2122 sortBy (leftmost_smallest `on` snd) after_here)
2126 -- the ticks that span this coordinate
2127 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2128 is_correct_file span ]
2130 is_correct_file span
2131 | Just f <- mb_file = GHC.srcSpanFile span == f
2134 after_here = [ tick | tick@(_,span) <- ticks,
2135 GHC.srcSpanStartLine span == line,
2136 GHC.srcSpanStartCol span >= col ]
2138 -- For now, use ANSI bold on terminals that we know support it.
2139 -- Otherwise, we add a line of carets under the active expression instead.
2140 -- In particular, on Windows and when running the testsuite (which sets
2141 -- TERM to vt100 for other reasons) we get carets.
2142 -- We really ought to use a proper termcap/terminfo library.
2144 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2145 where mTerm = System.Environment.getEnv "TERM"
2146 `Exception.catch` \_ -> return "TERM not set"
2148 start_bold :: String
2149 start_bold = "\ESC[1m"
2151 end_bold = "\ESC[0m"
2153 listCmd :: String -> GHCi ()
2155 mb_span <- getCurrentBreakSpan
2158 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2160 | GHC.isGoodSrcSpan span -> io $ listAround span True
2163 resumes <- io $ GHC.getResumeContext s
2165 [] -> panic "No resumes"
2167 do let traceIt = case GHC.resumeHistory r of
2168 [] -> text "rerunning with :trace,"
2170 doWhat = traceIt <+> text ":back then :list"
2171 printForUser (text "Unable to list source for" <+>
2173 $$ text "Try" <+> doWhat)
2174 listCmd str = list2 (words str)
2176 list2 :: [String] -> GHCi ()
2177 list2 [arg] | all isDigit arg = do
2178 session <- getSession
2179 (toplevel, _) <- io $ GHC.getContext session
2181 [] -> io $ putStrLn "No module to list"
2182 (mod : _) -> listModuleLine mod (read arg)
2183 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2184 mod <- wantInterpretedModule arg1
2185 listModuleLine mod (read arg2)
2187 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2188 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2189 if GHC.isGoodSrcLoc loc
2191 tickArray <- getTickArray (GHC.nameModule name)
2192 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2193 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2196 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2197 Just (_,span) -> io $ listAround span False
2199 noCanDo name $ text "can't find its location: " <>
2202 noCanDo n why = printForUser $
2203 text "cannot list source code for " <> ppr n <> text ": " <> why
2205 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2207 listModuleLine :: Module -> Int -> GHCi ()
2208 listModuleLine modl line = do
2209 session <- getSession
2210 graph <- io (GHC.getModuleGraph session)
2211 let this = filter ((== modl) . GHC.ms_mod) graph
2213 [] -> panic "listModuleLine"
2215 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2216 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2217 io $ listAround (GHC.srcLocSpan loc) False
2219 -- | list a section of a source file around a particular SrcSpan.
2220 -- If the highlight flag is True, also highlight the span using
2221 -- start_bold/end_bold.
2222 listAround :: SrcSpan -> Bool -> IO ()
2223 listAround span do_highlight = do
2224 contents <- BS.readFile (unpackFS file)
2226 lines = BS.split '\n' contents
2227 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2228 drop (line1 - 1 - pad_before) $ lines
2229 fst_line = max 1 (line1 - pad_before)
2230 line_nos = [ fst_line .. ]
2232 highlighted | do_highlight = zipWith highlight line_nos these_lines
2233 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2235 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2236 prefixed = zipWith ($) highlighted bs_line_nos
2238 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2240 file = GHC.srcSpanFile span
2241 line1 = GHC.srcSpanStartLine span
2242 col1 = GHC.srcSpanStartCol span
2243 line2 = GHC.srcSpanEndLine span
2244 col2 = GHC.srcSpanEndCol span
2246 pad_before | line1 == 1 = 0
2250 highlight | do_bold = highlight_bold
2251 | otherwise = highlight_carets
2253 highlight_bold no line prefix
2254 | no == line1 && no == line2
2255 = let (a,r) = BS.splitAt col1 line
2256 (b,c) = BS.splitAt (col2-col1) r
2258 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2260 = let (a,b) = BS.splitAt col1 line in
2261 BS.concat [prefix, a, BS.pack start_bold, b]
2263 = let (a,b) = BS.splitAt col2 line in
2264 BS.concat [prefix, a, BS.pack end_bold, b]
2265 | otherwise = BS.concat [prefix, line]
2267 highlight_carets no line prefix
2268 | no == line1 && no == line2
2269 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2270 BS.replicate (col2-col1) '^']
2272 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2275 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2277 | otherwise = BS.concat [prefix, line]
2279 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2280 nl = BS.singleton '\n'
2282 -- --------------------------------------------------------------------------
2285 getTickArray :: Module -> GHCi TickArray
2286 getTickArray modl = do
2288 let arrmap = tickarrays st
2289 case lookupModuleEnv arrmap modl of
2290 Just arr -> return arr
2292 (_breakArray, ticks) <- getModBreak modl
2293 let arr = mkTickArray (assocs ticks)
2294 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2297 discardTickArrays :: GHCi ()
2298 discardTickArrays = do
2300 setGHCiState st{tickarrays = emptyModuleEnv}
2302 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2304 = accumArray (flip (:)) [] (1, max_line)
2305 [ (line, (nm,span)) | (nm,span) <- ticks,
2306 line <- srcSpanLines span ]
2308 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2309 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2310 GHC.srcSpanEndLine span ]
2312 lookupModule :: String -> GHCi Module
2313 lookupModule modName
2314 = do session <- getSession
2315 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2317 -- don't reset the counter back to zero?
2318 discardActiveBreakPoints :: GHCi ()
2319 discardActiveBreakPoints = do
2321 mapM (turnOffBreak.snd) (breaks st)
2322 setGHCiState $ st { breaks = [] }
2324 deleteBreak :: Int -> GHCi ()
2325 deleteBreak identity = do
2327 let oldLocations = breaks st
2328 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2330 then printForUser (text "Breakpoint" <+> ppr identity <+>
2331 text "does not exist")
2333 mapM (turnOffBreak.snd) this
2334 setGHCiState $ st { breaks = rest }
2336 turnOffBreak :: BreakLocation -> GHCi Bool
2337 turnOffBreak loc = do
2338 (arr, _) <- getModBreak (breakModule loc)
2339 io $ setBreakFlag False arr (breakTick loc)
2341 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2342 getModBreak mod = do
2343 session <- getSession
2344 Just mod_info <- io $ GHC.getModuleInfo session mod
2345 let modBreaks = GHC.modInfoModBreaks mod_info
2346 let array = GHC.modBreaks_flags modBreaks
2347 let ticks = GHC.modBreaks_locs modBreaks
2348 return (array, ticks)
2350 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2351 setBreakFlag toggle array index
2352 | toggle = GHC.setBreakOn array index
2353 | otherwise = GHC.setBreakOff array index