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