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 qualified Data.ByteString.Char8 as BS
73 import System.Environment
74 import System.Exit ( exitWith, ExitCode(..) )
75 import System.Directory
77 import System.IO.Error as IO
81 import Control.Monad as Monad
84 import Foreign.C ( withCStringLen )
85 import GHC.Exts ( unsafeCoerce# )
86 import GHC.IOBase ( IOErrorType(InvalidArgument) )
88 import Data.IORef ( IORef, readIORef, writeIORef )
91 import System.Posix.Internals ( setNonBlockingFD )
94 -----------------------------------------------------------------------------
96 ghciWelcomeMsg :: String
97 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
98 ": http://www.haskell.org/ghc/ :? for help"
100 cmdName :: Command -> String
101 cmdName (n,_,_,_) = n
103 macros_ref :: IORef [Command]
104 GLOBAL_VAR(macros_ref, [], [Command])
106 builtin_commands :: [Command]
108 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
109 ("?", keepGoing help, Nothing, completeNone),
110 ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename),
111 ("abandon", keepGoing abandonCmd, Nothing, completeNone),
112 ("break", keepGoing breakCmd, Nothing, completeIdentifier),
113 ("back", keepGoing backCmd, Nothing, completeNone),
114 ("browse", keepGoing (browseCmd False), Nothing, completeModule),
115 ("browse!", keepGoing (browseCmd True), Nothing, completeModule),
116 ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename),
117 ("check", keepGoing checkModule, Nothing, completeHomeModule),
118 ("continue", keepGoing continueCmd, Nothing, completeNone),
119 ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier),
120 ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename),
121 ("def", keepGoing (defineMacro False), Nothing, completeIdentifier),
122 ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier),
123 ("delete", keepGoing deleteCmd, Nothing, completeNone),
124 ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
125 ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
126 ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename),
127 ("force", keepGoing forceCmd, Nothing, completeIdentifier),
128 ("forward", keepGoing forwardCmd, Nothing, completeNone),
129 ("help", keepGoing help, Nothing, completeNone),
130 ("history", keepGoing historyCmd, Nothing, completeNone),
131 ("info", keepGoing info, Nothing, completeIdentifier),
132 ("kind", keepGoing kindOfType, Nothing, completeIdentifier),
133 ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile),
134 ("list", keepGoing listCmd, Nothing, completeNone),
135 ("module", keepGoing setContext, Nothing, completeModule),
136 ("main", keepGoing runMain, Nothing, completeIdentifier),
137 ("print", keepGoing printCmd, Nothing, completeIdentifier),
138 ("quit", quit, Nothing, completeNone),
139 ("reload", keepGoing reloadModule, Nothing, completeNone),
140 ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions),
141 ("show", keepGoing showCmd, Nothing, completeNone),
142 ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier),
143 ("step", keepGoing stepCmd, Nothing, completeIdentifier),
144 ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier),
145 ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier),
146 ("type", keepGoing typeOfExpr, Nothing, completeIdentifier),
147 ("trace", keepGoing traceCmd, Nothing, completeIdentifier),
148 ("undef", keepGoing undefineMacro, Nothing, completeMacro),
149 ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions)
153 -- We initialize readline (in the interactiveUI function) to use
154 -- word_break_chars as the default set of completion word break characters.
155 -- This can be overridden for a particular command (for example, filename
156 -- expansion shouldn't consider '/' to be a word break) by setting the third
157 -- entry in the Command tuple above.
159 -- NOTE: in order for us to override the default correctly, any custom entry
160 -- must be a SUBSET of word_break_chars.
161 word_break_chars, flagWordBreakChars, filenameWordBreakChars :: String
162 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
163 specials = "(),;[]`{}"
165 in spaces ++ specials ++ symbols
166 flagWordBreakChars = " \t\n"
167 filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults
170 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
171 keepGoing a str = a str >> return False
173 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
174 keepGoingPaths a str = a (toArgs str) >> return False
176 shortHelpText :: String
177 shortHelpText = "use :? for help.\n"
181 " Commands available from the prompt:\n" ++
183 " <statement> evaluate/run <statement>\n" ++
184 " : repeat last command\n" ++
185 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
186 " :add <filename> ... add module(s) to the current target set\n" ++
187 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
188 " (!: more details; *: all top-level names)\n" ++
189 " :cd <dir> change directory to <dir>\n" ++
190 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
191 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
192 " :def <cmd> <expr> define a command :<cmd>\n" ++
193 " :edit <file> edit file\n" ++
194 " :edit edit last module\n" ++
195 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
196 " :help, :? display this list of commands\n" ++
197 " :info [<name> ...] display information about the given names\n" ++
198 " :kind <type> show the kind of <type>\n" ++
199 " :load <filename> ... load module(s) and their dependents\n" ++
200 " :main [<arguments> ...] run the main function with the given arguments\n" ++
201 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
202 " :quit exit GHCi\n" ++
203 " :reload reload the current module set\n" ++
204 " :type <expr> show the type of <expr>\n" ++
205 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
206 " :!<command> run the shell command <command>\n" ++
208 " -- Commands for debugging:\n" ++
210 " :abandon at a breakpoint, abandon current computation\n" ++
211 " :back go back in the history (after :trace)\n" ++
212 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
213 " :break <name> set a breakpoint on the specified function\n" ++
214 " :continue resume after a breakpoint\n" ++
215 " :delete <number> delete the specified breakpoint\n" ++
216 " :delete * delete all breakpoints\n" ++
217 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
218 " :forward go forward in the history (after :back)\n" ++
219 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
220 " :print [<name> ...] prints a value without forcing its computation\n" ++
221 " :sprint [<name> ...] simplifed version of :print\n" ++
222 " :step single-step after stopping at a breakpoint\n"++
223 " :step <expr> single-step into <expr>\n"++
224 " :steplocal single-step restricted to the current top level decl.\n"++
225 " :stepmodule single-step restricted to the current module\n"++
226 " :trace trace after stopping at a breakpoint\n"++
227 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
230 " -- Commands for changing settings:\n" ++
232 " :set <option> ... set options\n" ++
233 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
234 " :set prog <progname> set the value returned by System.getProgName\n" ++
235 " :set prompt <prompt> set the prompt used in GHCi\n" ++
236 " :set editor <cmd> set the command used for :edit\n" ++
237 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
238 " :unset <option> ... unset options\n" ++
240 " Options for ':set' and ':unset':\n" ++
242 " +r revert top-level expressions after each evaluation\n" ++
243 " +s print timing/memory stats after each evaluation\n" ++
244 " +t print type after evaluation\n" ++
245 " -<flags> most GHC command line flags can also be set here\n" ++
246 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
247 " for GHCi-specific flags, see User's Guide,\n"++
248 " Flag reference, Interactive-mode options\n" ++
250 " -- Commands for displaying information:\n" ++
252 " :show bindings show the current bindings made at the prompt\n" ++
253 " :show breaks show the active breakpoints\n" ++
254 " :show context show the breakpoint context\n" ++
255 " :show modules show the currently loaded modules\n" ++
256 " :show packages show the currently active package flags\n" ++
257 " :show languages show the currently active language flags\n" ++
258 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
261 findEditor :: IO String
266 win <- System.Win32.getWindowsDirectory
267 return (win `joinFileName` "notepad.exe")
272 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
273 interactiveUI session srcs maybe_expr = do
274 -- HACK! If we happen to get into an infinite loop (eg the user
275 -- types 'let x=x in x' at the prompt), then the thread will block
276 -- on a blackhole, and become unreachable during GC. The GC will
277 -- detect that it is unreachable and send it the NonTermination
278 -- exception. However, since the thread is unreachable, everything
279 -- it refers to might be finalized, including the standard Handles.
280 -- This sounds like a bug, but we don't have a good solution right
286 -- Initialise buffering for the *interpreted* I/O system
287 initInterpBuffering session
289 when (isNothing maybe_expr) $ do
290 -- Only for GHCi (not runghc and ghc -e):
292 -- Turn buffering off for the compiled program's stdout/stderr
294 -- Turn buffering off for GHCi's stdout
296 hSetBuffering stdout NoBuffering
297 -- We don't want the cmd line to buffer any input that might be
298 -- intended for the program, so unbuffer stdin.
299 hSetBuffering stdin NoBuffering
301 -- initial context is just the Prelude
302 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
304 GHC.setContext session [] [prel_mod]
308 Readline.setAttemptedCompletionFunction (Just completeWord)
309 --Readline.parseAndBind "set show-all-if-ambiguous 1"
311 Readline.setBasicWordBreakCharacters word_break_chars
312 Readline.setCompleterWordBreakCharacters word_break_chars
315 default_editor <- findEditor
317 startGHCi (runGHCi srcs maybe_expr)
318 GHCiState{ progname = "<interactive>",
322 editor = default_editor,
328 tickarrays = emptyModuleEnv,
329 last_command = Nothing,
331 remembered_ctx = Nothing
335 Readline.resetTerminal Nothing
340 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
341 runGHCi paths maybe_expr = do
342 let read_dot_files = not opt_IgnoreDotGhci
344 when (read_dot_files) $ do
347 exists <- io (doesFileExist file)
349 dir_ok <- io (checkPerms ".")
350 file_ok <- io (checkPerms file)
351 when (dir_ok && file_ok) $ do
352 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
355 Right hdl -> runCommands (fileLoop hdl False False)
357 when (read_dot_files) $ do
358 -- Read in $HOME/.ghci
359 either_dir <- io (IO.try getHomeDirectory)
363 cwd <- io (getCurrentDirectory)
364 when (dir /= cwd) $ do
365 let file = dir ++ "/.ghci"
366 ok <- io (checkPerms file)
368 either_hdl <- io (IO.try (openFile file ReadMode))
371 Right hdl -> runCommands (fileLoop hdl False False)
373 -- Perform a :load for files given on the GHCi command line
374 -- When in -e mode, if the load fails then we want to stop
375 -- immediately rather than going on to evaluate the expression.
376 when (not (null paths)) $ do
377 ok <- ghciHandle (\e -> do showException e; return Failed) $
379 when (isJust maybe_expr && failed ok) $
380 io (exitWith (ExitFailure 1))
382 -- if verbosity is greater than 0, or we are connected to a
383 -- terminal, display the prompt in the interactive loop.
384 is_tty <- io (hIsTerminalDevice stdin)
385 dflags <- getDynFlags
386 let show_prompt = verbosity dflags > 0 || is_tty
391 #if defined(mingw32_HOST_OS)
392 -- The win32 Console API mutates the first character of
393 -- type-ahead when reading from it in a non-buffered manner. Work
394 -- around this by flushing the input buffer of type-ahead characters,
395 -- but only if stdin is available.
396 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
398 Left err | isDoesNotExistError err -> return ()
399 | otherwise -> io (ioError err)
400 Right () -> return ()
402 -- enter the interactive loop
403 interactiveLoop is_tty show_prompt
405 -- just evaluate the expression we were given
410 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
413 interactiveLoop :: Bool -> Bool -> GHCi ()
414 interactiveLoop is_tty show_prompt =
415 -- Ignore ^C exceptions caught here
416 ghciHandleDyn (\e -> case e of
418 #if defined(mingw32_HOST_OS)
421 interactiveLoop is_tty show_prompt
422 _other -> return ()) $
424 ghciUnblock $ do -- unblock necessary if we recursed from the
425 -- exception handler above.
427 -- read commands from stdin
430 then runCommands readlineLoop
431 else runCommands (fileLoop stdin show_prompt is_tty)
433 runCommands (fileLoop stdin show_prompt is_tty)
437 -- NOTE: We only read .ghci files if they are owned by the current user,
438 -- and aren't world writable. Otherwise, we could be accidentally
439 -- running code planted by a malicious third party.
441 -- Furthermore, We only read ./.ghci if . is owned by the current user
442 -- and isn't writable by anyone else. I think this is sufficient: we
443 -- don't need to check .. and ../.. etc. because "." always refers to
444 -- the same directory while a process is running.
446 checkPerms :: String -> IO Bool
447 #ifdef mingw32_HOST_OS
452 Util.handle (\_ -> return False) $ do
453 st <- getFileStatus name
455 if fileOwner st /= me then do
456 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
459 let mode = fileMode st
460 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
461 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
463 putStrLn $ "*** WARNING: " ++ name ++
464 " is writable by someone else, IGNORING!"
469 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
470 fileLoop hdl show_prompt is_tty = do
471 when show_prompt $ do
474 l <- io (IO.try (hGetLine hdl))
476 Left e | isEOFError e -> return Nothing
477 | InvalidArgument <- etype -> return Nothing
478 | otherwise -> io (ioError e)
479 where etype = ioeGetErrorType e
480 -- treat InvalidArgument in the same way as EOF:
481 -- this can happen if the user closed stdin, or
482 -- perhaps did getContents which closes stdin at
485 str <- io $ consoleInputToUnicode is_tty l
488 #ifdef mingw32_HOST_OS
489 -- Convert the console input into Unicode according to the current code page.
490 -- The Windows console stores Unicode characters directly, so this is a
491 -- rather roundabout way of doing things... oh well.
492 -- See #782, #1483, #1649
493 consoleInputToUnicode :: Bool -> String -> IO String
494 consoleInputToUnicode is_tty str
496 cp <- System.Win32.getConsoleCP
497 System.Win32.stringToUnicode cp str
499 decodeStringAsUTF8 str
501 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
503 consoleInputToUnicode :: Bool -> String -> IO String
504 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
507 decodeStringAsUTF8 :: String -> IO String
508 decodeStringAsUTF8 str =
509 withCStringLen str $ \(cstr,len) ->
510 utf8DecodeString (castPtr cstr :: Ptr Word8) len
512 mkPrompt :: GHCi String
514 session <- getSession
515 (toplevs,exports) <- io (GHC.getContext session)
516 resumes <- io $ GHC.getResumeContext session
517 -- st <- getGHCiState
523 let ix = GHC.resumeHistoryIx r
525 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
527 let hist = GHC.resumeHistory r !! (ix-1)
528 span <- io$ GHC.getHistorySpan session hist
529 return (brackets (ppr (negate ix) <> char ':'
530 <+> ppr span) <> space)
532 dots | _:rs <- resumes, not (null rs) = text "... "
539 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
540 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
541 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
542 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
543 hsep (map (ppr . GHC.moduleName) exports)
545 deflt_prompt = dots <> context_bit <> modules_bit
547 f ('%':'s':xs) = deflt_prompt <> f xs
548 f ('%':'%':xs) = char '%' <> f xs
549 f (x:xs) = char x <> f xs
553 return (showSDoc (f (prompt st)))
557 readlineLoop :: GHCi (Maybe String)
560 saveSession -- for use by completion
562 l <- io (readline prompt `finally` setNonBlockingFD 0)
563 -- readline sometimes puts stdin into blocking mode,
564 -- so we need to put it back for the IO library
567 Nothing -> return Nothing
570 str <- io $ consoleInputToUnicode True l
574 queryQueue :: GHCi (Maybe String)
579 c:cs -> do setGHCiState st{ cmdqueue = cs }
582 runCommands :: GHCi (Maybe String) -> GHCi ()
583 runCommands getCmd = do
584 mb_cmd <- noSpace queryQueue
585 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
589 b <- ghciHandle handler (doCommand c)
590 if b then return () else runCommands getCmd
592 noSpace q = q >>= maybe (return Nothing)
593 (\c->case removeSpaces c of
595 ":{" -> multiLineCmd q
596 c -> return (Just c) )
600 setGHCiState st{ prompt = "%s| " }
601 mb_cmd <- collectCommand q ""
602 getGHCiState >>= \st->setGHCiState st{ prompt = p }
604 -- we can't use removeSpaces for the sublines here, so
605 -- multiline commands are somewhat more brittle against
606 -- fileformat errors (such as \r in dos input on unix),
607 -- we get rid of any extra spaces for the ":}" test;
608 -- we also avoid silent failure if ":}" is not found;
609 -- and since there is no (?) valid occurrence of \r (as
610 -- opposed to its String representation, "\r") inside a
611 -- ghci command, we replace any such with ' ' (argh:-(
612 collectCommand q c = q >>=
613 maybe (io (ioError collectError))
614 (\l->if removeSpaces l == ":}"
615 then return (Just $ removeSpaces c)
616 else collectCommand q (c++map normSpace l))
617 where normSpace '\r' = ' '
619 -- QUESTION: is userError the one to use here?
620 collectError = userError "unterminated multiline command :{ .. :}"
621 doCommand (':' : cmd) = specialCommand cmd
622 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
625 enqueueCommands :: [String] -> GHCi ()
626 enqueueCommands cmds = do
628 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
631 -- This version is for the GHC command-line option -e. The only difference
632 -- from runCommand is that it catches the ExitException exception and
633 -- exits, rather than printing out the exception.
634 runCommandEval :: String -> GHCi Bool
635 runCommandEval c = ghciHandle handleEval (doCommand c)
637 handleEval (ExitException code) = io (exitWith code)
638 handleEval e = do handler e
639 io (exitWith (ExitFailure 1))
641 doCommand (':' : command) = specialCommand command
643 = do r <- runStmt stmt GHC.RunToCompletion
645 False -> io (exitWith (ExitFailure 1))
646 -- failure to run the command causes exit(1) for ghc -e.
649 runStmt :: String -> SingleStep -> GHCi Bool
651 | null (filter (not.isSpace) stmt) = return False
652 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
654 = do st <- getGHCiState
655 session <- getSession
656 result <- io $ withProgName (progname st) $ withArgs (args st) $
657 GHC.runStmt session stmt step
658 afterRunStmt (const True) result
661 --afterRunStmt :: GHC.RunResult -> GHCi Bool
662 -- False <=> the statement failed to compile
663 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
664 afterRunStmt _ (GHC.RunException e) = throw e
665 afterRunStmt step_here run_result = do
666 session <- getSession
667 resumes <- io $ GHC.getResumeContext session
669 GHC.RunOk names -> do
670 show_types <- isOptionSet ShowType
671 when show_types $ printTypeOfNames session names
672 GHC.RunBreak _ names mb_info
673 | isNothing mb_info ||
674 step_here (GHC.resumeSpan $ head resumes) -> do
675 printForUser $ ptext SLIT("Stopped at") <+>
676 ppr (GHC.resumeSpan $ head resumes)
677 -- printTypeOfNames session names
678 let namesSorted = sortBy compareNames names
679 tythings <- catMaybes `liftM`
680 io (mapM (GHC.lookupName session) namesSorted)
681 docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
682 printForUserPartWay docs
683 maybe (return ()) runBreakCmd mb_info
684 -- run the command set with ":set stop <cmd>"
686 enqueueCommands [stop st]
688 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
689 afterRunStmt step_here >> return ()
693 io installSignalHandlers
694 b <- isOptionSet RevertCAFs
695 io (when b revertCAFs)
697 return (case run_result of GHC.RunOk _ -> True; _ -> False)
699 runBreakCmd :: GHC.BreakInfo -> GHCi ()
700 runBreakCmd info = do
701 let mod = GHC.breakInfo_module info
702 nm = GHC.breakInfo_number info
704 case [ loc | (_,loc) <- breaks st,
705 breakModule loc == mod, breakTick loc == nm ] of
707 loc:_ | null cmd -> return ()
708 | otherwise -> do enqueueCommands [cmd]; return ()
709 where cmd = onBreakCmd loc
711 printTypeOfNames :: Session -> [Name] -> GHCi ()
712 printTypeOfNames session names
713 = mapM_ (printTypeOfName session) $ sortBy compareNames names
715 compareNames :: Name -> Name -> Ordering
716 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
717 where compareWith n = (getOccString n, getSrcSpan n)
719 printTypeOfName :: Session -> Name -> GHCi ()
720 printTypeOfName session n
721 = do maybe_tything <- io (GHC.lookupName session n)
722 case maybe_tything of
724 Just thing -> printTyThing thing
727 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
729 specialCommand :: String -> GHCi Bool
730 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
731 specialCommand str = do
732 let (cmd,rest) = break isSpace str
733 maybe_cmd <- lookupCommand cmd
735 GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
737 do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
741 do io $ hPutStr stdout ("there is no last command to perform\n"
745 lookupCommand :: String -> GHCi (MaybeCommand)
746 lookupCommand "" = do
748 case last_command st of
749 Just c -> return $ GotCommand c
750 Nothing -> return NoLastCommand
751 lookupCommand str = do
752 mc <- io $ lookupCommand' str
754 setGHCiState st{ last_command = mc }
756 Just c -> GotCommand c
757 Nothing -> BadCommand
759 lookupCommand' :: String -> IO (Maybe Command)
760 lookupCommand' str = do
761 macros <- readIORef macros_ref
762 let cmds = builtin_commands ++ macros
763 -- look for exact match first, then the first prefix match
764 return $ case [ c | c <- cmds, str == cmdName c ] of
766 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
770 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
771 getCurrentBreakSpan = do
772 session <- getSession
773 resumes <- io $ GHC.getResumeContext session
777 let ix = GHC.resumeHistoryIx r
779 then return (Just (GHC.resumeSpan r))
781 let hist = GHC.resumeHistory r !! (ix-1)
782 span <- io $ GHC.getHistorySpan session hist
785 getCurrentBreakModule :: GHCi (Maybe Module)
786 getCurrentBreakModule = do
787 session <- getSession
788 resumes <- io $ GHC.getResumeContext session
792 let ix = GHC.resumeHistoryIx r
794 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
796 let hist = GHC.resumeHistory r !! (ix-1)
797 return $ Just $ GHC.getHistoryModule hist
799 -----------------------------------------------------------------------------
802 noArgs :: GHCi () -> String -> GHCi ()
804 noArgs _ _ = io $ putStrLn "This command takes no arguments"
806 help :: String -> GHCi ()
807 help _ = io (putStr helpText)
809 info :: String -> GHCi ()
810 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
811 info s = do { let names = words s
812 ; session <- getSession
813 ; dflags <- getDynFlags
814 ; let pefas = dopt Opt_PrintExplicitForalls dflags
815 ; mapM_ (infoThing pefas session) names }
817 infoThing pefas session str = io $ do
818 names <- GHC.parseName session str
819 mb_stuffs <- mapM (GHC.getInfo session) names
820 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
821 unqual <- GHC.getPrintUnqual session
822 putStrLn (showSDocForUser unqual $
823 vcat (intersperse (text "") $
824 map (pprInfo pefas) filtered))
826 -- Filter out names whose parent is also there Good
827 -- example is '[]', which is both a type and data
828 -- constructor in the same type
829 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
830 filterOutChildren get_thing xs
831 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
833 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
835 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
836 pprInfo pefas (thing, fixity, insts)
837 = pprTyThingInContextLoc pefas thing
838 $$ show_fixity fixity
839 $$ vcat (map GHC.pprInstance insts)
842 | fix == GHC.defaultFixity = empty
843 | otherwise = ppr fix <+> ppr (GHC.getName thing)
845 runMain :: String -> GHCi ()
847 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
848 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
850 addModule :: [FilePath] -> GHCi ()
852 io (revertCAFs) -- always revert CAFs on load/add.
853 files <- mapM expandPath files
854 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
855 session <- getSession
856 io (mapM_ (GHC.addTarget session) targets)
857 prev_context <- io $ GHC.getContext session
858 ok <- io (GHC.load session LoadAllTargets)
859 afterLoad ok session False prev_context
861 changeDirectory :: String -> GHCi ()
862 changeDirectory "" = do
863 -- :cd on its own changes to the user's home directory
864 either_dir <- io (IO.try getHomeDirectory)
867 Right dir -> changeDirectory dir
868 changeDirectory dir = do
869 session <- getSession
870 graph <- io (GHC.getModuleGraph session)
871 when (not (null graph)) $
872 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
873 prev_context <- io $ GHC.getContext session
874 io (GHC.setTargets session [])
875 io (GHC.load session LoadAllTargets)
876 setContextAfterLoad session prev_context []
877 io (GHC.workingDirectoryChanged session)
878 dir <- expandPath dir
879 io (setCurrentDirectory dir)
881 editFile :: String -> GHCi ()
883 do file <- if null str then chooseEditFile else return str
887 $ throwDyn (CmdLineError "editor not set, use :set editor")
888 io $ system (cmd ++ ' ':file)
891 -- The user didn't specify a file so we pick one for them.
892 -- Our strategy is to pick the first module that failed to load,
893 -- or otherwise the first target.
895 -- XXX: Can we figure out what happened if the depndecy analysis fails
896 -- (e.g., because the porgrammeer mistyped the name of a module)?
897 -- XXX: Can we figure out the location of an error to pass to the editor?
898 -- XXX: if we could figure out the list of errors that occured during the
899 -- last load/reaload, then we could start the editor focused on the first
901 chooseEditFile :: GHCi String
903 do session <- getSession
904 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
906 graph <- io (GHC.getModuleGraph session)
907 failed_graph <- filterM hasFailed graph
908 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
910 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
913 case pick (order failed_graph) of
914 Just file -> return file
916 do targets <- io (GHC.getTargets session)
917 case msum (map fromTarget targets) of
918 Just file -> return file
919 Nothing -> throwDyn (CmdLineError "No files to edit.")
921 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
922 fromTarget _ = Nothing -- when would we get a module target?
924 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
925 defineMacro overwrite s = do
926 let (macro_name, definition) = break isSpace s
927 macros <- io (readIORef macros_ref)
928 let defined = map cmdName macros
931 then io $ putStrLn "no macros defined"
932 else io $ putStr ("the following macros are defined:\n" ++
935 if (not overwrite && macro_name `elem` defined)
936 then throwDyn (CmdLineError
937 ("macro '" ++ macro_name ++ "' is already defined"))
940 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
942 -- give the expression a type signature, so we can be sure we're getting
943 -- something of the right type.
944 let new_expr = '(' : definition ++ ") :: String -> IO String"
946 -- compile the expression
948 maybe_hv <- io (GHC.compileExpr cms new_expr)
951 Just hv -> io (writeIORef macros_ref --
952 (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)]))
954 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
956 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
957 enqueueCommands (lines str)
960 undefineMacro :: String -> GHCi ()
961 undefineMacro str = mapM_ undef (words str)
962 where undef macro_name = do
963 cmds <- io (readIORef macros_ref)
964 if (macro_name `notElem` map cmdName cmds)
965 then throwDyn (CmdLineError
966 ("macro '" ++ macro_name ++ "' is not defined"))
968 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
970 cmdCmd :: String -> GHCi ()
972 let expr = '(' : str ++ ") :: IO String"
973 session <- getSession
974 maybe_hv <- io (GHC.compileExpr session expr)
978 cmds <- io $ (unsafeCoerce# hv :: IO String)
979 enqueueCommands (lines cmds)
982 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
983 loadModule fs = timeIt (loadModule' fs)
985 loadModule_ :: [FilePath] -> GHCi ()
986 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
988 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
989 loadModule' files = do
990 session <- getSession
991 prev_context <- io $ GHC.getContext session
994 discardActiveBreakPoints
995 io (GHC.setTargets session [])
996 io (GHC.load session LoadAllTargets)
999 let (filenames, phases) = unzip files
1000 exp_filenames <- mapM expandPath filenames
1001 let files' = zip exp_filenames phases
1002 targets <- io (mapM (uncurry GHC.guessTarget) files')
1004 -- NOTE: we used to do the dependency anal first, so that if it
1005 -- fails we didn't throw away the current set of modules. This would
1006 -- require some re-working of the GHC interface, so we'll leave it
1007 -- as a ToDo for now.
1009 io (GHC.setTargets session targets)
1010 doLoad session False prev_context LoadAllTargets
1012 checkModule :: String -> GHCi ()
1014 let modl = GHC.mkModuleName m
1015 session <- getSession
1016 prev_context <- io $ GHC.getContext session
1017 result <- io (GHC.checkModule session modl False)
1019 Nothing -> io $ putStrLn "Nothing"
1020 Just r -> io $ putStrLn (showSDoc (
1021 case GHC.checkedModuleInfo r of
1022 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1024 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1026 (text "global names: " <+> ppr global) $$
1027 (text "local names: " <+> ppr local)
1029 afterLoad (successIf (isJust result)) session False prev_context
1031 reloadModule :: String -> GHCi ()
1033 session <- getSession
1034 prev_context <- io $ GHC.getContext session
1035 doLoad session True prev_context $
1036 if null m then LoadAllTargets
1037 else LoadUpTo (GHC.mkModuleName m)
1040 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1041 doLoad session retain_context prev_context howmuch = do
1042 -- turn off breakpoints before we load: we can't turn them off later, because
1043 -- the ModBreaks will have gone away.
1044 discardActiveBreakPoints
1045 ok <- io (GHC.load session howmuch)
1046 afterLoad ok session retain_context prev_context
1049 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1050 afterLoad ok session retain_context prev_context = do
1051 io (revertCAFs) -- always revert CAFs on load.
1053 loaded_mod_summaries <- getLoadedModules session
1054 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1055 loaded_mod_names = map GHC.moduleName loaded_mods
1056 modulesLoadedMsg ok loaded_mod_names
1059 if not retain_context
1061 setGHCiState st{ remembered_ctx = Nothing }
1062 setContextAfterLoad session prev_context loaded_mod_summaries
1064 -- figure out which modules we can keep in the context, which we
1065 -- have to put back, and which we have to remember because they
1066 -- are (temporarily) unavailable. See ghci.prog009, #1873, #1360
1067 let (as,bs) = prev_context
1068 as1 = filter isHomeModule as -- package modules are kept anyway
1069 bs1 = filter isHomeModule bs
1070 (as_ok, as_bad) = partition (`elem` loaded_mods) as1
1071 (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1
1072 (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st)
1073 (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as
1074 (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs
1075 as' = nub (as_ok++rem_as_ok)
1076 bs' = nub (bs_ok++rem_bs_ok)
1077 rem_as' = nub (rem_as_bad ++ as_bad)
1078 rem_bs' = nub (rem_bs_bad ++ bs_bad)
1080 -- Put back into the context any modules that we previously had
1081 -- to drop because they weren't available (rem_as_ok, rem_bs_ok).
1082 setContextKeepingPackageModules session prev_context (as',bs')
1084 -- If compilation failed, remember any modules that we are unable
1085 -- to load, so that we can put them back in the context in the future.
1087 Succeeded -> setGHCiState st{ remembered_ctx = Nothing }
1088 Failed -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') }
1092 setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi ()
1093 setContextAfterLoad session prev [] = do
1094 prel_mod <- getPrelude
1095 setContextKeepingPackageModules session prev ([], [prel_mod])
1096 setContextAfterLoad session prev ms = do
1097 -- load a target if one is available, otherwise load the topmost module.
1098 targets <- io (GHC.getTargets session)
1099 case [ m | Just m <- map (findTarget ms) targets ] of
1101 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1102 load_this (last graph')
1107 = case filter (`matches` t) ms of
1111 summary `matches` Target (TargetModule m) _
1112 = GHC.ms_mod_name summary == m
1113 summary `matches` Target (TargetFile f _) _
1114 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1118 load_this summary | m <- GHC.ms_mod summary = do
1119 b <- io (GHC.moduleIsInterpreted session m)
1120 if b then setContextKeepingPackageModules session prev ([m], [])
1122 prel_mod <- getPrelude
1123 setContextKeepingPackageModules session prev ([],[prel_mod,m])
1125 -- | Keep any package modules (except Prelude) when changing the context.
1126 setContextKeepingPackageModules
1128 -> ([Module],[Module]) -- previous context
1129 -> ([Module],[Module]) -- new context
1131 setContextKeepingPackageModules session prev_context (as,bs) = do
1132 let (_,bs0) = prev_context
1133 prel_mod <- getPrelude
1134 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1135 let bs1 = if null as then nub (prel_mod : bs) else bs
1136 io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1138 isHomeModule :: Module -> Bool
1139 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1141 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1142 modulesLoadedMsg ok mods = do
1143 dflags <- getDynFlags
1144 when (verbosity dflags > 0) $ do
1146 | null mods = text "none."
1147 | otherwise = hsep (
1148 punctuate comma (map ppr mods)) <> text "."
1151 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1153 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1156 typeOfExpr :: String -> GHCi ()
1158 = do cms <- getSession
1159 maybe_ty <- io (GHC.exprType cms str)
1161 Nothing -> return ()
1162 Just ty -> do dflags <- getDynFlags
1163 let pefas = dopt Opt_PrintExplicitForalls dflags
1164 printForUser $ text str <+> dcolon
1165 <+> pprTypeForUser pefas ty
1167 kindOfType :: String -> GHCi ()
1169 = do cms <- getSession
1170 maybe_ty <- io (GHC.typeKind cms str)
1172 Nothing -> return ()
1173 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1175 quit :: String -> GHCi Bool
1176 quit _ = return True
1178 shellEscape :: String -> GHCi Bool
1179 shellEscape str = io (system str >> return False)
1181 -----------------------------------------------------------------------------
1182 -- Browsing a module's contents
1184 browseCmd :: Bool -> String -> GHCi ()
1187 ['*':s] | looksLikeModuleName s -> do
1188 m <- wantInterpretedModule s
1189 browseModule bang m False
1190 [s] | looksLikeModuleName s -> do
1192 browseModule bang m True
1195 (as,bs) <- io $ GHC.getContext s
1196 -- Guess which module the user wants to browse. Pick
1197 -- modules that are interpreted first. The most
1198 -- recently-added module occurs last, it seems.
1200 (as@(_:_), _) -> browseModule bang (last as) True
1201 ([], bs@(_:_)) -> browseModule bang (last bs) True
1202 ([], []) -> throwDyn (CmdLineError ":browse: no current module")
1203 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1205 -- without bang, show items in context of their parents and omit children
1206 -- with bang, show class methods and data constructors separately, and
1207 -- indicate import modules, to aid qualifying unqualified names
1208 -- with sorted, sort items alphabetically
1209 browseModule :: Bool -> Module -> Bool -> GHCi ()
1210 browseModule bang modl exports_only = do
1212 -- :browse! reports qualifiers wrt current context
1213 current_unqual <- io (GHC.getPrintUnqual s)
1214 -- Temporarily set the context to the module we're interested in,
1215 -- just so we can get an appropriate PrintUnqualified
1216 (as,bs) <- io (GHC.getContext s)
1217 prel_mod <- getPrelude
1218 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1219 else GHC.setContext s [modl] [])
1220 target_unqual <- io (GHC.getPrintUnqual s)
1221 io (GHC.setContext s as bs)
1223 let unqual = if bang then current_unqual else target_unqual
1225 mb_mod_info <- io $ GHC.getModuleInfo s modl
1227 Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1228 GHC.moduleNameString (GHC.moduleName modl)))
1230 dflags <- getDynFlags
1232 | exports_only = GHC.modInfoExports mod_info
1233 | otherwise = GHC.modInfoTopLevelScope mod_info
1236 -- sort alphabetically name, but putting
1237 -- locally-defined identifiers first.
1238 -- We would like to improve this; see #1799.
1239 sorted_names = loc_sort local ++ occ_sort external
1241 (local,external) = partition ((==modl) . nameModule) names
1242 occ_sort = sortBy (compare `on` nameOccName)
1243 -- try to sort by src location. If the first name in
1244 -- our list has a good source location, then they all should.
1246 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1247 = sortBy (compare `on` nameSrcSpan) names
1251 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1252 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1254 rdr_env <- io $ GHC.getGRE s
1256 let pefas = dopt Opt_PrintExplicitForalls dflags
1257 things | bang = catMaybes mb_things
1258 | otherwise = filtered_things
1259 pretty | bang = pprTyThing
1260 | otherwise = pprTyThingInContext
1262 labels [] = text "-- not currently imported"
1263 labels l = text $ intercalate "\n" $ map qualifier l
1264 qualifier = maybe "-- defined locally"
1265 (("-- imported via "++) . intercalate ", "
1266 . map GHC.moduleNameString)
1267 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1268 modNames = map (importInfo . GHC.getName) things
1270 -- annotate groups of imports with their import modules
1271 -- the default ordering is somewhat arbitrary, so we group
1272 -- by header and sort groups; the names themselves should
1273 -- really come in order of source appearance.. (trac #1799)
1274 annotate mts = concatMap (\(m,ts)->labels m:ts)
1275 $ sortBy cmpQualifiers $ group mts
1276 where cmpQualifiers =
1277 compare `on` (map (fmap (map moduleNameFS)) . fst)
1279 group mts@((m,_):_) = (m,map snd g) : group ng
1280 where (g,ng) = partition ((==m).fst) mts
1282 let prettyThings = map (pretty pefas) things
1283 prettyThings' | bang = annotate $ zip modNames prettyThings
1284 | otherwise = prettyThings
1285 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1286 -- ToDo: modInfoInstances currently throws an exception for
1287 -- package modules. When it works, we can do this:
1288 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1290 -----------------------------------------------------------------------------
1291 -- Setting the module context
1293 setContext :: String -> GHCi ()
1295 | all sensible mods = fn mods
1296 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1298 (fn, mods) = case str of
1299 '+':stuff -> (addToContext, words stuff)
1300 '-':stuff -> (removeFromContext, words stuff)
1301 stuff -> (newContext, words stuff)
1303 sensible ('*':m) = looksLikeModuleName m
1304 sensible m = looksLikeModuleName m
1306 separate :: Session -> [String] -> [Module] -> [Module]
1307 -> GHCi ([Module],[Module])
1308 separate _ [] as bs = return (as,bs)
1309 separate session (('*':str):ms) as bs = do
1310 m <- wantInterpretedModule str
1311 separate session ms (m:as) bs
1312 separate session (str:ms) as bs = do
1313 m <- lookupModule str
1314 separate session ms as (m:bs)
1316 newContext :: [String] -> GHCi ()
1317 newContext strs = do
1319 (as,bs) <- separate s strs [] []
1320 prel_mod <- getPrelude
1321 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1322 io $ GHC.setContext s as bs'
1325 addToContext :: [String] -> GHCi ()
1326 addToContext strs = do
1328 (as,bs) <- io $ GHC.getContext s
1330 (new_as,new_bs) <- separate s strs [] []
1332 let as_to_add = new_as \\ (as ++ bs)
1333 bs_to_add = new_bs \\ (as ++ bs)
1335 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1338 removeFromContext :: [String] -> GHCi ()
1339 removeFromContext strs = do
1341 (as,bs) <- io $ GHC.getContext s
1343 (as_to_remove,bs_to_remove) <- separate s strs [] []
1345 let as' = as \\ (as_to_remove ++ bs_to_remove)
1346 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1348 io $ GHC.setContext s as' bs'
1350 ----------------------------------------------------------------------------
1353 -- set options in the interpreter. Syntax is exactly the same as the
1354 -- ghc command line, except that certain options aren't available (-C,
1357 -- This is pretty fragile: most options won't work as expected. ToDo:
1358 -- figure out which ones & disallow them.
1360 setCmd :: String -> GHCi ()
1362 = do st <- getGHCiState
1363 let opts = options st
1364 io $ putStrLn (showSDoc (
1365 text "options currently set: " <>
1368 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1370 dflags <- getDynFlags
1371 io $ putStrLn (showSDoc (
1372 vcat (text "GHCi-specific dynamic flag settings:"
1373 :map (flagSetting dflags) ghciFlags)
1375 io $ putStrLn (showSDoc (
1376 vcat (text "other dynamic, non-language, flag settings:"
1377 :map (flagSetting dflags) nonLanguageDynFlags)
1379 where flagSetting dflags (str,f)
1380 | dopt f dflags = text " " <> text "-f" <> text str
1381 | otherwise = text " " <> text "-fno-" <> text str
1382 (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
1384 nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1386 flags = [Opt_PrintExplicitForalls
1387 ,Opt_PrintBindResult
1388 ,Opt_BreakOnException
1390 ,Opt_PrintEvldWithShow
1393 = case toArgs str of
1394 ("args":args) -> setArgs args
1395 ("prog":prog) -> setProg prog
1396 ("prompt":_) -> setPrompt (after 6)
1397 ("editor":_) -> setEditor (after 6)
1398 ("stop":_) -> setStop (after 4)
1399 wds -> setOptions wds
1400 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1402 setArgs, setProg, setOptions :: [String] -> GHCi ()
1403 setEditor, setStop, setPrompt :: String -> GHCi ()
1407 setGHCiState st{ args = args }
1411 setGHCiState st{ progname = prog }
1413 io (hPutStrLn stderr "syntax: :set prog <progname>")
1417 setGHCiState st{ editor = cmd }
1419 setStop str@(c:_) | isDigit c
1420 = do let (nm_str,rest) = break (not.isDigit) str
1423 let old_breaks = breaks st
1424 if all ((/= nm) . fst) old_breaks
1425 then printForUser (text "Breakpoint" <+> ppr nm <+>
1426 text "does not exist")
1428 let new_breaks = map fn old_breaks
1429 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1430 | otherwise = (i,loc)
1431 setGHCiState st{ breaks = new_breaks }
1434 setGHCiState st{ stop = cmd }
1436 setPrompt value = do
1439 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1440 else setGHCiState st{ prompt = remQuotes value }
1442 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1446 do -- first, deal with the GHCi opts (+s, +t, etc.)
1447 let (plus_opts, minus_opts) = partitionWith isPlus wds
1448 mapM_ setOpt plus_opts
1449 -- then, dynamic flags
1450 newDynFlags minus_opts
1452 newDynFlags :: [String] -> GHCi ()
1453 newDynFlags minus_opts = do
1454 dflags <- getDynFlags
1455 let pkg_flags = packageFlags dflags
1456 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1458 if (not (null leftovers))
1459 then throwDyn (CmdLineError ("unrecognised flags: " ++
1463 new_pkgs <- setDynFlags dflags'
1465 -- if the package flags changed, we should reset the context
1466 -- and link the new packages.
1467 dflags <- getDynFlags
1468 when (packageFlags dflags /= pkg_flags) $ do
1469 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1470 session <- getSession
1471 io (GHC.setTargets session [])
1472 io (GHC.load session LoadAllTargets)
1473 io (linkPackages dflags new_pkgs)
1474 -- package flags changed, we can't re-use any of the old context
1475 setContextAfterLoad session ([],[]) []
1479 unsetOptions :: String -> GHCi ()
1481 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1482 let opts = words str
1483 (minus_opts, rest1) = partition isMinus opts
1484 (plus_opts, rest2) = partitionWith isPlus rest1
1486 if (not (null rest2))
1487 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1490 mapM_ unsetOpt plus_opts
1492 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1493 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1495 no_flags <- mapM no_flag minus_opts
1496 newDynFlags no_flags
1498 isMinus :: String -> Bool
1499 isMinus ('-':_) = True
1502 isPlus :: String -> Either String String
1503 isPlus ('+':opt) = Left opt
1504 isPlus other = Right other
1506 setOpt, unsetOpt :: String -> GHCi ()
1509 = case strToGHCiOpt str of
1510 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1511 Just o -> setOption o
1514 = case strToGHCiOpt str of
1515 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1516 Just o -> unsetOption o
1518 strToGHCiOpt :: String -> (Maybe GHCiOption)
1519 strToGHCiOpt "s" = Just ShowTiming
1520 strToGHCiOpt "t" = Just ShowType
1521 strToGHCiOpt "r" = Just RevertCAFs
1522 strToGHCiOpt _ = Nothing
1524 optToStr :: GHCiOption -> String
1525 optToStr ShowTiming = "s"
1526 optToStr ShowType = "t"
1527 optToStr RevertCAFs = "r"
1529 -- ---------------------------------------------------------------------------
1532 showCmd :: String -> GHCi ()
1536 ["args"] -> io $ putStrLn (show (args st))
1537 ["prog"] -> io $ putStrLn (show (progname st))
1538 ["prompt"] -> io $ putStrLn (show (prompt st))
1539 ["editor"] -> io $ putStrLn (show (editor st))
1540 ["stop"] -> io $ putStrLn (show (stop st))
1541 ["modules" ] -> showModules
1542 ["bindings"] -> showBindings
1543 ["linker"] -> io showLinkerState
1544 ["breaks"] -> showBkptTable
1545 ["context"] -> showContext
1546 ["packages"] -> showPackages
1547 ["languages"] -> showLanguages
1548 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1550 showModules :: GHCi ()
1552 session <- getSession
1553 loaded_mods <- getLoadedModules session
1554 -- we want *loaded* modules only, see #1734
1555 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1556 mapM_ show_one loaded_mods
1558 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1559 getLoadedModules session = do
1560 graph <- io (GHC.getModuleGraph session)
1561 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1563 showBindings :: GHCi ()
1566 bindings <- io (GHC.getBindings s)
1567 docs <- io$ pprTypeAndContents s
1568 [ id | AnId id <- sortBy compareTyThings bindings]
1569 printForUserPartWay docs
1571 compareTyThings :: TyThing -> TyThing -> Ordering
1572 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1574 printTyThing :: TyThing -> GHCi ()
1575 printTyThing tyth = do dflags <- getDynFlags
1576 let pefas = dopt Opt_PrintExplicitForalls dflags
1577 printForUser (pprTyThing pefas tyth)
1579 showBkptTable :: GHCi ()
1582 printForUser $ prettyLocations (breaks st)
1584 showContext :: GHCi ()
1586 session <- getSession
1587 resumes <- io $ GHC.getResumeContext session
1588 printForUser $ vcat (map pp_resume (reverse resumes))
1591 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1592 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1594 showPackages :: GHCi ()
1596 pkg_flags <- fmap packageFlags getDynFlags
1597 io $ putStrLn $ showSDoc $ vcat $
1598 text ("active package flags:"++if null pkg_flags then " none" else "")
1599 : map showFlag pkg_flags
1600 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1601 io $ putStrLn $ showSDoc $ vcat $
1602 text "packages currently loaded:"
1603 : map (nest 2 . text . packageIdString) pkg_ids
1604 where showFlag (ExposePackage p) = text $ " -package " ++ p
1605 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1606 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1608 showLanguages :: GHCi ()
1610 dflags <- getDynFlags
1611 io $ putStrLn $ showSDoc $ vcat $
1612 text "active language flags:" :
1613 [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1615 -- -----------------------------------------------------------------------------
1618 completeNone :: String -> IO [String]
1619 completeNone _w = return []
1621 completeMacro, completeIdentifier, completeModule,
1622 completeHomeModule, completeSetOptions, completeFilename,
1623 completeHomeModuleOrFile
1624 :: String -> IO [String]
1627 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1628 completeWord w start end = do
1629 line <- Readline.getLineBuffer
1630 let line_words = words (dropWhile isSpace line)
1632 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1634 | ((':':c) : _) <- line_words -> do
1635 completionVars <- lookupCompletionVars c
1636 case completionVars of
1637 (Nothing,complete) -> wrapCompleter complete w
1638 (Just breakChars,complete)
1639 -> let (n,w') = selectWord
1640 (words' (`elem` breakChars) 0 line)
1641 complete' w = do rets <- complete w
1642 return (map (drop n) rets)
1643 in wrapCompleter complete' w'
1644 | ("import" : _) <- line_words ->
1645 wrapCompleter completeModule w
1647 --printf "complete %s, start = %d, end = %d\n" w start end
1648 wrapCompleter completeIdentifier w
1649 where words' _ _ [] = []
1650 words' isBreak n str = let (w,r) = break isBreak str
1651 (s,r') = span isBreak r
1652 in (n,w):words' isBreak (n+length w+length s) r'
1653 -- In a Haskell expression we want to parse 'a-b' as three words
1654 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1655 -- only be a single word.
1656 selectWord [] = (0,w)
1657 selectWord ((offset,x):xs)
1658 | offset+length x >= start = (start-offset,take (end-offset) x)
1659 | otherwise = selectWord xs
1661 lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars,
1663 lookupCompletionVars c = do
1664 maybe_cmd <- lookupCommand' c
1666 Just (_,_,ws,f) -> return (ws,f)
1667 Nothing -> return (Just filenameWordBreakChars,
1671 completeCmd :: String -> IO [String]
1673 cmds <- readIORef macros_ref
1674 return (filter (w `isPrefixOf`) (map (':':)
1675 (map cmdName (builtin_commands ++ cmds))))
1677 completeMacro w = do
1678 cmds <- readIORef macros_ref
1679 return (filter (w `isPrefixOf`) (map cmdName cmds))
1681 completeIdentifier w = do
1683 rdrs <- GHC.getRdrNamesInScope s
1684 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1686 completeModule w = do
1688 dflags <- GHC.getSessionDynFlags s
1689 let pkg_mods = allExposedModules dflags
1690 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1692 completeHomeModule w = do
1694 g <- GHC.getModuleGraph s
1695 let home_mods = map GHC.ms_mod_name g
1696 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1698 completeSetOptions w = do
1699 return (filter (w `isPrefixOf`) options)
1700 where options = "args":"prog":allFlags
1702 completeFilename = Readline.filenameCompletionFunction
1704 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1706 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1707 unionComplete f1 f2 w = do
1712 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1713 wrapCompleter fun w = do
1716 [] -> return Nothing
1717 [x] -> return (Just (x,[]))
1718 xs -> case getCommonPrefix xs of
1719 "" -> return (Just ("",xs))
1720 pref -> return (Just (pref,xs))
1722 getCommonPrefix :: [String] -> String
1723 getCommonPrefix [] = ""
1724 getCommonPrefix (s:ss) = foldl common s ss
1725 where common _s "" = ""
1727 common (c:cs) (d:ds)
1728 | c == d = c : common cs ds
1731 allExposedModules :: DynFlags -> [ModuleName]
1732 allExposedModules dflags
1733 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1735 pkg_db = pkgIdMap (pkgState dflags)
1737 completeMacro = completeNone
1738 completeIdentifier = completeNone
1739 completeModule = completeNone
1740 completeHomeModule = completeNone
1741 completeSetOptions = completeNone
1742 completeFilename = completeNone
1743 completeHomeModuleOrFile=completeNone
1746 -- ---------------------------------------------------------------------------
1747 -- User code exception handling
1749 -- This is the exception handler for exceptions generated by the
1750 -- user's code and exceptions coming from children sessions;
1751 -- it normally just prints out the exception. The
1752 -- handler must be recursive, in case showing the exception causes
1753 -- more exceptions to be raised.
1755 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1756 -- raising another exception. We therefore don't put the recursive
1757 -- handler arond the flushing operation, so if stderr is closed
1758 -- GHCi will just die gracefully rather than going into an infinite loop.
1759 handler :: Exception -> GHCi Bool
1761 handler exception = do
1763 io installSignalHandlers
1764 ghciHandle handler (showException exception >> return False)
1766 showException :: Exception -> GHCi ()
1767 showException (DynException dyn) =
1768 case fromDynamic dyn of
1769 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1770 Just Interrupted -> io (putStrLn "Interrupted.")
1771 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1772 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1773 Just other_ghc_ex -> io (print other_ghc_ex)
1775 showException other_exception
1776 = io (putStrLn ("*** Exception: " ++ show other_exception))
1778 -----------------------------------------------------------------------------
1779 -- recursive exception handlers
1781 -- Don't forget to unblock async exceptions in the handler, or if we're
1782 -- in an exception loop (eg. let a = error a in a) the ^C exception
1783 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1785 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1786 ghciHandle h (GHCi m) = GHCi $ \s ->
1787 Exception.catch (m s)
1788 (\e -> unGHCi (ghciUnblock (h e)) s)
1790 ghciUnblock :: GHCi a -> GHCi a
1791 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1794 -- ----------------------------------------------------------------------------
1797 expandPath :: String -> GHCi String
1799 case dropWhile isSpace path of
1801 tilde <- io getHomeDirectory -- will fail if HOME not defined
1802 return (tilde ++ '/':d)
1806 wantInterpretedModule :: String -> GHCi Module
1807 wantInterpretedModule str = do
1808 session <- getSession
1809 modl <- lookupModule str
1810 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1811 when (not is_interpreted) $
1812 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1815 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1816 -> (Name -> GHCi ())
1818 wantNameFromInterpretedModule noCanDo str and_then = do
1819 session <- getSession
1820 names <- io $ GHC.parseName session str
1824 let modl = GHC.nameModule n
1825 if not (GHC.isExternalName n)
1826 then noCanDo n $ ppr n <>
1827 text " is not defined in an interpreted module"
1829 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1830 if not is_interpreted
1831 then noCanDo n $ text "module " <> ppr modl <>
1832 text " is not interpreted"
1835 -- -----------------------------------------------------------------------------
1836 -- commands for debugger
1838 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1839 sprintCmd = pprintCommand False False
1840 printCmd = pprintCommand True False
1841 forceCmd = pprintCommand False True
1843 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1844 pprintCommand bind force str = do
1845 session <- getSession
1846 io $ pprintClosureCommand session bind force str
1848 stepCmd :: String -> GHCi ()
1849 stepCmd [] = doContinue (const True) GHC.SingleStep
1850 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1852 stepLocalCmd :: String -> GHCi ()
1853 stepLocalCmd [] = do
1854 mb_span <- getCurrentBreakSpan
1856 Nothing -> stepCmd []
1858 Just mod <- getCurrentBreakModule
1859 current_toplevel_decl <- enclosingTickSpan mod loc
1860 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1862 stepLocalCmd expression = stepCmd expression
1864 stepModuleCmd :: String -> GHCi ()
1865 stepModuleCmd [] = do
1866 mb_span <- getCurrentBreakSpan
1868 Nothing -> stepCmd []
1870 Just span <- getCurrentBreakSpan
1871 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1872 doContinue f GHC.SingleStep
1874 stepModuleCmd expression = stepCmd expression
1876 -- | Returns the span of the largest tick containing the srcspan given
1877 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1878 enclosingTickSpan mod src = do
1879 ticks <- getTickArray mod
1880 let line = srcSpanStartLine src
1881 ASSERT (inRange (bounds ticks) line) do
1882 let enclosing_spans = [ span | (_,span) <- ticks ! line
1883 , srcSpanEnd span >= srcSpanEnd src]
1884 return . head . sortBy leftmost_largest $ enclosing_spans
1886 traceCmd :: String -> GHCi ()
1887 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1888 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1890 continueCmd :: String -> GHCi ()
1891 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1893 -- doContinue :: SingleStep -> GHCi ()
1894 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1895 doContinue pred step = do
1896 session <- getSession
1897 runResult <- io $ GHC.resume session step
1898 afterRunStmt pred runResult
1901 abandonCmd :: String -> GHCi ()
1902 abandonCmd = noArgs $ do
1904 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1905 when (not b) $ io $ putStrLn "There is no computation running."
1908 deleteCmd :: String -> GHCi ()
1909 deleteCmd argLine = do
1910 deleteSwitch $ words argLine
1912 deleteSwitch :: [String] -> GHCi ()
1914 io $ putStrLn "The delete command requires at least one argument."
1915 -- delete all break points
1916 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1917 deleteSwitch idents = do
1918 mapM_ deleteOneBreak idents
1920 deleteOneBreak :: String -> GHCi ()
1922 | all isDigit str = deleteBreak (read str)
1923 | otherwise = return ()
1925 historyCmd :: String -> GHCi ()
1927 | null arg = history 20
1928 | all isDigit arg = history (read arg)
1929 | otherwise = io $ putStrLn "Syntax: :history [num]"
1933 resumes <- io $ GHC.getResumeContext s
1935 [] -> io $ putStrLn "Not stopped at a breakpoint"
1937 let hist = GHC.resumeHistory r
1938 (took,rest) = splitAt num hist
1940 [] -> io $ putStrLn $
1941 "Empty history. Perhaps you forgot to use :trace?"
1943 spans <- mapM (io . GHC.getHistorySpan s) took
1944 let nums = map (printf "-%-3d:") [(1::Int)..]
1945 names = map GHC.historyEnclosingDecl took
1946 printForUser (vcat(zipWith3
1947 (\x y z -> x <+> y <+> z)
1949 (map (bold . ppr) names)
1950 (map (parens . ppr) spans)))
1951 io $ putStrLn $ if null rest then "<end of history>" else "..."
1953 bold :: SDoc -> SDoc
1954 bold c | do_bold = text start_bold <> c <> text end_bold
1957 backCmd :: String -> GHCi ()
1958 backCmd = noArgs $ do
1960 (names, _, span) <- io $ GHC.back s
1961 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1962 printTypeOfNames s names
1963 -- run the command set with ":set stop <cmd>"
1965 enqueueCommands [stop st]
1967 forwardCmd :: String -> GHCi ()
1968 forwardCmd = noArgs $ do
1970 (names, ix, span) <- io $ GHC.forward s
1971 printForUser $ (if (ix == 0)
1972 then ptext SLIT("Stopped at")
1973 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1974 printTypeOfNames s names
1975 -- run the command set with ":set stop <cmd>"
1977 enqueueCommands [stop st]
1979 -- handle the "break" command
1980 breakCmd :: String -> GHCi ()
1981 breakCmd argLine = do
1982 session <- getSession
1983 breakSwitch session $ words argLine
1985 breakSwitch :: Session -> [String] -> GHCi ()
1986 breakSwitch _session [] = do
1987 io $ putStrLn "The break command requires at least one argument."
1988 breakSwitch session (arg1:rest)
1989 | looksLikeModuleName arg1 = do
1990 mod <- wantInterpretedModule arg1
1991 breakByModule mod rest
1992 | all isDigit arg1 = do
1993 (toplevel, _) <- io $ GHC.getContext session
1995 (mod : _) -> breakByModuleLine mod (read arg1) rest
1997 io $ putStrLn "Cannot find default module for breakpoint."
1998 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1999 | otherwise = do -- try parsing it as an identifier
2000 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2001 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2002 if GHC.isGoodSrcLoc loc
2003 then findBreakAndSet (GHC.nameModule name) $
2004 findBreakByCoord (Just (GHC.srcLocFile loc))
2005 (GHC.srcLocLine loc,
2007 else noCanDo name $ text "can't find its location: " <> ppr loc
2009 noCanDo n why = printForUser $
2010 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2012 breakByModule :: Module -> [String] -> GHCi ()
2013 breakByModule mod (arg1:rest)
2014 | all isDigit arg1 = do -- looks like a line number
2015 breakByModuleLine mod (read arg1) rest
2019 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2020 breakByModuleLine mod line args
2021 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2022 | [col] <- args, all isDigit col =
2023 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2024 | otherwise = breakSyntax
2027 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2029 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2030 findBreakAndSet mod lookupTickTree = do
2031 tickArray <- getTickArray mod
2032 (breakArray, _) <- getModBreak mod
2033 case lookupTickTree tickArray of
2034 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2035 Just (tick, span) -> do
2036 success <- io $ setBreakFlag True breakArray tick
2040 recordBreak $ BreakLocation
2047 text "Breakpoint " <> ppr nm <>
2049 then text " was already set at " <> ppr span
2050 else text " activated at " <> ppr span
2052 printForUser $ text "Breakpoint could not be activated at"
2055 -- When a line number is specified, the current policy for choosing
2056 -- the best breakpoint is this:
2057 -- - the leftmost complete subexpression on the specified line, or
2058 -- - the leftmost subexpression starting on the specified line, or
2059 -- - the rightmost subexpression enclosing the specified line
2061 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2062 findBreakByLine line arr
2063 | not (inRange (bounds arr) line) = Nothing
2065 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2066 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2067 listToMaybe (sortBy (rightmost `on` snd) ticks)
2071 starts_here = [ tick | tick@(_,span) <- ticks,
2072 GHC.srcSpanStartLine span == line ]
2074 (complete,incomplete) = partition ends_here starts_here
2075 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2077 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2078 -> Maybe (BreakIndex,SrcSpan)
2079 findBreakByCoord mb_file (line, col) arr
2080 | not (inRange (bounds arr) line) = Nothing
2082 listToMaybe (sortBy (rightmost `on` snd) contains ++
2083 sortBy (leftmost_smallest `on` snd) after_here)
2087 -- the ticks that span this coordinate
2088 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2089 is_correct_file span ]
2091 is_correct_file span
2092 | Just f <- mb_file = GHC.srcSpanFile span == f
2095 after_here = [ tick | tick@(_,span) <- ticks,
2096 GHC.srcSpanStartLine span == line,
2097 GHC.srcSpanStartCol span >= col ]
2099 -- For now, use ANSI bold on terminals that we know support it.
2100 -- Otherwise, we add a line of carets under the active expression instead.
2101 -- In particular, on Windows and when running the testsuite (which sets
2102 -- TERM to vt100 for other reasons) we get carets.
2103 -- We really ought to use a proper termcap/terminfo library.
2105 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2106 where mTerm = System.Environment.getEnv "TERM"
2107 `Exception.catch` \_ -> return "TERM not set"
2109 start_bold :: String
2110 start_bold = "\ESC[1m"
2112 end_bold = "\ESC[0m"
2114 listCmd :: String -> GHCi ()
2116 mb_span <- getCurrentBreakSpan
2118 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
2119 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
2120 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
2121 listCmd str = list2 (words str)
2123 list2 :: [String] -> GHCi ()
2124 list2 [arg] | all isDigit arg = do
2125 session <- getSession
2126 (toplevel, _) <- io $ GHC.getContext session
2128 [] -> io $ putStrLn "No module to list"
2129 (mod : _) -> listModuleLine mod (read arg)
2130 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2131 mod <- wantInterpretedModule arg1
2132 listModuleLine mod (read arg2)
2134 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2135 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2136 if GHC.isGoodSrcLoc loc
2138 tickArray <- getTickArray (GHC.nameModule name)
2139 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2140 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2143 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2144 Just (_,span) -> io $ listAround span False
2146 noCanDo name $ text "can't find its location: " <>
2149 noCanDo n why = printForUser $
2150 text "cannot list source code for " <> ppr n <> text ": " <> why
2152 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2154 listModuleLine :: Module -> Int -> GHCi ()
2155 listModuleLine modl line = do
2156 session <- getSession
2157 graph <- io (GHC.getModuleGraph session)
2158 let this = filter ((== modl) . GHC.ms_mod) graph
2160 [] -> panic "listModuleLine"
2162 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2163 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2164 io $ listAround (GHC.srcLocSpan loc) False
2166 -- | list a section of a source file around a particular SrcSpan.
2167 -- If the highlight flag is True, also highlight the span using
2168 -- start_bold/end_bold.
2169 listAround :: SrcSpan -> Bool -> IO ()
2170 listAround span do_highlight = do
2171 contents <- BS.readFile (unpackFS file)
2173 lines = BS.split '\n' contents
2174 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2175 drop (line1 - 1 - pad_before) $ lines
2176 fst_line = max 1 (line1 - pad_before)
2177 line_nos = [ fst_line .. ]
2179 highlighted | do_highlight = zipWith highlight line_nos these_lines
2180 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2182 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2183 prefixed = zipWith ($) highlighted bs_line_nos
2185 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2187 file = GHC.srcSpanFile span
2188 line1 = GHC.srcSpanStartLine span
2189 col1 = GHC.srcSpanStartCol span
2190 line2 = GHC.srcSpanEndLine span
2191 col2 = GHC.srcSpanEndCol span
2193 pad_before | line1 == 1 = 0
2197 highlight | do_bold = highlight_bold
2198 | otherwise = highlight_carets
2200 highlight_bold no line prefix
2201 | no == line1 && no == line2
2202 = let (a,r) = BS.splitAt col1 line
2203 (b,c) = BS.splitAt (col2-col1) r
2205 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2207 = let (a,b) = BS.splitAt col1 line in
2208 BS.concat [prefix, a, BS.pack start_bold, b]
2210 = let (a,b) = BS.splitAt col2 line in
2211 BS.concat [prefix, a, BS.pack end_bold, b]
2212 | otherwise = BS.concat [prefix, line]
2214 highlight_carets no line prefix
2215 | no == line1 && no == line2
2216 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2217 BS.replicate (col2-col1) '^']
2219 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2222 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2224 | otherwise = BS.concat [prefix, line]
2226 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2227 nl = BS.singleton '\n'
2229 -- --------------------------------------------------------------------------
2232 getTickArray :: Module -> GHCi TickArray
2233 getTickArray modl = do
2235 let arrmap = tickarrays st
2236 case lookupModuleEnv arrmap modl of
2237 Just arr -> return arr
2239 (_breakArray, ticks) <- getModBreak modl
2240 let arr = mkTickArray (assocs ticks)
2241 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2244 discardTickArrays :: GHCi ()
2245 discardTickArrays = do
2247 setGHCiState st{tickarrays = emptyModuleEnv}
2249 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2251 = accumArray (flip (:)) [] (1, max_line)
2252 [ (line, (nm,span)) | (nm,span) <- ticks,
2253 line <- srcSpanLines span ]
2255 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2256 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2257 GHC.srcSpanEndLine span ]
2259 lookupModule :: String -> GHCi Module
2260 lookupModule modName
2261 = do session <- getSession
2262 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2264 -- don't reset the counter back to zero?
2265 discardActiveBreakPoints :: GHCi ()
2266 discardActiveBreakPoints = do
2268 mapM (turnOffBreak.snd) (breaks st)
2269 setGHCiState $ st { breaks = [] }
2271 deleteBreak :: Int -> GHCi ()
2272 deleteBreak identity = do
2274 let oldLocations = breaks st
2275 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2277 then printForUser (text "Breakpoint" <+> ppr identity <+>
2278 text "does not exist")
2280 mapM (turnOffBreak.snd) this
2281 setGHCiState $ st { breaks = rest }
2283 turnOffBreak :: BreakLocation -> GHCi Bool
2284 turnOffBreak loc = do
2285 (arr, _) <- getModBreak (breakModule loc)
2286 io $ setBreakFlag False arr (breakTick loc)
2288 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2289 getModBreak mod = do
2290 session <- getSession
2291 Just mod_info <- io $ GHC.getModuleInfo session mod
2292 let modBreaks = GHC.modInfoModBreaks mod_info
2293 let array = GHC.modBreaks_flags modBreaks
2294 let ticks = GHC.modBreaks_locs modBreaks
2295 return (array, ticks)
2297 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2298 setBreakFlag toggle array index
2299 | toggle = GHC.setBreakOn array index
2300 | otherwise = GHC.setBreakOff array index