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
57 import System.FilePath
61 import Control.Concurrent ( yield ) -- Used in readline loop
62 import System.Console.Readline as Readline
67 import Control.Exception as Exception
68 -- import Control.Concurrent
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
85 import Foreign.C ( withCStringLen )
86 import GHC.Exts ( unsafeCoerce# )
87 import GHC.IOBase ( IOErrorType(InvalidArgument) )
89 import Data.IORef ( IORef, readIORef, writeIORef )
92 import System.Posix.Internals ( setNonBlockingFD )
95 -----------------------------------------------------------------------------
97 ghciWelcomeMsg :: String
98 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
99 ": http://www.haskell.org/ghc/ :? for help"
101 cmdName :: Command -> String
102 cmdName (n,_,_,_) = n
104 macros_ref :: IORef [Command]
105 GLOBAL_VAR(macros_ref, [], [Command])
107 builtin_commands :: [Command]
109 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
110 ("?", keepGoing help, Nothing, completeNone),
111 ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename),
112 ("abandon", keepGoing abandonCmd, Nothing, completeNone),
113 ("break", keepGoing breakCmd, Nothing, completeIdentifier),
114 ("back", keepGoing backCmd, Nothing, completeNone),
115 ("browse", keepGoing (browseCmd False), Nothing, completeModule),
116 ("browse!", keepGoing (browseCmd True), Nothing, completeModule),
117 ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename),
118 ("check", keepGoing checkModule, Nothing, completeHomeModule),
119 ("continue", keepGoing continueCmd, Nothing, completeNone),
120 ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier),
121 ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename),
122 ("def", keepGoing (defineMacro False), Nothing, completeIdentifier),
123 ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier),
124 ("delete", keepGoing deleteCmd, Nothing, completeNone),
125 ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
126 ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
127 ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename),
128 ("force", keepGoing forceCmd, Nothing, completeIdentifier),
129 ("forward", keepGoing forwardCmd, Nothing, completeNone),
130 ("help", keepGoing help, Nothing, completeNone),
131 ("history", keepGoing historyCmd, Nothing, completeNone),
132 ("info", keepGoing info, Nothing, completeIdentifier),
133 ("kind", keepGoing kindOfType, Nothing, completeIdentifier),
134 ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile),
135 ("list", keepGoing listCmd, Nothing, completeNone),
136 ("module", keepGoing setContext, Nothing, completeModule),
137 ("main", keepGoing runMain, Nothing, completeIdentifier),
138 ("print", keepGoing printCmd, Nothing, completeIdentifier),
139 ("quit", quit, Nothing, completeNone),
140 ("reload", keepGoing reloadModule, Nothing, completeNone),
141 ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions),
142 ("show", keepGoing showCmd, Nothing, completeNone),
143 ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier),
144 ("step", keepGoing stepCmd, Nothing, completeIdentifier),
145 ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier),
146 ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier),
147 ("type", keepGoing typeOfExpr, Nothing, completeIdentifier),
148 ("trace", keepGoing traceCmd, Nothing, completeIdentifier),
149 ("undef", keepGoing undefineMacro, Nothing, completeMacro),
150 ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions)
154 -- We initialize readline (in the interactiveUI function) to use
155 -- word_break_chars as the default set of completion word break characters.
156 -- This can be overridden for a particular command (for example, filename
157 -- expansion shouldn't consider '/' to be a word break) by setting the third
158 -- entry in the Command tuple above.
160 -- NOTE: in order for us to override the default correctly, any custom entry
161 -- must be a SUBSET of word_break_chars.
163 word_break_chars :: String
164 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
165 specials = "(),;[]`{}"
167 in spaces ++ specials ++ symbols
170 flagWordBreakChars, filenameWordBreakChars :: String
171 flagWordBreakChars = " \t\n"
172 filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults
175 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
176 keepGoing a str = a str >> return False
178 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
179 keepGoingPaths a str = a (toArgs str) >> return False
181 shortHelpText :: String
182 shortHelpText = "use :? for help.\n"
186 " Commands available from the prompt:\n" ++
188 " <statement> evaluate/run <statement>\n" ++
189 " : repeat last command\n" ++
190 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
191 " :add <filename> ... add module(s) to the current target set\n" ++
192 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
193 " (!: more details; *: all top-level names)\n" ++
194 " :cd <dir> change directory to <dir>\n" ++
195 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
196 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
197 " :def <cmd> <expr> define a command :<cmd>\n" ++
198 " :edit <file> edit file\n" ++
199 " :edit edit last module\n" ++
200 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
201 " :help, :? display this list of commands\n" ++
202 " :info [<name> ...] display information about the given names\n" ++
203 " :kind <type> show the kind of <type>\n" ++
204 " :load <filename> ... load module(s) and their dependents\n" ++
205 " :main [<arguments> ...] run the main function with the given arguments\n" ++
206 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
207 " :quit exit GHCi\n" ++
208 " :reload reload the current module set\n" ++
209 " :type <expr> show the type of <expr>\n" ++
210 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
211 " :!<command> run the shell command <command>\n" ++
213 " -- Commands for debugging:\n" ++
215 " :abandon at a breakpoint, abandon current computation\n" ++
216 " :back go back in the history (after :trace)\n" ++
217 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
218 " :break <name> set a breakpoint on the specified function\n" ++
219 " :continue resume after a breakpoint\n" ++
220 " :delete <number> delete the specified breakpoint\n" ++
221 " :delete * delete all breakpoints\n" ++
222 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
223 " :forward go forward in the history (after :back)\n" ++
224 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
225 " :print [<name> ...] prints a value without forcing its computation\n" ++
226 " :sprint [<name> ...] simplifed version of :print\n" ++
227 " :step single-step after stopping at a breakpoint\n"++
228 " :step <expr> single-step into <expr>\n"++
229 " :steplocal single-step restricted to the current top level decl.\n"++
230 " :stepmodule single-step restricted to the current module\n"++
231 " :trace trace after stopping at a breakpoint\n"++
232 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
235 " -- Commands for changing settings:\n" ++
237 " :set <option> ... set options\n" ++
238 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
239 " :set prog <progname> set the value returned by System.getProgName\n" ++
240 " :set prompt <prompt> set the prompt used in GHCi\n" ++
241 " :set editor <cmd> set the command used for :edit\n" ++
242 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
243 " :unset <option> ... unset options\n" ++
245 " Options for ':set' and ':unset':\n" ++
247 " +r revert top-level expressions after each evaluation\n" ++
248 " +s print timing/memory stats after each evaluation\n" ++
249 " +t print type after evaluation\n" ++
250 " -<flags> most GHC command line flags can also be set here\n" ++
251 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
252 " for GHCi-specific flags, see User's Guide,\n"++
253 " Flag reference, Interactive-mode options\n" ++
255 " -- Commands for displaying information:\n" ++
257 " :show bindings show the current bindings made at the prompt\n" ++
258 " :show breaks show the active breakpoints\n" ++
259 " :show context show the breakpoint context\n" ++
260 " :show modules show the currently loaded modules\n" ++
261 " :show packages show the currently active package flags\n" ++
262 " :show languages show the currently active language flags\n" ++
263 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
266 findEditor :: IO String
271 win <- System.Win32.getWindowsDirectory
272 return (win </> "notepad.exe")
277 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
278 interactiveUI session srcs maybe_expr = do
279 -- HACK! If we happen to get into an infinite loop (eg the user
280 -- types 'let x=x in x' at the prompt), then the thread will block
281 -- on a blackhole, and become unreachable during GC. The GC will
282 -- detect that it is unreachable and send it the NonTermination
283 -- exception. However, since the thread is unreachable, everything
284 -- it refers to might be finalized, including the standard Handles.
285 -- This sounds like a bug, but we don't have a good solution right
291 -- Initialise buffering for the *interpreted* I/O system
292 initInterpBuffering session
294 when (isNothing maybe_expr) $ do
295 -- Only for GHCi (not runghc and ghc -e):
297 -- Turn buffering off for the compiled program's stdout/stderr
299 -- Turn buffering off for GHCi's stdout
301 hSetBuffering stdout NoBuffering
302 -- We don't want the cmd line to buffer any input that might be
303 -- intended for the program, so unbuffer stdin.
304 hSetBuffering stdin NoBuffering
307 is_tty <- hIsTerminalDevice stdin
310 Readline.setAttemptedCompletionFunction (Just completeWord)
311 --Readline.parseAndBind "set show-all-if-ambiguous 1"
313 Readline.setBasicWordBreakCharacters word_break_chars
314 Readline.setCompleterWordBreakCharacters word_break_chars
315 Readline.setCompletionAppendCharacter Nothing
318 -- initial context is just the Prelude
319 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
321 GHC.setContext session [] [prel_mod]
323 default_editor <- findEditor
325 startGHCi (runGHCi srcs maybe_expr)
326 GHCiState{ progname = "<interactive>",
330 editor = default_editor,
336 tickarrays = emptyModuleEnv,
337 last_command = Nothing,
339 remembered_ctx = Nothing
343 Readline.resetTerminal Nothing
348 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
349 runGHCi paths maybe_expr = do
350 let read_dot_files = not opt_IgnoreDotGhci
352 when (read_dot_files) $ do
355 exists <- io (doesFileExist file)
357 dir_ok <- io (checkPerms ".")
358 file_ok <- io (checkPerms file)
359 when (dir_ok && file_ok) $ do
360 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
363 Right hdl -> runCommands (fileLoop hdl False False)
365 when (read_dot_files) $ do
366 -- Read in $HOME/.ghci
367 either_dir <- io (IO.try getHomeDirectory)
371 cwd <- io (getCurrentDirectory)
372 when (dir /= cwd) $ do
373 let file = dir ++ "/.ghci"
374 ok <- io (checkPerms file)
376 either_hdl <- io (IO.try (openFile file ReadMode))
379 Right hdl -> runCommands (fileLoop hdl False False)
381 -- Perform a :load for files given on the GHCi command line
382 -- When in -e mode, if the load fails then we want to stop
383 -- immediately rather than going on to evaluate the expression.
384 when (not (null paths)) $ do
385 ok <- ghciHandle (\e -> do showException e; return Failed) $
387 when (isJust maybe_expr && failed ok) $
388 io (exitWith (ExitFailure 1))
390 -- if verbosity is greater than 0, or we are connected to a
391 -- terminal, display the prompt in the interactive loop.
392 is_tty <- io (hIsTerminalDevice stdin)
393 dflags <- getDynFlags
394 let show_prompt = verbosity dflags > 0 || is_tty
399 #if defined(mingw32_HOST_OS)
400 -- The win32 Console API mutates the first character of
401 -- type-ahead when reading from it in a non-buffered manner. Work
402 -- around this by flushing the input buffer of type-ahead characters,
403 -- but only if stdin is available.
404 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
406 Left err | isDoesNotExistError err -> return ()
407 | otherwise -> io (ioError err)
408 Right () -> return ()
410 -- enter the interactive loop
411 interactiveLoop is_tty show_prompt
413 -- just evaluate the expression we were given
418 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
421 interactiveLoop :: Bool -> Bool -> GHCi ()
422 interactiveLoop is_tty show_prompt =
423 -- Ignore ^C exceptions caught here
424 ghciHandleDyn (\e -> case e of
426 #if defined(mingw32_HOST_OS)
429 interactiveLoop is_tty show_prompt
430 _other -> return ()) $
432 ghciUnblock $ do -- unblock necessary if we recursed from the
433 -- exception handler above.
435 -- read commands from stdin
438 then runCommands readlineLoop
439 else runCommands (fileLoop stdin show_prompt is_tty)
441 runCommands (fileLoop stdin show_prompt is_tty)
445 -- NOTE: We only read .ghci files if they are owned by the current user,
446 -- and aren't world writable. Otherwise, we could be accidentally
447 -- running code planted by a malicious third party.
449 -- Furthermore, We only read ./.ghci if . is owned by the current user
450 -- and isn't writable by anyone else. I think this is sufficient: we
451 -- don't need to check .. and ../.. etc. because "." always refers to
452 -- the same directory while a process is running.
454 checkPerms :: String -> IO Bool
455 #ifdef mingw32_HOST_OS
460 Util.handle (\_ -> return False) $ do
461 st <- getFileStatus name
463 if fileOwner st /= me then do
464 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
467 let mode = fileMode st
468 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
469 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
471 putStrLn $ "*** WARNING: " ++ name ++
472 " is writable by someone else, IGNORING!"
477 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
478 fileLoop hdl show_prompt is_tty = do
479 when show_prompt $ do
482 l <- io (IO.try (hGetLine hdl))
484 Left e | isEOFError e -> return Nothing
485 | InvalidArgument <- etype -> return Nothing
486 | otherwise -> io (ioError e)
487 where etype = ioeGetErrorType e
488 -- treat InvalidArgument in the same way as EOF:
489 -- this can happen if the user closed stdin, or
490 -- perhaps did getContents which closes stdin at
493 str <- io $ consoleInputToUnicode is_tty l
496 #ifdef mingw32_HOST_OS
497 -- Convert the console input into Unicode according to the current code page.
498 -- The Windows console stores Unicode characters directly, so this is a
499 -- rather roundabout way of doing things... oh well.
500 -- See #782, #1483, #1649
501 consoleInputToUnicode :: Bool -> String -> IO String
502 consoleInputToUnicode is_tty str
504 cp <- System.Win32.getConsoleCP
505 System.Win32.stringToUnicode cp str
507 decodeStringAsUTF8 str
509 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
511 consoleInputToUnicode :: Bool -> String -> IO String
512 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
515 decodeStringAsUTF8 :: String -> IO String
516 decodeStringAsUTF8 str =
517 withCStringLen str $ \(cstr,len) ->
518 utf8DecodeString (castPtr cstr :: Ptr Word8) len
520 mkPrompt :: GHCi String
522 session <- getSession
523 (toplevs,exports) <- io (GHC.getContext session)
524 resumes <- io $ GHC.getResumeContext session
525 -- st <- getGHCiState
531 let ix = GHC.resumeHistoryIx r
533 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
535 let hist = GHC.resumeHistory r !! (ix-1)
536 span <- io$ GHC.getHistorySpan session hist
537 return (brackets (ppr (negate ix) <> char ':'
538 <+> ppr span) <> space)
540 dots | _:rs <- resumes, not (null rs) = text "... "
547 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
548 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
549 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
550 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
551 hsep (map (ppr . GHC.moduleName) exports)
553 deflt_prompt = dots <> context_bit <> modules_bit
555 f ('%':'s':xs) = deflt_prompt <> f xs
556 f ('%':'%':xs) = char '%' <> f xs
557 f (x:xs) = char x <> f xs
561 return (showSDoc (f (prompt st)))
565 readlineLoop :: GHCi (Maybe String)
568 saveSession -- for use by completion
570 l <- io (readline prompt `finally` setNonBlockingFD 0)
571 -- readline sometimes puts stdin into blocking mode,
572 -- so we need to put it back for the IO library
575 Nothing -> return Nothing
578 str <- io $ consoleInputToUnicode True l
582 queryQueue :: GHCi (Maybe String)
587 c:cs -> do setGHCiState st{ cmdqueue = cs }
590 runCommands :: GHCi (Maybe String) -> GHCi ()
591 runCommands getCmd = do
592 mb_cmd <- noSpace queryQueue
593 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
597 b <- ghciHandle handler (doCommand c)
598 if b then return () else runCommands getCmd
600 noSpace q = q >>= maybe (return Nothing)
601 (\c->case removeSpaces c of
603 ":{" -> multiLineCmd q
604 c -> return (Just c) )
608 setGHCiState st{ prompt = "%s| " }
609 mb_cmd <- collectCommand q ""
610 getGHCiState >>= \st->setGHCiState st{ prompt = p }
612 -- we can't use removeSpaces for the sublines here, so
613 -- multiline commands are somewhat more brittle against
614 -- fileformat errors (such as \r in dos input on unix),
615 -- we get rid of any extra spaces for the ":}" test;
616 -- we also avoid silent failure if ":}" is not found;
617 -- and since there is no (?) valid occurrence of \r (as
618 -- opposed to its String representation, "\r") inside a
619 -- ghci command, we replace any such with ' ' (argh:-(
620 collectCommand q c = q >>=
621 maybe (io (ioError collectError))
622 (\l->if removeSpaces l == ":}"
623 then return (Just $ removeSpaces c)
624 else collectCommand q (c++map normSpace l))
625 where normSpace '\r' = ' '
627 -- QUESTION: is userError the one to use here?
628 collectError = userError "unterminated multiline command :{ .. :}"
629 doCommand (':' : cmd) = specialCommand cmd
630 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
633 enqueueCommands :: [String] -> GHCi ()
634 enqueueCommands cmds = do
636 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
639 -- This version is for the GHC command-line option -e. The only difference
640 -- from runCommand is that it catches the ExitException exception and
641 -- exits, rather than printing out the exception.
642 runCommandEval :: String -> GHCi Bool
643 runCommandEval c = ghciHandle handleEval (doCommand c)
645 handleEval (ExitException code) = io (exitWith code)
646 handleEval e = do handler e
647 io (exitWith (ExitFailure 1))
649 doCommand (':' : command) = specialCommand command
651 = do r <- runStmt stmt GHC.RunToCompletion
653 False -> io (exitWith (ExitFailure 1))
654 -- failure to run the command causes exit(1) for ghc -e.
657 runStmt :: String -> SingleStep -> GHCi Bool
659 | null (filter (not.isSpace) stmt) = return False
660 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
662 = do st <- getGHCiState
663 session <- getSession
664 result <- io $ withProgName (progname st) $ withArgs (args st) $
665 GHC.runStmt session stmt step
666 afterRunStmt (const True) result
669 --afterRunStmt :: GHC.RunResult -> GHCi Bool
670 -- False <=> the statement failed to compile
671 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
672 afterRunStmt _ (GHC.RunException e) = throw e
673 afterRunStmt step_here run_result = do
674 session <- getSession
675 resumes <- io $ GHC.getResumeContext session
677 GHC.RunOk names -> do
678 show_types <- isOptionSet ShowType
679 when show_types $ printTypeOfNames session names
680 GHC.RunBreak _ names mb_info
681 | isNothing mb_info ||
682 step_here (GHC.resumeSpan $ head resumes) -> do
683 printForUser $ ptext SLIT("Stopped at") <+>
684 ppr (GHC.resumeSpan $ head resumes)
685 -- printTypeOfNames session names
686 let namesSorted = sortBy compareNames names
687 tythings <- catMaybes `liftM`
688 io (mapM (GHC.lookupName session) namesSorted)
689 docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
690 printForUserPartWay docs
691 maybe (return ()) runBreakCmd mb_info
692 -- run the command set with ":set stop <cmd>"
694 enqueueCommands [stop st]
696 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
697 afterRunStmt step_here >> return ()
701 io installSignalHandlers
702 b <- isOptionSet RevertCAFs
703 io (when b revertCAFs)
705 return (case run_result of GHC.RunOk _ -> True; _ -> False)
707 runBreakCmd :: GHC.BreakInfo -> GHCi ()
708 runBreakCmd info = do
709 let mod = GHC.breakInfo_module info
710 nm = GHC.breakInfo_number info
712 case [ loc | (_,loc) <- breaks st,
713 breakModule loc == mod, breakTick loc == nm ] of
715 loc:_ | null cmd -> return ()
716 | otherwise -> do enqueueCommands [cmd]; return ()
717 where cmd = onBreakCmd loc
719 printTypeOfNames :: Session -> [Name] -> GHCi ()
720 printTypeOfNames session names
721 = mapM_ (printTypeOfName session) $ sortBy compareNames names
723 compareNames :: Name -> Name -> Ordering
724 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
725 where compareWith n = (getOccString n, getSrcSpan n)
727 printTypeOfName :: Session -> Name -> GHCi ()
728 printTypeOfName session n
729 = do maybe_tything <- io (GHC.lookupName session n)
730 case maybe_tything of
732 Just thing -> printTyThing thing
735 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
737 specialCommand :: String -> GHCi Bool
738 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
739 specialCommand str = do
740 let (cmd,rest) = break isSpace str
741 maybe_cmd <- lookupCommand cmd
743 GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
745 do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
749 do io $ hPutStr stdout ("there is no last command to perform\n"
753 lookupCommand :: String -> GHCi (MaybeCommand)
754 lookupCommand "" = do
756 case last_command st of
757 Just c -> return $ GotCommand c
758 Nothing -> return NoLastCommand
759 lookupCommand str = do
760 mc <- io $ lookupCommand' str
762 setGHCiState st{ last_command = mc }
764 Just c -> GotCommand c
765 Nothing -> BadCommand
767 lookupCommand' :: String -> IO (Maybe Command)
768 lookupCommand' str = do
769 macros <- readIORef macros_ref
770 let cmds = builtin_commands ++ macros
771 -- look for exact match first, then the first prefix match
772 return $ case [ c | c <- cmds, str == cmdName c ] of
774 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
778 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
779 getCurrentBreakSpan = do
780 session <- getSession
781 resumes <- io $ GHC.getResumeContext session
785 let ix = GHC.resumeHistoryIx r
787 then return (Just (GHC.resumeSpan r))
789 let hist = GHC.resumeHistory r !! (ix-1)
790 span <- io $ GHC.getHistorySpan session hist
793 getCurrentBreakModule :: GHCi (Maybe Module)
794 getCurrentBreakModule = do
795 session <- getSession
796 resumes <- io $ GHC.getResumeContext session
800 let ix = GHC.resumeHistoryIx r
802 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
804 let hist = GHC.resumeHistory r !! (ix-1)
805 return $ Just $ GHC.getHistoryModule hist
807 -----------------------------------------------------------------------------
810 noArgs :: GHCi () -> String -> GHCi ()
812 noArgs _ _ = io $ putStrLn "This command takes no arguments"
814 help :: String -> GHCi ()
815 help _ = io (putStr helpText)
817 info :: String -> GHCi ()
818 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
819 info s = do { let names = words s
820 ; session <- getSession
821 ; dflags <- getDynFlags
822 ; let pefas = dopt Opt_PrintExplicitForalls dflags
823 ; mapM_ (infoThing pefas session) names }
825 infoThing pefas session str = io $ do
826 names <- GHC.parseName session str
827 mb_stuffs <- mapM (GHC.getInfo session) names
828 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
829 unqual <- GHC.getPrintUnqual session
830 putStrLn (showSDocForUser unqual $
831 vcat (intersperse (text "") $
832 map (pprInfo pefas) filtered))
834 -- Filter out names whose parent is also there Good
835 -- example is '[]', which is both a type and data
836 -- constructor in the same type
837 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
838 filterOutChildren get_thing xs
839 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
841 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
843 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
844 pprInfo pefas (thing, fixity, insts)
845 = pprTyThingInContextLoc pefas thing
846 $$ show_fixity fixity
847 $$ vcat (map GHC.pprInstance insts)
850 | fix == GHC.defaultFixity = empty
851 | otherwise = ppr fix <+> ppr (GHC.getName thing)
853 runMain :: String -> GHCi ()
855 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
856 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
858 addModule :: [FilePath] -> GHCi ()
860 io (revertCAFs) -- always revert CAFs on load/add.
861 files <- mapM expandPath files
862 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
863 session <- getSession
864 io (mapM_ (GHC.addTarget session) targets)
865 prev_context <- io $ GHC.getContext session
866 ok <- io (GHC.load session LoadAllTargets)
867 afterLoad ok session False prev_context
869 changeDirectory :: String -> GHCi ()
870 changeDirectory "" = do
871 -- :cd on its own changes to the user's home directory
872 either_dir <- io (IO.try getHomeDirectory)
875 Right dir -> changeDirectory dir
876 changeDirectory dir = do
877 session <- getSession
878 graph <- io (GHC.getModuleGraph session)
879 when (not (null graph)) $
880 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
881 prev_context <- io $ GHC.getContext session
882 io (GHC.setTargets session [])
883 io (GHC.load session LoadAllTargets)
884 setContextAfterLoad session prev_context []
885 io (GHC.workingDirectoryChanged session)
886 dir <- expandPath dir
887 io (setCurrentDirectory dir)
889 editFile :: String -> GHCi ()
891 do file <- if null str then chooseEditFile else return str
895 $ throwDyn (CmdLineError "editor not set, use :set editor")
896 io $ system (cmd ++ ' ':file)
899 -- The user didn't specify a file so we pick one for them.
900 -- Our strategy is to pick the first module that failed to load,
901 -- or otherwise the first target.
903 -- XXX: Can we figure out what happened if the depndecy analysis fails
904 -- (e.g., because the porgrammeer mistyped the name of a module)?
905 -- XXX: Can we figure out the location of an error to pass to the editor?
906 -- XXX: if we could figure out the list of errors that occured during the
907 -- last load/reaload, then we could start the editor focused on the first
909 chooseEditFile :: GHCi String
911 do session <- getSession
912 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
914 graph <- io (GHC.getModuleGraph session)
915 failed_graph <- filterM hasFailed graph
916 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
918 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
921 case pick (order failed_graph) of
922 Just file -> return file
924 do targets <- io (GHC.getTargets session)
925 case msum (map fromTarget targets) of
926 Just file -> return file
927 Nothing -> throwDyn (CmdLineError "No files to edit.")
929 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
930 fromTarget _ = Nothing -- when would we get a module target?
932 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
933 defineMacro overwrite s = do
934 let (macro_name, definition) = break isSpace s
935 macros <- io (readIORef macros_ref)
936 let defined = map cmdName macros
939 then io $ putStrLn "no macros defined"
940 else io $ putStr ("the following macros are defined:\n" ++
943 if (not overwrite && macro_name `elem` defined)
944 then throwDyn (CmdLineError
945 ("macro '" ++ macro_name ++ "' is already defined"))
948 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
950 -- give the expression a type signature, so we can be sure we're getting
951 -- something of the right type.
952 let new_expr = '(' : definition ++ ") :: String -> IO String"
954 -- compile the expression
956 maybe_hv <- io (GHC.compileExpr cms new_expr)
959 Just hv -> io (writeIORef macros_ref --
960 (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)]))
962 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
964 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
965 enqueueCommands (lines str)
968 undefineMacro :: String -> GHCi ()
969 undefineMacro str = mapM_ undef (words str)
970 where undef macro_name = do
971 cmds <- io (readIORef macros_ref)
972 if (macro_name `notElem` map cmdName cmds)
973 then throwDyn (CmdLineError
974 ("macro '" ++ macro_name ++ "' is not defined"))
976 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
978 cmdCmd :: String -> GHCi ()
980 let expr = '(' : str ++ ") :: IO String"
981 session <- getSession
982 maybe_hv <- io (GHC.compileExpr session expr)
986 cmds <- io $ (unsafeCoerce# hv :: IO String)
987 enqueueCommands (lines cmds)
990 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
991 loadModule fs = timeIt (loadModule' fs)
993 loadModule_ :: [FilePath] -> GHCi ()
994 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
996 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
997 loadModule' files = do
998 session <- getSession
999 prev_context <- io $ GHC.getContext session
1002 discardActiveBreakPoints
1003 io (GHC.setTargets session [])
1004 io (GHC.load session LoadAllTargets)
1007 let (filenames, phases) = unzip files
1008 exp_filenames <- mapM expandPath filenames
1009 let files' = zip exp_filenames phases
1010 targets <- io (mapM (uncurry GHC.guessTarget) files')
1012 -- NOTE: we used to do the dependency anal first, so that if it
1013 -- fails we didn't throw away the current set of modules. This would
1014 -- require some re-working of the GHC interface, so we'll leave it
1015 -- as a ToDo for now.
1017 io (GHC.setTargets session targets)
1018 doLoad session False prev_context LoadAllTargets
1020 checkModule :: String -> GHCi ()
1022 let modl = GHC.mkModuleName m
1023 session <- getSession
1024 prev_context <- io $ GHC.getContext session
1025 result <- io (GHC.checkModule session modl False)
1027 Nothing -> io $ putStrLn "Nothing"
1028 Just r -> io $ putStrLn (showSDoc (
1029 case GHC.checkedModuleInfo r of
1030 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1032 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1034 (text "global names: " <+> ppr global) $$
1035 (text "local names: " <+> ppr local)
1037 afterLoad (successIf (isJust result)) session False prev_context
1039 reloadModule :: String -> GHCi ()
1041 session <- getSession
1042 prev_context <- io $ GHC.getContext session
1043 doLoad session True prev_context $
1044 if null m then LoadAllTargets
1045 else LoadUpTo (GHC.mkModuleName m)
1048 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1049 doLoad session retain_context prev_context howmuch = do
1050 -- turn off breakpoints before we load: we can't turn them off later, because
1051 -- the ModBreaks will have gone away.
1052 discardActiveBreakPoints
1053 ok <- io (GHC.load session howmuch)
1054 afterLoad ok session retain_context prev_context
1057 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1058 afterLoad ok session retain_context prev_context = do
1059 io (revertCAFs) -- always revert CAFs on load.
1061 loaded_mod_summaries <- getLoadedModules session
1062 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1063 loaded_mod_names = map GHC.moduleName loaded_mods
1064 modulesLoadedMsg ok loaded_mod_names
1067 if not retain_context
1069 setGHCiState st{ remembered_ctx = Nothing }
1070 setContextAfterLoad session prev_context loaded_mod_summaries
1072 -- figure out which modules we can keep in the context, which we
1073 -- have to put back, and which we have to remember because they
1074 -- are (temporarily) unavailable. See ghci.prog009, #1873, #1360
1075 let (as,bs) = prev_context
1076 as1 = filter isHomeModule as -- package modules are kept anyway
1077 bs1 = filter isHomeModule bs
1078 (as_ok, as_bad) = partition (`elem` loaded_mods) as1
1079 (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1
1080 (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st)
1081 (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as
1082 (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs
1083 as' = nub (as_ok++rem_as_ok)
1084 bs' = nub (bs_ok++rem_bs_ok)
1085 rem_as' = nub (rem_as_bad ++ as_bad)
1086 rem_bs' = nub (rem_bs_bad ++ bs_bad)
1088 -- Put back into the context any modules that we previously had
1089 -- to drop because they weren't available (rem_as_ok, rem_bs_ok).
1090 setContextKeepingPackageModules session prev_context (as',bs')
1092 -- If compilation failed, remember any modules that we are unable
1093 -- to load, so that we can put them back in the context in the future.
1095 Succeeded -> setGHCiState st{ remembered_ctx = Nothing }
1096 Failed -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') }
1100 setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi ()
1101 setContextAfterLoad session prev [] = do
1102 prel_mod <- getPrelude
1103 setContextKeepingPackageModules session prev ([], [prel_mod])
1104 setContextAfterLoad session prev ms = do
1105 -- load a target if one is available, otherwise load the topmost module.
1106 targets <- io (GHC.getTargets session)
1107 case [ m | Just m <- map (findTarget ms) targets ] of
1109 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1110 load_this (last graph')
1115 = case filter (`matches` t) ms of
1119 summary `matches` Target (TargetModule m) _
1120 = GHC.ms_mod_name summary == m
1121 summary `matches` Target (TargetFile f _) _
1122 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1126 load_this summary | m <- GHC.ms_mod summary = do
1127 b <- io (GHC.moduleIsInterpreted session m)
1128 if b then setContextKeepingPackageModules session prev ([m], [])
1130 prel_mod <- getPrelude
1131 setContextKeepingPackageModules session prev ([],[prel_mod,m])
1133 -- | Keep any package modules (except Prelude) when changing the context.
1134 setContextKeepingPackageModules
1136 -> ([Module],[Module]) -- previous context
1137 -> ([Module],[Module]) -- new context
1139 setContextKeepingPackageModules session prev_context (as,bs) = do
1140 let (_,bs0) = prev_context
1141 prel_mod <- getPrelude
1142 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1143 let bs1 = if null as then nub (prel_mod : bs) else bs
1144 io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1146 isHomeModule :: Module -> Bool
1147 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1149 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1150 modulesLoadedMsg ok mods = do
1151 dflags <- getDynFlags
1152 when (verbosity dflags > 0) $ do
1154 | null mods = text "none."
1155 | otherwise = hsep (
1156 punctuate comma (map ppr mods)) <> text "."
1159 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1161 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1164 typeOfExpr :: String -> GHCi ()
1166 = do cms <- getSession
1167 maybe_ty <- io (GHC.exprType cms str)
1169 Nothing -> return ()
1170 Just ty -> do dflags <- getDynFlags
1171 let pefas = dopt Opt_PrintExplicitForalls dflags
1172 printForUser $ text str <+> dcolon
1173 <+> pprTypeForUser pefas ty
1175 kindOfType :: String -> GHCi ()
1177 = do cms <- getSession
1178 maybe_ty <- io (GHC.typeKind cms str)
1180 Nothing -> return ()
1181 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1183 quit :: String -> GHCi Bool
1184 quit _ = return True
1186 shellEscape :: String -> GHCi Bool
1187 shellEscape str = io (system str >> return False)
1189 -----------------------------------------------------------------------------
1190 -- Browsing a module's contents
1192 browseCmd :: Bool -> String -> GHCi ()
1195 ['*':s] | looksLikeModuleName s -> do
1196 m <- wantInterpretedModule s
1197 browseModule bang m False
1198 [s] | looksLikeModuleName s -> do
1200 browseModule bang m True
1203 (as,bs) <- io $ GHC.getContext s
1204 -- Guess which module the user wants to browse. Pick
1205 -- modules that are interpreted first. The most
1206 -- recently-added module occurs last, it seems.
1208 (as@(_:_), _) -> browseModule bang (last as) True
1209 ([], bs@(_:_)) -> browseModule bang (last bs) True
1210 ([], []) -> throwDyn (CmdLineError ":browse: no current module")
1211 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1213 -- without bang, show items in context of their parents and omit children
1214 -- with bang, show class methods and data constructors separately, and
1215 -- indicate import modules, to aid qualifying unqualified names
1216 -- with sorted, sort items alphabetically
1217 browseModule :: Bool -> Module -> Bool -> GHCi ()
1218 browseModule bang modl exports_only = do
1220 -- :browse! reports qualifiers wrt current context
1221 current_unqual <- io (GHC.getPrintUnqual s)
1222 -- Temporarily set the context to the module we're interested in,
1223 -- just so we can get an appropriate PrintUnqualified
1224 (as,bs) <- io (GHC.getContext s)
1225 prel_mod <- getPrelude
1226 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1227 else GHC.setContext s [modl] [])
1228 target_unqual <- io (GHC.getPrintUnqual s)
1229 io (GHC.setContext s as bs)
1231 let unqual = if bang then current_unqual else target_unqual
1233 mb_mod_info <- io $ GHC.getModuleInfo s modl
1235 Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1236 GHC.moduleNameString (GHC.moduleName modl)))
1238 dflags <- getDynFlags
1240 | exports_only = GHC.modInfoExports mod_info
1241 | otherwise = GHC.modInfoTopLevelScope mod_info
1244 -- sort alphabetically name, but putting
1245 -- locally-defined identifiers first.
1246 -- We would like to improve this; see #1799.
1247 sorted_names = loc_sort local ++ occ_sort external
1249 (local,external) = partition ((==modl) . nameModule) names
1250 occ_sort = sortBy (compare `on` nameOccName)
1251 -- try to sort by src location. If the first name in
1252 -- our list has a good source location, then they all should.
1254 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1255 = sortBy (compare `on` nameSrcSpan) names
1259 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1260 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1262 rdr_env <- io $ GHC.getGRE s
1264 let pefas = dopt Opt_PrintExplicitForalls dflags
1265 things | bang = catMaybes mb_things
1266 | otherwise = filtered_things
1267 pretty | bang = pprTyThing
1268 | otherwise = pprTyThingInContext
1270 labels [] = text "-- not currently imported"
1271 labels l = text $ intercalate "\n" $ map qualifier l
1272 qualifier = maybe "-- defined locally"
1273 (("-- imported via "++) . intercalate ", "
1274 . map GHC.moduleNameString)
1275 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1276 modNames = map (importInfo . GHC.getName) things
1278 -- annotate groups of imports with their import modules
1279 -- the default ordering is somewhat arbitrary, so we group
1280 -- by header and sort groups; the names themselves should
1281 -- really come in order of source appearance.. (trac #1799)
1282 annotate mts = concatMap (\(m,ts)->labels m:ts)
1283 $ sortBy cmpQualifiers $ group mts
1284 where cmpQualifiers =
1285 compare `on` (map (fmap (map moduleNameFS)) . fst)
1287 group mts@((m,_):_) = (m,map snd g) : group ng
1288 where (g,ng) = partition ((==m).fst) mts
1290 let prettyThings = map (pretty pefas) things
1291 prettyThings' | bang = annotate $ zip modNames prettyThings
1292 | otherwise = prettyThings
1293 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1294 -- ToDo: modInfoInstances currently throws an exception for
1295 -- package modules. When it works, we can do this:
1296 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1298 -----------------------------------------------------------------------------
1299 -- Setting the module context
1301 setContext :: String -> GHCi ()
1303 | all sensible mods = fn mods
1304 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1306 (fn, mods) = case str of
1307 '+':stuff -> (addToContext, words stuff)
1308 '-':stuff -> (removeFromContext, words stuff)
1309 stuff -> (newContext, words stuff)
1311 sensible ('*':m) = looksLikeModuleName m
1312 sensible m = looksLikeModuleName m
1314 separate :: Session -> [String] -> [Module] -> [Module]
1315 -> GHCi ([Module],[Module])
1316 separate _ [] as bs = return (as,bs)
1317 separate session (('*':str):ms) as bs = do
1318 m <- wantInterpretedModule str
1319 separate session ms (m:as) bs
1320 separate session (str:ms) as bs = do
1321 m <- lookupModule str
1322 separate session ms as (m:bs)
1324 newContext :: [String] -> GHCi ()
1325 newContext strs = do
1327 (as,bs) <- separate s strs [] []
1328 prel_mod <- getPrelude
1329 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1330 io $ GHC.setContext s as bs'
1333 addToContext :: [String] -> GHCi ()
1334 addToContext strs = do
1336 (as,bs) <- io $ GHC.getContext s
1338 (new_as,new_bs) <- separate s strs [] []
1340 let as_to_add = new_as \\ (as ++ bs)
1341 bs_to_add = new_bs \\ (as ++ bs)
1343 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1346 removeFromContext :: [String] -> GHCi ()
1347 removeFromContext strs = do
1349 (as,bs) <- io $ GHC.getContext s
1351 (as_to_remove,bs_to_remove) <- separate s strs [] []
1353 let as' = as \\ (as_to_remove ++ bs_to_remove)
1354 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1356 io $ GHC.setContext s as' bs'
1358 ----------------------------------------------------------------------------
1361 -- set options in the interpreter. Syntax is exactly the same as the
1362 -- ghc command line, except that certain options aren't available (-C,
1365 -- This is pretty fragile: most options won't work as expected. ToDo:
1366 -- figure out which ones & disallow them.
1368 setCmd :: String -> GHCi ()
1370 = do st <- getGHCiState
1371 let opts = options st
1372 io $ putStrLn (showSDoc (
1373 text "options currently set: " <>
1376 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1378 dflags <- getDynFlags
1379 io $ putStrLn (showSDoc (
1380 vcat (text "GHCi-specific dynamic flag settings:"
1381 :map (flagSetting dflags) ghciFlags)
1383 io $ putStrLn (showSDoc (
1384 vcat (text "other dynamic, non-language, flag settings:"
1385 :map (flagSetting dflags) nonLanguageDynFlags)
1387 where flagSetting dflags (str,f)
1388 | dopt f dflags = text " " <> text "-f" <> text str
1389 | otherwise = text " " <> text "-fno-" <> text str
1390 (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
1392 nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1394 flags = [Opt_PrintExplicitForalls
1395 ,Opt_PrintBindResult
1396 ,Opt_BreakOnException
1398 ,Opt_PrintEvldWithShow
1401 = case toArgs str of
1402 ("args":args) -> setArgs args
1403 ("prog":prog) -> setProg prog
1404 ("prompt":_) -> setPrompt (after 6)
1405 ("editor":_) -> setEditor (after 6)
1406 ("stop":_) -> setStop (after 4)
1407 wds -> setOptions wds
1408 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1410 setArgs, setProg, setOptions :: [String] -> GHCi ()
1411 setEditor, setStop, setPrompt :: String -> GHCi ()
1415 setGHCiState st{ args = args }
1419 setGHCiState st{ progname = prog }
1421 io (hPutStrLn stderr "syntax: :set prog <progname>")
1425 setGHCiState st{ editor = cmd }
1427 setStop str@(c:_) | isDigit c
1428 = do let (nm_str,rest) = break (not.isDigit) str
1431 let old_breaks = breaks st
1432 if all ((/= nm) . fst) old_breaks
1433 then printForUser (text "Breakpoint" <+> ppr nm <+>
1434 text "does not exist")
1436 let new_breaks = map fn old_breaks
1437 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1438 | otherwise = (i,loc)
1439 setGHCiState st{ breaks = new_breaks }
1442 setGHCiState st{ stop = cmd }
1444 setPrompt value = do
1447 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1448 else setGHCiState st{ prompt = remQuotes value }
1450 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1454 do -- first, deal with the GHCi opts (+s, +t, etc.)
1455 let (plus_opts, minus_opts) = partitionWith isPlus wds
1456 mapM_ setOpt plus_opts
1457 -- then, dynamic flags
1458 newDynFlags minus_opts
1460 newDynFlags :: [String] -> GHCi ()
1461 newDynFlags minus_opts = do
1462 dflags <- getDynFlags
1463 let pkg_flags = packageFlags dflags
1464 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1466 if (not (null leftovers))
1467 then throwDyn (CmdLineError ("unrecognised flags: " ++
1471 new_pkgs <- setDynFlags dflags'
1473 -- if the package flags changed, we should reset the context
1474 -- and link the new packages.
1475 dflags <- getDynFlags
1476 when (packageFlags dflags /= pkg_flags) $ do
1477 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1478 session <- getSession
1479 io (GHC.setTargets session [])
1480 io (GHC.load session LoadAllTargets)
1481 io (linkPackages dflags new_pkgs)
1482 -- package flags changed, we can't re-use any of the old context
1483 setContextAfterLoad session ([],[]) []
1487 unsetOptions :: String -> GHCi ()
1489 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1490 let opts = words str
1491 (minus_opts, rest1) = partition isMinus opts
1492 (plus_opts, rest2) = partitionWith isPlus rest1
1494 if (not (null rest2))
1495 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1498 mapM_ unsetOpt plus_opts
1500 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1501 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1503 no_flags <- mapM no_flag minus_opts
1504 newDynFlags no_flags
1506 isMinus :: String -> Bool
1507 isMinus ('-':_) = True
1510 isPlus :: String -> Either String String
1511 isPlus ('+':opt) = Left opt
1512 isPlus other = Right other
1514 setOpt, unsetOpt :: String -> GHCi ()
1517 = case strToGHCiOpt str of
1518 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1519 Just o -> setOption o
1522 = case strToGHCiOpt str of
1523 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1524 Just o -> unsetOption o
1526 strToGHCiOpt :: String -> (Maybe GHCiOption)
1527 strToGHCiOpt "s" = Just ShowTiming
1528 strToGHCiOpt "t" = Just ShowType
1529 strToGHCiOpt "r" = Just RevertCAFs
1530 strToGHCiOpt _ = Nothing
1532 optToStr :: GHCiOption -> String
1533 optToStr ShowTiming = "s"
1534 optToStr ShowType = "t"
1535 optToStr RevertCAFs = "r"
1537 -- ---------------------------------------------------------------------------
1540 showCmd :: String -> GHCi ()
1544 ["args"] -> io $ putStrLn (show (args st))
1545 ["prog"] -> io $ putStrLn (show (progname st))
1546 ["prompt"] -> io $ putStrLn (show (prompt st))
1547 ["editor"] -> io $ putStrLn (show (editor st))
1548 ["stop"] -> io $ putStrLn (show (stop st))
1549 ["modules" ] -> showModules
1550 ["bindings"] -> showBindings
1551 ["linker"] -> io showLinkerState
1552 ["breaks"] -> showBkptTable
1553 ["context"] -> showContext
1554 ["packages"] -> showPackages
1555 ["languages"] -> showLanguages
1556 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1558 showModules :: GHCi ()
1560 session <- getSession
1561 loaded_mods <- getLoadedModules session
1562 -- we want *loaded* modules only, see #1734
1563 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1564 mapM_ show_one loaded_mods
1566 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1567 getLoadedModules session = do
1568 graph <- io (GHC.getModuleGraph session)
1569 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1571 showBindings :: GHCi ()
1574 bindings <- io (GHC.getBindings s)
1575 docs <- io$ pprTypeAndContents s
1576 [ id | AnId id <- sortBy compareTyThings bindings]
1577 printForUserPartWay docs
1579 compareTyThings :: TyThing -> TyThing -> Ordering
1580 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1582 printTyThing :: TyThing -> GHCi ()
1583 printTyThing tyth = do dflags <- getDynFlags
1584 let pefas = dopt Opt_PrintExplicitForalls dflags
1585 printForUser (pprTyThing pefas tyth)
1587 showBkptTable :: GHCi ()
1590 printForUser $ prettyLocations (breaks st)
1592 showContext :: GHCi ()
1594 session <- getSession
1595 resumes <- io $ GHC.getResumeContext session
1596 printForUser $ vcat (map pp_resume (reverse resumes))
1599 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1600 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1602 showPackages :: GHCi ()
1604 pkg_flags <- fmap packageFlags getDynFlags
1605 io $ putStrLn $ showSDoc $ vcat $
1606 text ("active package flags:"++if null pkg_flags then " none" else "")
1607 : map showFlag pkg_flags
1608 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1609 io $ putStrLn $ showSDoc $ vcat $
1610 text "packages currently loaded:"
1611 : map (nest 2 . text . packageIdString) pkg_ids
1612 where showFlag (ExposePackage p) = text $ " -package " ++ p
1613 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1614 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1616 showLanguages :: GHCi ()
1618 dflags <- getDynFlags
1619 io $ putStrLn $ showSDoc $ vcat $
1620 text "active language flags:" :
1621 [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1623 -- -----------------------------------------------------------------------------
1626 completeNone :: String -> IO [String]
1627 completeNone _w = return []
1629 completeMacro, completeIdentifier, completeModule,
1630 completeHomeModule, completeSetOptions, completeFilename,
1631 completeHomeModuleOrFile
1632 :: String -> IO [String]
1635 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1636 completeWord w start end = do
1637 line <- Readline.getLineBuffer
1638 let line_words = words (dropWhile isSpace line)
1640 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1642 | ((':':c) : _) <- line_words -> do
1643 completionVars <- lookupCompletionVars c
1644 case completionVars of
1645 (Nothing,complete) -> wrapCompleter complete w
1646 (Just breakChars,complete)
1647 -> let (n,w') = selectWord
1648 (words' (`elem` breakChars) 0 line)
1649 complete' w = do rets <- complete w
1650 return (map (drop n) rets)
1651 in wrapCompleter complete' w'
1652 | ("import" : _) <- line_words ->
1653 wrapCompleter completeModule w
1655 --printf "complete %s, start = %d, end = %d\n" w start end
1656 wrapCompleter completeIdentifier w
1657 where words' _ _ [] = []
1658 words' isBreak n str = let (w,r) = break isBreak str
1659 (s,r') = span isBreak r
1660 in (n,w):words' isBreak (n+length w+length s) r'
1661 -- In a Haskell expression we want to parse 'a-b' as three words
1662 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1663 -- only be a single word.
1664 selectWord [] = (0,w)
1665 selectWord ((offset,x):xs)
1666 | offset+length x >= start = (start-offset,take (end-offset) x)
1667 | otherwise = selectWord xs
1669 lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars,
1671 lookupCompletionVars c = do
1672 maybe_cmd <- lookupCommand' c
1674 Just (_,_,ws,f) -> return (ws,f)
1675 Nothing -> return (Just filenameWordBreakChars,
1679 completeCmd :: String -> IO [String]
1681 cmds <- readIORef macros_ref
1682 return (filter (w `isPrefixOf`) (map (':':)
1683 (map cmdName (builtin_commands ++ cmds))))
1685 completeMacro w = do
1686 cmds <- readIORef macros_ref
1687 return (filter (w `isPrefixOf`) (map cmdName cmds))
1689 completeIdentifier w = do
1691 rdrs <- GHC.getRdrNamesInScope s
1692 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1694 completeModule w = do
1696 dflags <- GHC.getSessionDynFlags s
1697 let pkg_mods = allExposedModules dflags
1698 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1700 completeHomeModule w = do
1702 g <- GHC.getModuleGraph s
1703 let home_mods = map GHC.ms_mod_name g
1704 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1706 completeSetOptions w = do
1707 return (filter (w `isPrefixOf`) options)
1708 where options = "args":"prog":allFlags
1710 completeFilename w = do
1711 ws <- Readline.filenameCompletionFunction w
1713 -- If we only found one result, and it's a directory,
1714 -- add a trailing slash.
1716 isDir <- expandPathIO file >>= doesDirectoryExist
1717 if isDir && last file /= '/'
1718 then return [file ++ "/"]
1723 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1725 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1726 unionComplete f1 f2 w = do
1731 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1732 wrapCompleter fun w = do
1735 [] -> Readline.setAttemptedCompletionOver True >> return Nothing
1736 [x] -> -- Add a trailing space, unless it already has an appended slash.
1737 let appended = if last x == '/' then x else x ++ " "
1738 in return (Just (appended,[]))
1739 xs -> case getCommonPrefix xs of
1740 "" -> return (Just ("",xs))
1741 pref -> return (Just (pref,xs))
1743 getCommonPrefix :: [String] -> String
1744 getCommonPrefix [] = ""
1745 getCommonPrefix (s:ss) = foldl common s ss
1746 where common _s "" = ""
1748 common (c:cs) (d:ds)
1749 | c == d = c : common cs ds
1752 allExposedModules :: DynFlags -> [ModuleName]
1753 allExposedModules dflags
1754 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1756 pkg_db = pkgIdMap (pkgState dflags)
1758 completeMacro = completeNone
1759 completeIdentifier = completeNone
1760 completeModule = completeNone
1761 completeHomeModule = completeNone
1762 completeSetOptions = completeNone
1763 completeFilename = completeNone
1764 completeHomeModuleOrFile=completeNone
1767 -- ---------------------------------------------------------------------------
1768 -- User code exception handling
1770 -- This is the exception handler for exceptions generated by the
1771 -- user's code and exceptions coming from children sessions;
1772 -- it normally just prints out the exception. The
1773 -- handler must be recursive, in case showing the exception causes
1774 -- more exceptions to be raised.
1776 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1777 -- raising another exception. We therefore don't put the recursive
1778 -- handler arond the flushing operation, so if stderr is closed
1779 -- GHCi will just die gracefully rather than going into an infinite loop.
1780 handler :: Exception -> GHCi Bool
1782 handler exception = do
1784 io installSignalHandlers
1785 ghciHandle handler (showException exception >> return False)
1787 showException :: Exception -> GHCi ()
1788 showException (DynException dyn) =
1789 case fromDynamic dyn of
1790 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1791 Just Interrupted -> io (putStrLn "Interrupted.")
1792 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1793 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1794 Just other_ghc_ex -> io (print other_ghc_ex)
1796 showException other_exception
1797 = io (putStrLn ("*** Exception: " ++ show other_exception))
1799 -----------------------------------------------------------------------------
1800 -- recursive exception handlers
1802 -- Don't forget to unblock async exceptions in the handler, or if we're
1803 -- in an exception loop (eg. let a = error a in a) the ^C exception
1804 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1806 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1807 ghciHandle h (GHCi m) = GHCi $ \s ->
1808 Exception.catch (m s)
1809 (\e -> unGHCi (ghciUnblock (h e)) s)
1811 ghciUnblock :: GHCi a -> GHCi a
1812 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1815 -- ----------------------------------------------------------------------------
1818 expandPath :: String -> GHCi String
1819 expandPath path = io (expandPathIO path)
1821 expandPathIO :: String -> IO String
1823 case dropWhile isSpace path of
1825 tilde <- getHomeDirectory -- will fail if HOME not defined
1826 return (tilde ++ '/':d)
1830 wantInterpretedModule :: String -> GHCi Module
1831 wantInterpretedModule str = do
1832 session <- getSession
1833 modl <- lookupModule str
1834 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1835 when (not is_interpreted) $
1836 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1839 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1840 -> (Name -> GHCi ())
1842 wantNameFromInterpretedModule noCanDo str and_then = do
1843 session <- getSession
1844 names <- io $ GHC.parseName session str
1848 let modl = GHC.nameModule n
1849 if not (GHC.isExternalName n)
1850 then noCanDo n $ ppr n <>
1851 text " is not defined in an interpreted module"
1853 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1854 if not is_interpreted
1855 then noCanDo n $ text "module " <> ppr modl <>
1856 text " is not interpreted"
1859 -- -----------------------------------------------------------------------------
1860 -- commands for debugger
1862 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1863 sprintCmd = pprintCommand False False
1864 printCmd = pprintCommand True False
1865 forceCmd = pprintCommand False True
1867 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1868 pprintCommand bind force str = do
1869 session <- getSession
1870 io $ pprintClosureCommand session bind force str
1872 stepCmd :: String -> GHCi ()
1873 stepCmd [] = doContinue (const True) GHC.SingleStep
1874 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1876 stepLocalCmd :: String -> GHCi ()
1877 stepLocalCmd [] = do
1878 mb_span <- getCurrentBreakSpan
1880 Nothing -> stepCmd []
1882 Just mod <- getCurrentBreakModule
1883 current_toplevel_decl <- enclosingTickSpan mod loc
1884 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1886 stepLocalCmd expression = stepCmd expression
1888 stepModuleCmd :: String -> GHCi ()
1889 stepModuleCmd [] = do
1890 mb_span <- getCurrentBreakSpan
1892 Nothing -> stepCmd []
1894 Just span <- getCurrentBreakSpan
1895 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1896 doContinue f GHC.SingleStep
1898 stepModuleCmd expression = stepCmd expression
1900 -- | Returns the span of the largest tick containing the srcspan given
1901 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1902 enclosingTickSpan mod src = do
1903 ticks <- getTickArray mod
1904 let line = srcSpanStartLine src
1905 ASSERT (inRange (bounds ticks) line) do
1906 let enclosing_spans = [ span | (_,span) <- ticks ! line
1907 , srcSpanEnd span >= srcSpanEnd src]
1908 return . head . sortBy leftmost_largest $ enclosing_spans
1910 traceCmd :: String -> GHCi ()
1911 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1912 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1914 continueCmd :: String -> GHCi ()
1915 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1917 -- doContinue :: SingleStep -> GHCi ()
1918 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1919 doContinue pred step = do
1920 session <- getSession
1921 runResult <- io $ GHC.resume session step
1922 afterRunStmt pred runResult
1925 abandonCmd :: String -> GHCi ()
1926 abandonCmd = noArgs $ do
1928 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1929 when (not b) $ io $ putStrLn "There is no computation running."
1932 deleteCmd :: String -> GHCi ()
1933 deleteCmd argLine = do
1934 deleteSwitch $ words argLine
1936 deleteSwitch :: [String] -> GHCi ()
1938 io $ putStrLn "The delete command requires at least one argument."
1939 -- delete all break points
1940 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1941 deleteSwitch idents = do
1942 mapM_ deleteOneBreak idents
1944 deleteOneBreak :: String -> GHCi ()
1946 | all isDigit str = deleteBreak (read str)
1947 | otherwise = return ()
1949 historyCmd :: String -> GHCi ()
1951 | null arg = history 20
1952 | all isDigit arg = history (read arg)
1953 | otherwise = io $ putStrLn "Syntax: :history [num]"
1957 resumes <- io $ GHC.getResumeContext s
1959 [] -> io $ putStrLn "Not stopped at a breakpoint"
1961 let hist = GHC.resumeHistory r
1962 (took,rest) = splitAt num hist
1964 [] -> io $ putStrLn $
1965 "Empty history. Perhaps you forgot to use :trace?"
1967 spans <- mapM (io . GHC.getHistorySpan s) took
1968 let nums = map (printf "-%-3d:") [(1::Int)..]
1969 names = map GHC.historyEnclosingDecl took
1970 printForUser (vcat(zipWith3
1971 (\x y z -> x <+> y <+> z)
1973 (map (bold . ppr) names)
1974 (map (parens . ppr) spans)))
1975 io $ putStrLn $ if null rest then "<end of history>" else "..."
1977 bold :: SDoc -> SDoc
1978 bold c | do_bold = text start_bold <> c <> text end_bold
1981 backCmd :: String -> GHCi ()
1982 backCmd = noArgs $ do
1984 (names, _, span) <- io $ GHC.back s
1985 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1986 printTypeOfNames s names
1987 -- run the command set with ":set stop <cmd>"
1989 enqueueCommands [stop st]
1991 forwardCmd :: String -> GHCi ()
1992 forwardCmd = noArgs $ do
1994 (names, ix, span) <- io $ GHC.forward s
1995 printForUser $ (if (ix == 0)
1996 then ptext SLIT("Stopped at")
1997 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1998 printTypeOfNames s names
1999 -- run the command set with ":set stop <cmd>"
2001 enqueueCommands [stop st]
2003 -- handle the "break" command
2004 breakCmd :: String -> GHCi ()
2005 breakCmd argLine = do
2006 session <- getSession
2007 breakSwitch session $ words argLine
2009 breakSwitch :: Session -> [String] -> GHCi ()
2010 breakSwitch _session [] = do
2011 io $ putStrLn "The break command requires at least one argument."
2012 breakSwitch session (arg1:rest)
2013 | looksLikeModuleName arg1 = do
2014 mod <- wantInterpretedModule arg1
2015 breakByModule mod rest
2016 | all isDigit arg1 = do
2017 (toplevel, _) <- io $ GHC.getContext session
2019 (mod : _) -> breakByModuleLine mod (read arg1) rest
2021 io $ putStrLn "Cannot find default module for breakpoint."
2022 io $ putStrLn "Perhaps no modules are loaded for debugging?"
2023 | otherwise = do -- try parsing it as an identifier
2024 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2025 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2026 if GHC.isGoodSrcLoc loc
2027 then findBreakAndSet (GHC.nameModule name) $
2028 findBreakByCoord (Just (GHC.srcLocFile loc))
2029 (GHC.srcLocLine loc,
2031 else noCanDo name $ text "can't find its location: " <> ppr loc
2033 noCanDo n why = printForUser $
2034 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2036 breakByModule :: Module -> [String] -> GHCi ()
2037 breakByModule mod (arg1:rest)
2038 | all isDigit arg1 = do -- looks like a line number
2039 breakByModuleLine mod (read arg1) rest
2043 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2044 breakByModuleLine mod line args
2045 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2046 | [col] <- args, all isDigit col =
2047 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2048 | otherwise = breakSyntax
2051 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2053 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2054 findBreakAndSet mod lookupTickTree = do
2055 tickArray <- getTickArray mod
2056 (breakArray, _) <- getModBreak mod
2057 case lookupTickTree tickArray of
2058 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2059 Just (tick, span) -> do
2060 success <- io $ setBreakFlag True breakArray tick
2064 recordBreak $ BreakLocation
2071 text "Breakpoint " <> ppr nm <>
2073 then text " was already set at " <> ppr span
2074 else text " activated at " <> ppr span
2076 printForUser $ text "Breakpoint could not be activated at"
2079 -- When a line number is specified, the current policy for choosing
2080 -- the best breakpoint is this:
2081 -- - the leftmost complete subexpression on the specified line, or
2082 -- - the leftmost subexpression starting on the specified line, or
2083 -- - the rightmost subexpression enclosing the specified line
2085 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2086 findBreakByLine line arr
2087 | not (inRange (bounds arr) line) = Nothing
2089 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2090 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2091 listToMaybe (sortBy (rightmost `on` snd) ticks)
2095 starts_here = [ tick | tick@(_,span) <- ticks,
2096 GHC.srcSpanStartLine span == line ]
2098 (complete,incomplete) = partition ends_here starts_here
2099 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2101 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2102 -> Maybe (BreakIndex,SrcSpan)
2103 findBreakByCoord mb_file (line, col) arr
2104 | not (inRange (bounds arr) line) = Nothing
2106 listToMaybe (sortBy (rightmost `on` snd) contains ++
2107 sortBy (leftmost_smallest `on` snd) after_here)
2111 -- the ticks that span this coordinate
2112 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2113 is_correct_file span ]
2115 is_correct_file span
2116 | Just f <- mb_file = GHC.srcSpanFile span == f
2119 after_here = [ tick | tick@(_,span) <- ticks,
2120 GHC.srcSpanStartLine span == line,
2121 GHC.srcSpanStartCol span >= col ]
2123 -- For now, use ANSI bold on terminals that we know support it.
2124 -- Otherwise, we add a line of carets under the active expression instead.
2125 -- In particular, on Windows and when running the testsuite (which sets
2126 -- TERM to vt100 for other reasons) we get carets.
2127 -- We really ought to use a proper termcap/terminfo library.
2129 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2130 where mTerm = System.Environment.getEnv "TERM"
2131 `Exception.catch` \_ -> return "TERM not set"
2133 start_bold :: String
2134 start_bold = "\ESC[1m"
2136 end_bold = "\ESC[0m"
2138 listCmd :: String -> GHCi ()
2140 mb_span <- getCurrentBreakSpan
2142 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
2143 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
2144 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
2145 listCmd str = list2 (words str)
2147 list2 :: [String] -> GHCi ()
2148 list2 [arg] | all isDigit arg = do
2149 session <- getSession
2150 (toplevel, _) <- io $ GHC.getContext session
2152 [] -> io $ putStrLn "No module to list"
2153 (mod : _) -> listModuleLine mod (read arg)
2154 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2155 mod <- wantInterpretedModule arg1
2156 listModuleLine mod (read arg2)
2158 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2159 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2160 if GHC.isGoodSrcLoc loc
2162 tickArray <- getTickArray (GHC.nameModule name)
2163 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2164 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2167 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2168 Just (_,span) -> io $ listAround span False
2170 noCanDo name $ text "can't find its location: " <>
2173 noCanDo n why = printForUser $
2174 text "cannot list source code for " <> ppr n <> text ": " <> why
2176 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2178 listModuleLine :: Module -> Int -> GHCi ()
2179 listModuleLine modl line = do
2180 session <- getSession
2181 graph <- io (GHC.getModuleGraph session)
2182 let this = filter ((== modl) . GHC.ms_mod) graph
2184 [] -> panic "listModuleLine"
2186 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2187 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2188 io $ listAround (GHC.srcLocSpan loc) False
2190 -- | list a section of a source file around a particular SrcSpan.
2191 -- If the highlight flag is True, also highlight the span using
2192 -- start_bold/end_bold.
2193 listAround :: SrcSpan -> Bool -> IO ()
2194 listAround span do_highlight = do
2195 contents <- BS.readFile (unpackFS file)
2197 lines = BS.split '\n' contents
2198 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2199 drop (line1 - 1 - pad_before) $ lines
2200 fst_line = max 1 (line1 - pad_before)
2201 line_nos = [ fst_line .. ]
2203 highlighted | do_highlight = zipWith highlight line_nos these_lines
2204 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2206 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2207 prefixed = zipWith ($) highlighted bs_line_nos
2209 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2211 file = GHC.srcSpanFile span
2212 line1 = GHC.srcSpanStartLine span
2213 col1 = GHC.srcSpanStartCol span
2214 line2 = GHC.srcSpanEndLine span
2215 col2 = GHC.srcSpanEndCol span
2217 pad_before | line1 == 1 = 0
2221 highlight | do_bold = highlight_bold
2222 | otherwise = highlight_carets
2224 highlight_bold no line prefix
2225 | no == line1 && no == line2
2226 = let (a,r) = BS.splitAt col1 line
2227 (b,c) = BS.splitAt (col2-col1) r
2229 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2231 = let (a,b) = BS.splitAt col1 line in
2232 BS.concat [prefix, a, BS.pack start_bold, b]
2234 = let (a,b) = BS.splitAt col2 line in
2235 BS.concat [prefix, a, BS.pack end_bold, b]
2236 | otherwise = BS.concat [prefix, line]
2238 highlight_carets no line prefix
2239 | no == line1 && no == line2
2240 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2241 BS.replicate (col2-col1) '^']
2243 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2246 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2248 | otherwise = BS.concat [prefix, line]
2250 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2251 nl = BS.singleton '\n'
2253 -- --------------------------------------------------------------------------
2256 getTickArray :: Module -> GHCi TickArray
2257 getTickArray modl = do
2259 let arrmap = tickarrays st
2260 case lookupModuleEnv arrmap modl of
2261 Just arr -> return arr
2263 (_breakArray, ticks) <- getModBreak modl
2264 let arr = mkTickArray (assocs ticks)
2265 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2268 discardTickArrays :: GHCi ()
2269 discardTickArrays = do
2271 setGHCiState st{tickarrays = emptyModuleEnv}
2273 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2275 = accumArray (flip (:)) [] (1, max_line)
2276 [ (line, (nm,span)) | (nm,span) <- ticks,
2277 line <- srcSpanLines span ]
2279 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2280 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2281 GHC.srcSpanEndLine span ]
2283 lookupModule :: String -> GHCi Module
2284 lookupModule modName
2285 = do session <- getSession
2286 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2288 -- don't reset the counter back to zero?
2289 discardActiveBreakPoints :: GHCi ()
2290 discardActiveBreakPoints = do
2292 mapM (turnOffBreak.snd) (breaks st)
2293 setGHCiState $ st { breaks = [] }
2295 deleteBreak :: Int -> GHCi ()
2296 deleteBreak identity = do
2298 let oldLocations = breaks st
2299 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2301 then printForUser (text "Breakpoint" <+> ppr identity <+>
2302 text "does not exist")
2304 mapM (turnOffBreak.snd) this
2305 setGHCiState $ st { breaks = rest }
2307 turnOffBreak :: BreakLocation -> GHCi Bool
2308 turnOffBreak loc = do
2309 (arr, _) <- getModBreak (breakModule loc)
2310 io $ setBreakFlag False arr (breakTick loc)
2312 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2313 getModBreak mod = do
2314 session <- getSession
2315 Just mod_info <- io $ GHC.getModuleInfo session mod
2316 let modBreaks = GHC.modInfoModBreaks mod_info
2317 let array = GHC.modBreaks_flags modBreaks
2318 let ticks = GHC.modBreaks_locs modBreaks
2319 return (array, ticks)
2321 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2322 setBreakFlag toggle array index
2323 | toggle = GHC.setBreakOn array index
2324 | otherwise = GHC.setBreakOff array index