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, False, completeNone),
110 ("add", keepGoingPaths addModule, False, completeFilename),
111 ("abandon", keepGoing abandonCmd, False, completeNone),
112 ("break", keepGoing breakCmd, False, completeIdentifier),
113 ("back", keepGoing backCmd, False, completeNone),
114 ("browse", keepGoing (browseCmd False), False, completeModule),
115 ("browse!", keepGoing (browseCmd True), False, completeModule),
116 ("cd", keepGoing changeDirectory, False, completeFilename),
117 ("check", keepGoing checkModule, False, completeHomeModule),
118 ("continue", keepGoing continueCmd, False, completeNone),
119 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
120 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
121 ("def", keepGoing (defineMacro False), False, completeIdentifier),
122 ("def!", keepGoing (defineMacro True), False, completeIdentifier),
123 ("delete", keepGoing deleteCmd, False, completeNone),
124 ("e", keepGoing editFile, False, completeFilename),
125 ("edit", keepGoing editFile, False, completeFilename),
126 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
127 ("force", keepGoing forceCmd, False, completeIdentifier),
128 ("forward", keepGoing forwardCmd, False, completeNone),
129 ("help", keepGoing help, False, completeNone),
130 ("history", keepGoing historyCmd, False, completeNone),
131 ("info", keepGoing info, False, completeIdentifier),
132 ("kind", keepGoing kindOfType, False, completeIdentifier),
133 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
134 ("list", keepGoing listCmd, False, completeNone),
135 ("module", keepGoing setContext, False, completeModule),
136 ("main", keepGoing runMain, False, completeIdentifier),
137 ("print", keepGoing printCmd, False, completeIdentifier),
138 ("quit", quit, False, completeNone),
139 ("reload", keepGoing reloadModule, False, completeNone),
140 ("set", keepGoing setCmd, True, completeSetOptions),
141 ("show", keepGoing showCmd, False, completeNone),
142 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
143 ("step", keepGoing stepCmd, False, completeIdentifier),
144 ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
145 ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
146 ("type", keepGoing typeOfExpr, False, completeIdentifier),
147 ("trace", keepGoing traceCmd, False, completeIdentifier),
148 ("undef", keepGoing undefineMacro, False, completeMacro),
149 ("unset", keepGoing unsetOptions, True, completeSetOptions)
152 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
153 keepGoing a str = a str >> return False
155 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
156 keepGoingPaths a str = a (toArgs str) >> return False
158 shortHelpText :: String
159 shortHelpText = "use :? for help.\n"
163 " Commands available from the prompt:\n" ++
165 " <statement> evaluate/run <statement>\n" ++
166 " : repeat last command\n" ++
167 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
168 " :add <filename> ... add module(s) to the current target set\n" ++
169 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
170 " (!: more details; *: all top-level names)\n" ++
171 " :cd <dir> change directory to <dir>\n" ++
172 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
173 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
174 " :def <cmd> <expr> define a command :<cmd>\n" ++
175 " :edit <file> edit file\n" ++
176 " :edit edit last module\n" ++
177 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
178 " :help, :? display this list of commands\n" ++
179 " :info [<name> ...] display information about the given names\n" ++
180 " :kind <type> show the kind of <type>\n" ++
181 " :load <filename> ... load module(s) and their dependents\n" ++
182 " :main [<arguments> ...] run the main function with the given arguments\n" ++
183 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
184 " :quit exit GHCi\n" ++
185 " :reload reload the current module set\n" ++
186 " :type <expr> show the type of <expr>\n" ++
187 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
188 " :!<command> run the shell command <command>\n" ++
190 " -- Commands for debugging:\n" ++
192 " :abandon at a breakpoint, abandon current computation\n" ++
193 " :back go back in the history (after :trace)\n" ++
194 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
195 " :break <name> set a breakpoint on the specified function\n" ++
196 " :continue resume after a breakpoint\n" ++
197 " :delete <number> delete the specified breakpoint\n" ++
198 " :delete * delete all breakpoints\n" ++
199 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
200 " :forward go forward in the history (after :back)\n" ++
201 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
202 " :print [<name> ...] prints a value without forcing its computation\n" ++
203 " :sprint [<name> ...] simplifed version of :print\n" ++
204 " :step single-step after stopping at a breakpoint\n"++
205 " :step <expr> single-step into <expr>\n"++
206 " :steplocal single-step restricted to the current top level decl.\n"++
207 " :stepmodule single-step restricted to the current module\n"++
208 " :trace trace after stopping at a breakpoint\n"++
209 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
212 " -- Commands for changing settings:\n" ++
214 " :set <option> ... set options\n" ++
215 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
216 " :set prog <progname> set the value returned by System.getProgName\n" ++
217 " :set prompt <prompt> set the prompt used in GHCi\n" ++
218 " :set editor <cmd> set the command used for :edit\n" ++
219 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
220 " :unset <option> ... unset options\n" ++
222 " Options for ':set' and ':unset':\n" ++
224 " +r revert top-level expressions after each evaluation\n" ++
225 " +s print timing/memory stats after each evaluation\n" ++
226 " +t print type after evaluation\n" ++
227 " -<flags> most GHC command line flags can also be set here\n" ++
228 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
229 " for GHCi-specific flags, see User's Guide,\n"++
230 " Flag reference, Interactive-mode options\n" ++
232 " -- Commands for displaying information:\n" ++
234 " :show bindings show the current bindings made at the prompt\n" ++
235 " :show breaks show the active breakpoints\n" ++
236 " :show context show the breakpoint context\n" ++
237 " :show modules show the currently loaded modules\n" ++
238 " :show packages show the currently active package flags\n" ++
239 " :show languages show the currently active language flags\n" ++
240 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
243 findEditor :: IO String
248 win <- System.Win32.getWindowsDirectory
249 return (win `joinFileName` "notepad.exe")
254 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
255 interactiveUI session srcs maybe_expr = do
256 -- HACK! If we happen to get into an infinite loop (eg the user
257 -- types 'let x=x in x' at the prompt), then the thread will block
258 -- on a blackhole, and become unreachable during GC. The GC will
259 -- detect that it is unreachable and send it the NonTermination
260 -- exception. However, since the thread is unreachable, everything
261 -- it refers to might be finalized, including the standard Handles.
262 -- This sounds like a bug, but we don't have a good solution right
268 -- Initialise buffering for the *interpreted* I/O system
269 initInterpBuffering session
271 when (isNothing maybe_expr) $ do
272 -- Only for GHCi (not runghc and ghc -e):
274 -- Turn buffering off for the compiled program's stdout/stderr
276 -- Turn buffering off for GHCi's stdout
278 hSetBuffering stdout NoBuffering
279 -- We don't want the cmd line to buffer any input that might be
280 -- intended for the program, so unbuffer stdin.
281 hSetBuffering stdin NoBuffering
283 -- initial context is just the Prelude
284 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
286 GHC.setContext session [] [prel_mod]
290 Readline.setAttemptedCompletionFunction (Just completeWord)
291 --Readline.parseAndBind "set show-all-if-ambiguous 1"
293 let symbols = "!#$%&*+/<=>?@\\^|-~"
294 specials = "(),;[]`{}"
296 word_break_chars = spaces ++ specials ++ symbols
298 Readline.setBasicWordBreakCharacters word_break_chars
299 Readline.setCompleterWordBreakCharacters word_break_chars
302 default_editor <- findEditor
304 startGHCi (runGHCi srcs maybe_expr)
305 GHCiState{ progname = "<interactive>",
309 editor = default_editor,
315 tickarrays = emptyModuleEnv,
316 last_command = Nothing,
318 remembered_ctx = Nothing
322 Readline.resetTerminal Nothing
327 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
328 runGHCi paths maybe_expr = do
329 let read_dot_files = not opt_IgnoreDotGhci
331 when (read_dot_files) $ do
334 exists <- io (doesFileExist file)
336 dir_ok <- io (checkPerms ".")
337 file_ok <- io (checkPerms file)
338 when (dir_ok && file_ok) $ do
339 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
342 Right hdl -> runCommands (fileLoop hdl False False)
344 when (read_dot_files) $ do
345 -- Read in $HOME/.ghci
346 either_dir <- io (IO.try getHomeDirectory)
350 cwd <- io (getCurrentDirectory)
351 when (dir /= cwd) $ do
352 let file = dir ++ "/.ghci"
353 ok <- io (checkPerms file)
355 either_hdl <- io (IO.try (openFile file ReadMode))
358 Right hdl -> runCommands (fileLoop hdl False False)
360 -- Perform a :load for files given on the GHCi command line
361 -- When in -e mode, if the load fails then we want to stop
362 -- immediately rather than going on to evaluate the expression.
363 when (not (null paths)) $ do
364 ok <- ghciHandle (\e -> do showException e; return Failed) $
366 when (isJust maybe_expr && failed ok) $
367 io (exitWith (ExitFailure 1))
369 -- if verbosity is greater than 0, or we are connected to a
370 -- terminal, display the prompt in the interactive loop.
371 is_tty <- io (hIsTerminalDevice stdin)
372 dflags <- getDynFlags
373 let show_prompt = verbosity dflags > 0 || is_tty
378 #if defined(mingw32_HOST_OS)
379 -- The win32 Console API mutates the first character of
380 -- type-ahead when reading from it in a non-buffered manner. Work
381 -- around this by flushing the input buffer of type-ahead characters,
382 -- but only if stdin is available.
383 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
385 Left err | isDoesNotExistError err -> return ()
386 | otherwise -> io (ioError err)
387 Right () -> return ()
389 -- enter the interactive loop
390 interactiveLoop is_tty show_prompt
392 -- just evaluate the expression we were given
397 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
400 interactiveLoop :: Bool -> Bool -> GHCi ()
401 interactiveLoop is_tty show_prompt =
402 -- Ignore ^C exceptions caught here
403 ghciHandleDyn (\e -> case e of
405 #if defined(mingw32_HOST_OS)
408 interactiveLoop is_tty show_prompt
409 _other -> return ()) $
411 ghciUnblock $ do -- unblock necessary if we recursed from the
412 -- exception handler above.
414 -- read commands from stdin
417 then runCommands readlineLoop
418 else runCommands (fileLoop stdin show_prompt is_tty)
420 runCommands (fileLoop stdin show_prompt is_tty)
424 -- NOTE: We only read .ghci files if they are owned by the current user,
425 -- and aren't world writable. Otherwise, we could be accidentally
426 -- running code planted by a malicious third party.
428 -- Furthermore, We only read ./.ghci if . is owned by the current user
429 -- and isn't writable by anyone else. I think this is sufficient: we
430 -- don't need to check .. and ../.. etc. because "." always refers to
431 -- the same directory while a process is running.
433 checkPerms :: String -> IO Bool
434 #ifdef mingw32_HOST_OS
439 Util.handle (\_ -> return False) $ do
440 st <- getFileStatus name
442 if fileOwner st /= me then do
443 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
446 let mode = fileMode st
447 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
448 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
450 putStrLn $ "*** WARNING: " ++ name ++
451 " is writable by someone else, IGNORING!"
456 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
457 fileLoop hdl show_prompt is_tty = do
458 when show_prompt $ do
461 l <- io (IO.try (hGetLine hdl))
463 Left e | isEOFError e -> return Nothing
464 | InvalidArgument <- etype -> return Nothing
465 | otherwise -> io (ioError e)
466 where etype = ioeGetErrorType e
467 -- treat InvalidArgument in the same way as EOF:
468 -- this can happen if the user closed stdin, or
469 -- perhaps did getContents which closes stdin at
472 str <- io $ consoleInputToUnicode is_tty l
475 #ifdef mingw32_HOST_OS
476 -- Convert the console input into Unicode according to the current code page.
477 -- The Windows console stores Unicode characters directly, so this is a
478 -- rather roundabout way of doing things... oh well.
479 -- See #782, #1483, #1649
480 consoleInputToUnicode :: Bool -> String -> IO String
481 consoleInputToUnicode is_tty str
483 cp <- System.Win32.getConsoleCP
484 System.Win32.stringToUnicode cp str
486 decodeStringAsUTF8 str
488 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
490 consoleInputToUnicode :: Bool -> String -> IO String
491 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
494 decodeStringAsUTF8 :: String -> IO String
495 decodeStringAsUTF8 str =
496 withCStringLen str $ \(cstr,len) ->
497 utf8DecodeString (castPtr cstr :: Ptr Word8) len
499 mkPrompt :: GHCi String
501 session <- getSession
502 (toplevs,exports) <- io (GHC.getContext session)
503 resumes <- io $ GHC.getResumeContext session
504 -- st <- getGHCiState
510 let ix = GHC.resumeHistoryIx r
512 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
514 let hist = GHC.resumeHistory r !! (ix-1)
515 span <- io$ GHC.getHistorySpan session hist
516 return (brackets (ppr (negate ix) <> char ':'
517 <+> ppr span) <> space)
519 dots | _:rs <- resumes, not (null rs) = text "... "
526 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
527 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
528 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
529 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
530 hsep (map (ppr . GHC.moduleName) exports)
532 deflt_prompt = dots <> context_bit <> modules_bit
534 f ('%':'s':xs) = deflt_prompt <> f xs
535 f ('%':'%':xs) = char '%' <> f xs
536 f (x:xs) = char x <> f xs
540 return (showSDoc (f (prompt st)))
544 readlineLoop :: GHCi (Maybe String)
547 saveSession -- for use by completion
549 l <- io (readline prompt `finally` setNonBlockingFD 0)
550 -- readline sometimes puts stdin into blocking mode,
551 -- so we need to put it back for the IO library
554 Nothing -> return Nothing
557 str <- io $ consoleInputToUnicode True l
561 queryQueue :: GHCi (Maybe String)
566 c:cs -> do setGHCiState st{ cmdqueue = cs }
569 runCommands :: GHCi (Maybe String) -> GHCi ()
570 runCommands getCmd = do
571 mb_cmd <- noSpace queryQueue
572 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
576 b <- ghciHandle handler (doCommand c)
577 if b then return () else runCommands getCmd
579 noSpace q = q >>= maybe (return Nothing)
580 (\c->case removeSpaces c of
582 ":{" -> multiLineCmd q
583 c -> return (Just c) )
587 setGHCiState st{ prompt = "%s| " }
588 mb_cmd <- collectCommand q ""
589 getGHCiState >>= \st->setGHCiState st{ prompt = p }
591 -- we can't use removeSpaces for the sublines here, so
592 -- multiline commands are somewhat more brittle against
593 -- fileformat errors (such as \r in dos input on unix),
594 -- we get rid of any extra spaces for the ":}" test;
595 -- we also avoid silent failure if ":}" is not found;
596 -- and since there is no (?) valid occurrence of \r (as
597 -- opposed to its String representation, "\r") inside a
598 -- ghci command, we replace any such with ' ' (argh:-(
599 collectCommand q c = q >>=
600 maybe (io (ioError collectError))
601 (\l->if removeSpaces l == ":}"
602 then return (Just $ removeSpaces c)
603 else collectCommand q (c++map normSpace l))
604 where normSpace '\r' = ' '
606 -- QUESTION: is userError the one to use here?
607 collectError = userError "unterminated multiline command :{ .. :}"
608 doCommand (':' : cmd) = specialCommand cmd
609 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
612 enqueueCommands :: [String] -> GHCi ()
613 enqueueCommands cmds = do
615 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
618 -- This version is for the GHC command-line option -e. The only difference
619 -- from runCommand is that it catches the ExitException exception and
620 -- exits, rather than printing out the exception.
621 runCommandEval :: String -> GHCi Bool
622 runCommandEval c = ghciHandle handleEval (doCommand c)
624 handleEval (ExitException code) = io (exitWith code)
625 handleEval e = do handler e
626 io (exitWith (ExitFailure 1))
628 doCommand (':' : command) = specialCommand command
630 = do r <- runStmt stmt GHC.RunToCompletion
632 False -> io (exitWith (ExitFailure 1))
633 -- failure to run the command causes exit(1) for ghc -e.
636 runStmt :: String -> SingleStep -> GHCi Bool
638 | null (filter (not.isSpace) stmt) = return False
639 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
641 = do st <- getGHCiState
642 session <- getSession
643 result <- io $ withProgName (progname st) $ withArgs (args st) $
644 GHC.runStmt session stmt step
645 afterRunStmt (const True) result
648 --afterRunStmt :: GHC.RunResult -> GHCi Bool
649 -- False <=> the statement failed to compile
650 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
651 afterRunStmt _ (GHC.RunException e) = throw e
652 afterRunStmt step_here run_result = do
653 session <- getSession
654 resumes <- io $ GHC.getResumeContext session
656 GHC.RunOk names -> do
657 show_types <- isOptionSet ShowType
658 when show_types $ printTypeOfNames session names
659 GHC.RunBreak _ names mb_info
660 | isNothing mb_info ||
661 step_here (GHC.resumeSpan $ head resumes) -> do
662 printForUser $ ptext SLIT("Stopped at") <+>
663 ppr (GHC.resumeSpan $ head resumes)
664 -- printTypeOfNames session names
665 let namesSorted = sortBy compareNames names
666 tythings <- catMaybes `liftM`
667 io (mapM (GHC.lookupName session) namesSorted)
668 docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
669 printForUserPartWay docs
670 maybe (return ()) runBreakCmd mb_info
671 -- run the command set with ":set stop <cmd>"
673 enqueueCommands [stop st]
675 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
676 afterRunStmt step_here >> return ()
680 io installSignalHandlers
681 b <- isOptionSet RevertCAFs
682 io (when b revertCAFs)
684 return (case run_result of GHC.RunOk _ -> True; _ -> False)
686 runBreakCmd :: GHC.BreakInfo -> GHCi ()
687 runBreakCmd info = do
688 let mod = GHC.breakInfo_module info
689 nm = GHC.breakInfo_number info
691 case [ loc | (_,loc) <- breaks st,
692 breakModule loc == mod, breakTick loc == nm ] of
694 loc:_ | null cmd -> return ()
695 | otherwise -> do enqueueCommands [cmd]; return ()
696 where cmd = onBreakCmd loc
698 printTypeOfNames :: Session -> [Name] -> GHCi ()
699 printTypeOfNames session names
700 = mapM_ (printTypeOfName session) $ sortBy compareNames names
702 compareNames :: Name -> Name -> Ordering
703 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
704 where compareWith n = (getOccString n, getSrcSpan n)
706 printTypeOfName :: Session -> Name -> GHCi ()
707 printTypeOfName session n
708 = do maybe_tything <- io (GHC.lookupName session n)
709 case maybe_tything of
711 Just thing -> printTyThing thing
714 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
716 specialCommand :: String -> GHCi Bool
717 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
718 specialCommand str = do
719 let (cmd,rest) = break isSpace str
720 maybe_cmd <- lookupCommand cmd
722 GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
724 do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
728 do io $ hPutStr stdout ("there is no last command to perform\n"
732 lookupCommand :: String -> GHCi (MaybeCommand)
733 lookupCommand "" = do
735 case last_command st of
736 Just c -> return $ GotCommand c
737 Nothing -> return NoLastCommand
738 lookupCommand str = do
739 mc <- io $ lookupCommand' str
741 setGHCiState st{ last_command = mc }
743 Just c -> GotCommand c
744 Nothing -> BadCommand
746 lookupCommand' :: String -> IO (Maybe Command)
747 lookupCommand' str = do
748 macros <- readIORef macros_ref
749 let cmds = builtin_commands ++ macros
750 -- look for exact match first, then the first prefix match
751 return $ case [ c | c <- cmds, str == cmdName c ] of
753 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
757 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
758 getCurrentBreakSpan = do
759 session <- getSession
760 resumes <- io $ GHC.getResumeContext session
764 let ix = GHC.resumeHistoryIx r
766 then return (Just (GHC.resumeSpan r))
768 let hist = GHC.resumeHistory r !! (ix-1)
769 span <- io $ GHC.getHistorySpan session hist
772 getCurrentBreakModule :: GHCi (Maybe Module)
773 getCurrentBreakModule = do
774 session <- getSession
775 resumes <- io $ GHC.getResumeContext session
779 let ix = GHC.resumeHistoryIx r
781 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
783 let hist = GHC.resumeHistory r !! (ix-1)
784 return $ Just $ GHC.getHistoryModule hist
786 -----------------------------------------------------------------------------
789 noArgs :: GHCi () -> String -> GHCi ()
791 noArgs _ _ = io $ putStrLn "This command takes no arguments"
793 help :: String -> GHCi ()
794 help _ = io (putStr helpText)
796 info :: String -> GHCi ()
797 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
798 info s = do { let names = words s
799 ; session <- getSession
800 ; dflags <- getDynFlags
801 ; let pefas = dopt Opt_PrintExplicitForalls dflags
802 ; mapM_ (infoThing pefas session) names }
804 infoThing pefas session str = io $ do
805 names <- GHC.parseName session str
806 mb_stuffs <- mapM (GHC.getInfo session) names
807 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
808 unqual <- GHC.getPrintUnqual session
809 putStrLn (showSDocForUser unqual $
810 vcat (intersperse (text "") $
811 map (pprInfo pefas) filtered))
813 -- Filter out names whose parent is also there Good
814 -- example is '[]', which is both a type and data
815 -- constructor in the same type
816 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
817 filterOutChildren get_thing xs
818 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
820 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
822 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
823 pprInfo pefas (thing, fixity, insts)
824 = pprTyThingInContextLoc pefas thing
825 $$ show_fixity fixity
826 $$ vcat (map GHC.pprInstance insts)
829 | fix == GHC.defaultFixity = empty
830 | otherwise = ppr fix <+> ppr (GHC.getName thing)
832 runMain :: String -> GHCi ()
834 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
835 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
837 addModule :: [FilePath] -> GHCi ()
839 io (revertCAFs) -- always revert CAFs on load/add.
840 files <- mapM expandPath files
841 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
842 session <- getSession
843 io (mapM_ (GHC.addTarget session) targets)
844 prev_context <- io $ GHC.getContext session
845 ok <- io (GHC.load session LoadAllTargets)
846 afterLoad ok session False prev_context
848 changeDirectory :: String -> GHCi ()
849 changeDirectory "" = do
850 -- :cd on its own changes to the user's home directory
851 either_dir <- io (IO.try getHomeDirectory)
854 Right dir -> changeDirectory dir
855 changeDirectory dir = do
856 session <- getSession
857 graph <- io (GHC.getModuleGraph session)
858 when (not (null graph)) $
859 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
860 prev_context <- io $ GHC.getContext session
861 io (GHC.setTargets session [])
862 io (GHC.load session LoadAllTargets)
863 setContextAfterLoad session prev_context []
864 io (GHC.workingDirectoryChanged session)
865 dir <- expandPath dir
866 io (setCurrentDirectory dir)
868 editFile :: String -> GHCi ()
870 do file <- if null str then chooseEditFile else return str
874 $ throwDyn (CmdLineError "editor not set, use :set editor")
875 io $ system (cmd ++ ' ':file)
878 -- The user didn't specify a file so we pick one for them.
879 -- Our strategy is to pick the first module that failed to load,
880 -- or otherwise the first target.
882 -- XXX: Can we figure out what happened if the depndecy analysis fails
883 -- (e.g., because the porgrammeer mistyped the name of a module)?
884 -- XXX: Can we figure out the location of an error to pass to the editor?
885 -- XXX: if we could figure out the list of errors that occured during the
886 -- last load/reaload, then we could start the editor focused on the first
888 chooseEditFile :: GHCi String
890 do session <- getSession
891 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
893 graph <- io (GHC.getModuleGraph session)
894 failed_graph <- filterM hasFailed graph
895 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
897 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
900 case pick (order failed_graph) of
901 Just file -> return file
903 do targets <- io (GHC.getTargets session)
904 case msum (map fromTarget targets) of
905 Just file -> return file
906 Nothing -> throwDyn (CmdLineError "No files to edit.")
908 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
909 fromTarget _ = Nothing -- when would we get a module target?
911 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
912 defineMacro overwrite s = do
913 let (macro_name, definition) = break isSpace s
914 macros <- io (readIORef macros_ref)
915 let defined = map cmdName macros
918 then io $ putStrLn "no macros defined"
919 else io $ putStr ("the following macros are defined:\n" ++
922 if (not overwrite && macro_name `elem` defined)
923 then throwDyn (CmdLineError
924 ("macro '" ++ macro_name ++ "' is already defined"))
927 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
929 -- give the expression a type signature, so we can be sure we're getting
930 -- something of the right type.
931 let new_expr = '(' : definition ++ ") :: String -> IO String"
933 -- compile the expression
935 maybe_hv <- io (GHC.compileExpr cms new_expr)
938 Just hv -> io (writeIORef macros_ref --
939 (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
941 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
943 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
944 enqueueCommands (lines str)
947 undefineMacro :: String -> GHCi ()
948 undefineMacro str = mapM_ undef (words str)
949 where undef macro_name = do
950 cmds <- io (readIORef macros_ref)
951 if (macro_name `notElem` map cmdName cmds)
952 then throwDyn (CmdLineError
953 ("macro '" ++ macro_name ++ "' is not defined"))
955 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
957 cmdCmd :: String -> GHCi ()
959 let expr = '(' : str ++ ") :: IO String"
960 session <- getSession
961 maybe_hv <- io (GHC.compileExpr session expr)
965 cmds <- io $ (unsafeCoerce# hv :: IO String)
966 enqueueCommands (lines cmds)
969 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
970 loadModule fs = timeIt (loadModule' fs)
972 loadModule_ :: [FilePath] -> GHCi ()
973 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
975 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
976 loadModule' files = do
977 session <- getSession
978 prev_context <- io $ GHC.getContext session
981 discardActiveBreakPoints
982 io (GHC.setTargets session [])
983 io (GHC.load session LoadAllTargets)
986 let (filenames, phases) = unzip files
987 exp_filenames <- mapM expandPath filenames
988 let files' = zip exp_filenames phases
989 targets <- io (mapM (uncurry GHC.guessTarget) files')
991 -- NOTE: we used to do the dependency anal first, so that if it
992 -- fails we didn't throw away the current set of modules. This would
993 -- require some re-working of the GHC interface, so we'll leave it
994 -- as a ToDo for now.
996 io (GHC.setTargets session targets)
997 doLoad session False prev_context LoadAllTargets
999 checkModule :: String -> GHCi ()
1001 let modl = GHC.mkModuleName m
1002 session <- getSession
1003 prev_context <- io $ GHC.getContext session
1004 result <- io (GHC.checkModule session modl False)
1006 Nothing -> io $ putStrLn "Nothing"
1007 Just r -> io $ putStrLn (showSDoc (
1008 case GHC.checkedModuleInfo r of
1009 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1011 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1013 (text "global names: " <+> ppr global) $$
1014 (text "local names: " <+> ppr local)
1016 afterLoad (successIf (isJust result)) session False prev_context
1018 reloadModule :: String -> GHCi ()
1020 session <- getSession
1021 prev_context <- io $ GHC.getContext session
1022 doLoad session True prev_context $
1023 if null m then LoadAllTargets
1024 else LoadUpTo (GHC.mkModuleName m)
1027 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1028 doLoad session retain_context prev_context howmuch = do
1029 -- turn off breakpoints before we load: we can't turn them off later, because
1030 -- the ModBreaks will have gone away.
1031 discardActiveBreakPoints
1032 ok <- io (GHC.load session howmuch)
1033 afterLoad ok session retain_context prev_context
1036 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1037 afterLoad ok session retain_context prev_context = do
1038 io (revertCAFs) -- always revert CAFs on load.
1040 loaded_mod_summaries <- getLoadedModules session
1041 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1042 loaded_mod_names = map GHC.moduleName loaded_mods
1043 modulesLoadedMsg ok loaded_mod_names
1046 if not retain_context
1048 setGHCiState st{ remembered_ctx = Nothing }
1049 setContextAfterLoad session prev_context loaded_mod_summaries
1051 -- figure out which modules we can keep in the context, which we
1052 -- have to put back, and which we have to remember because they
1053 -- are (temporarily) unavailable. See ghci.prog009, #1873, #1360
1054 let (as,bs) = prev_context
1055 as1 = filter isHomeModule as -- package modules are kept anyway
1056 bs1 = filter isHomeModule bs
1057 (as_ok, as_bad) = partition (`elem` loaded_mods) as1
1058 (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1
1059 (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st)
1060 (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as
1061 (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs
1062 as' = nub (as_ok++rem_as_ok)
1063 bs' = nub (bs_ok++rem_bs_ok)
1064 rem_as' = nub (rem_as_bad ++ as_bad)
1065 rem_bs' = nub (rem_bs_bad ++ bs_bad)
1067 -- Put back into the context any modules that we previously had
1068 -- to drop because they weren't available (rem_as_ok, rem_bs_ok).
1069 setContextKeepingPackageModules session prev_context (as',bs')
1071 -- If compilation failed, remember any modules that we are unable
1072 -- to load, so that we can put them back in the context in the future.
1074 Succeeded -> setGHCiState st{ remembered_ctx = Nothing }
1075 Failed -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') }
1079 setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi ()
1080 setContextAfterLoad session prev [] = do
1081 prel_mod <- getPrelude
1082 setContextKeepingPackageModules session prev ([], [prel_mod])
1083 setContextAfterLoad session prev ms = do
1084 -- load a target if one is available, otherwise load the topmost module.
1085 targets <- io (GHC.getTargets session)
1086 case [ m | Just m <- map (findTarget ms) targets ] of
1088 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1089 load_this (last graph')
1094 = case filter (`matches` t) ms of
1098 summary `matches` Target (TargetModule m) _
1099 = GHC.ms_mod_name summary == m
1100 summary `matches` Target (TargetFile f _) _
1101 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1105 load_this summary | m <- GHC.ms_mod summary = do
1106 b <- io (GHC.moduleIsInterpreted session m)
1107 if b then setContextKeepingPackageModules session prev ([m], [])
1109 prel_mod <- getPrelude
1110 setContextKeepingPackageModules session prev ([],[prel_mod,m])
1112 -- | Keep any package modules (except Prelude) when changing the context.
1113 setContextKeepingPackageModules
1115 -> ([Module],[Module]) -- previous context
1116 -> ([Module],[Module]) -- new context
1118 setContextKeepingPackageModules session prev_context (as,bs) = do
1119 let (_,bs0) = prev_context
1120 prel_mod <- getPrelude
1121 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1122 let bs1 = if null as then nub (prel_mod : bs) else bs
1123 io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1125 isHomeModule :: Module -> Bool
1126 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1128 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1129 modulesLoadedMsg ok mods = do
1130 dflags <- getDynFlags
1131 when (verbosity dflags > 0) $ do
1133 | null mods = text "none."
1134 | otherwise = hsep (
1135 punctuate comma (map ppr mods)) <> text "."
1138 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1140 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1143 typeOfExpr :: String -> GHCi ()
1145 = do cms <- getSession
1146 maybe_ty <- io (GHC.exprType cms str)
1148 Nothing -> return ()
1149 Just ty -> do dflags <- getDynFlags
1150 let pefas = dopt Opt_PrintExplicitForalls dflags
1151 printForUser $ text str <+> dcolon
1152 <+> pprTypeForUser pefas ty
1154 kindOfType :: String -> GHCi ()
1156 = do cms <- getSession
1157 maybe_ty <- io (GHC.typeKind cms str)
1159 Nothing -> return ()
1160 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1162 quit :: String -> GHCi Bool
1163 quit _ = return True
1165 shellEscape :: String -> GHCi Bool
1166 shellEscape str = io (system str >> return False)
1168 -----------------------------------------------------------------------------
1169 -- Browsing a module's contents
1171 browseCmd :: Bool -> String -> GHCi ()
1174 ['*':s] | looksLikeModuleName s -> do
1175 m <- wantInterpretedModule s
1176 browseModule bang m False
1177 [s] | looksLikeModuleName s -> do
1179 browseModule bang m True
1182 (as,bs) <- io $ GHC.getContext s
1183 -- Guess which module the user wants to browse. Pick
1184 -- modules that are interpreted first. The most
1185 -- recently-added module occurs last, it seems.
1187 (as@(_:_), _) -> browseModule bang (last as) True
1188 ([], bs@(_:_)) -> browseModule bang (last bs) True
1189 ([], []) -> throwDyn (CmdLineError ":browse: no current module")
1190 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1192 -- without bang, show items in context of their parents and omit children
1193 -- with bang, show class methods and data constructors separately, and
1194 -- indicate import modules, to aid qualifying unqualified names
1195 -- with sorted, sort items alphabetically
1196 browseModule :: Bool -> Module -> Bool -> GHCi ()
1197 browseModule bang modl exports_only = do
1199 -- :browse! reports qualifiers wrt current context
1200 current_unqual <- io (GHC.getPrintUnqual s)
1201 -- Temporarily set the context to the module we're interested in,
1202 -- just so we can get an appropriate PrintUnqualified
1203 (as,bs) <- io (GHC.getContext s)
1204 prel_mod <- getPrelude
1205 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1206 else GHC.setContext s [modl] [])
1207 target_unqual <- io (GHC.getPrintUnqual s)
1208 io (GHC.setContext s as bs)
1210 let unqual = if bang then current_unqual else target_unqual
1212 mb_mod_info <- io $ GHC.getModuleInfo s modl
1214 Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1215 GHC.moduleNameString (GHC.moduleName modl)))
1217 dflags <- getDynFlags
1219 | exports_only = GHC.modInfoExports mod_info
1220 | otherwise = GHC.modInfoTopLevelScope mod_info
1223 -- sort alphabetically name, but putting
1224 -- locally-defined identifiers first.
1225 -- We would like to improve this; see #1799.
1226 sorted_names = loc_sort local ++ occ_sort external
1228 (local,external) = partition ((==modl) . nameModule) names
1229 occ_sort = sortBy (compare `on` nameOccName)
1230 -- try to sort by src location. If the first name in
1231 -- our list has a good source location, then they all should.
1233 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1234 = sortBy (compare `on` nameSrcSpan) names
1238 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1239 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1241 rdr_env <- io $ GHC.getGRE s
1243 let pefas = dopt Opt_PrintExplicitForalls dflags
1244 things | bang = catMaybes mb_things
1245 | otherwise = filtered_things
1246 pretty | bang = pprTyThing
1247 | otherwise = pprTyThingInContext
1249 labels [] = text "-- not currently imported"
1250 labels l = text $ intercalate "\n" $ map qualifier l
1251 qualifier = maybe "-- defined locally"
1252 (("-- imported via "++) . intercalate ", "
1253 . map GHC.moduleNameString)
1254 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1255 modNames = map (importInfo . GHC.getName) things
1257 -- annotate groups of imports with their import modules
1258 -- the default ordering is somewhat arbitrary, so we group
1259 -- by header and sort groups; the names themselves should
1260 -- really come in order of source appearance.. (trac #1799)
1261 annotate mts = concatMap (\(m,ts)->labels m:ts)
1262 $ sortBy cmpQualifiers $ group mts
1263 where cmpQualifiers =
1264 compare `on` (map (fmap (map moduleNameFS)) . fst)
1266 group mts@((m,_):_) = (m,map snd g) : group ng
1267 where (g,ng) = partition ((==m).fst) mts
1269 let prettyThings = map (pretty pefas) things
1270 prettyThings' | bang = annotate $ zip modNames prettyThings
1271 | otherwise = prettyThings
1272 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1273 -- ToDo: modInfoInstances currently throws an exception for
1274 -- package modules. When it works, we can do this:
1275 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1277 -----------------------------------------------------------------------------
1278 -- Setting the module context
1280 setContext :: String -> GHCi ()
1282 | all sensible mods = fn mods
1283 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1285 (fn, mods) = case str of
1286 '+':stuff -> (addToContext, words stuff)
1287 '-':stuff -> (removeFromContext, words stuff)
1288 stuff -> (newContext, words stuff)
1290 sensible ('*':m) = looksLikeModuleName m
1291 sensible m = looksLikeModuleName m
1293 separate :: Session -> [String] -> [Module] -> [Module]
1294 -> GHCi ([Module],[Module])
1295 separate _ [] as bs = return (as,bs)
1296 separate session (('*':str):ms) as bs = do
1297 m <- wantInterpretedModule str
1298 separate session ms (m:as) bs
1299 separate session (str:ms) as bs = do
1300 m <- lookupModule str
1301 separate session ms as (m:bs)
1303 newContext :: [String] -> GHCi ()
1304 newContext strs = do
1306 (as,bs) <- separate s strs [] []
1307 prel_mod <- getPrelude
1308 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1309 io $ GHC.setContext s as bs'
1312 addToContext :: [String] -> GHCi ()
1313 addToContext strs = do
1315 (as,bs) <- io $ GHC.getContext s
1317 (new_as,new_bs) <- separate s strs [] []
1319 let as_to_add = new_as \\ (as ++ bs)
1320 bs_to_add = new_bs \\ (as ++ bs)
1322 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1325 removeFromContext :: [String] -> GHCi ()
1326 removeFromContext strs = do
1328 (as,bs) <- io $ GHC.getContext s
1330 (as_to_remove,bs_to_remove) <- separate s strs [] []
1332 let as' = as \\ (as_to_remove ++ bs_to_remove)
1333 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1335 io $ GHC.setContext s as' bs'
1337 ----------------------------------------------------------------------------
1340 -- set options in the interpreter. Syntax is exactly the same as the
1341 -- ghc command line, except that certain options aren't available (-C,
1344 -- This is pretty fragile: most options won't work as expected. ToDo:
1345 -- figure out which ones & disallow them.
1347 setCmd :: String -> GHCi ()
1349 = do st <- getGHCiState
1350 let opts = options st
1351 io $ putStrLn (showSDoc (
1352 text "options currently set: " <>
1355 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1357 dflags <- getDynFlags
1358 io $ putStrLn (showSDoc (
1359 vcat (text "GHCi-specific dynamic flag settings:"
1360 :map (flagSetting dflags) ghciFlags)
1362 io $ putStrLn (showSDoc (
1363 vcat (text "other dynamic, non-language, flag settings:"
1364 :map (flagSetting dflags) nonLanguageDynFlags)
1366 where flagSetting dflags (str,f)
1367 | dopt f dflags = text " " <> text "-f" <> text str
1368 | otherwise = text " " <> text "-fno-" <> text str
1369 (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
1371 nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1373 flags = [Opt_PrintExplicitForalls
1374 ,Opt_PrintBindResult
1375 ,Opt_BreakOnException
1377 ,Opt_PrintEvldWithShow
1380 = case toArgs str of
1381 ("args":args) -> setArgs args
1382 ("prog":prog) -> setProg prog
1383 ("prompt":_) -> setPrompt (after 6)
1384 ("editor":_) -> setEditor (after 6)
1385 ("stop":_) -> setStop (after 4)
1386 wds -> setOptions wds
1387 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1389 setArgs, setProg, setOptions :: [String] -> GHCi ()
1390 setEditor, setStop, setPrompt :: String -> GHCi ()
1394 setGHCiState st{ args = args }
1398 setGHCiState st{ progname = prog }
1400 io (hPutStrLn stderr "syntax: :set prog <progname>")
1404 setGHCiState st{ editor = cmd }
1406 setStop str@(c:_) | isDigit c
1407 = do let (nm_str,rest) = break (not.isDigit) str
1410 let old_breaks = breaks st
1411 if all ((/= nm) . fst) old_breaks
1412 then printForUser (text "Breakpoint" <+> ppr nm <+>
1413 text "does not exist")
1415 let new_breaks = map fn old_breaks
1416 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1417 | otherwise = (i,loc)
1418 setGHCiState st{ breaks = new_breaks }
1421 setGHCiState st{ stop = cmd }
1423 setPrompt value = do
1426 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1427 else setGHCiState st{ prompt = remQuotes value }
1429 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1433 do -- first, deal with the GHCi opts (+s, +t, etc.)
1434 let (plus_opts, minus_opts) = partitionWith isPlus wds
1435 mapM_ setOpt plus_opts
1436 -- then, dynamic flags
1437 newDynFlags minus_opts
1439 newDynFlags :: [String] -> GHCi ()
1440 newDynFlags minus_opts = do
1441 dflags <- getDynFlags
1442 let pkg_flags = packageFlags dflags
1443 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1445 if (not (null leftovers))
1446 then throwDyn (CmdLineError ("unrecognised flags: " ++
1450 new_pkgs <- setDynFlags dflags'
1452 -- if the package flags changed, we should reset the context
1453 -- and link the new packages.
1454 dflags <- getDynFlags
1455 when (packageFlags dflags /= pkg_flags) $ do
1456 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1457 session <- getSession
1458 io (GHC.setTargets session [])
1459 io (GHC.load session LoadAllTargets)
1460 io (linkPackages dflags new_pkgs)
1461 -- package flags changed, we can't re-use any of the old context
1462 setContextAfterLoad session ([],[]) []
1466 unsetOptions :: String -> GHCi ()
1468 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1469 let opts = words str
1470 (minus_opts, rest1) = partition isMinus opts
1471 (plus_opts, rest2) = partitionWith isPlus rest1
1473 if (not (null rest2))
1474 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1477 mapM_ unsetOpt plus_opts
1479 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1480 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1482 no_flags <- mapM no_flag minus_opts
1483 newDynFlags no_flags
1485 isMinus :: String -> Bool
1486 isMinus ('-':_) = True
1489 isPlus :: String -> Either String String
1490 isPlus ('+':opt) = Left opt
1491 isPlus other = Right other
1493 setOpt, unsetOpt :: String -> GHCi ()
1496 = case strToGHCiOpt str of
1497 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1498 Just o -> setOption o
1501 = case strToGHCiOpt str of
1502 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1503 Just o -> unsetOption o
1505 strToGHCiOpt :: String -> (Maybe GHCiOption)
1506 strToGHCiOpt "s" = Just ShowTiming
1507 strToGHCiOpt "t" = Just ShowType
1508 strToGHCiOpt "r" = Just RevertCAFs
1509 strToGHCiOpt _ = Nothing
1511 optToStr :: GHCiOption -> String
1512 optToStr ShowTiming = "s"
1513 optToStr ShowType = "t"
1514 optToStr RevertCAFs = "r"
1516 -- ---------------------------------------------------------------------------
1519 showCmd :: String -> GHCi ()
1523 ["args"] -> io $ putStrLn (show (args st))
1524 ["prog"] -> io $ putStrLn (show (progname st))
1525 ["prompt"] -> io $ putStrLn (show (prompt st))
1526 ["editor"] -> io $ putStrLn (show (editor st))
1527 ["stop"] -> io $ putStrLn (show (stop st))
1528 ["modules" ] -> showModules
1529 ["bindings"] -> showBindings
1530 ["linker"] -> io showLinkerState
1531 ["breaks"] -> showBkptTable
1532 ["context"] -> showContext
1533 ["packages"] -> showPackages
1534 ["languages"] -> showLanguages
1535 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1537 showModules :: GHCi ()
1539 session <- getSession
1540 loaded_mods <- getLoadedModules session
1541 -- we want *loaded* modules only, see #1734
1542 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1543 mapM_ show_one loaded_mods
1545 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1546 getLoadedModules session = do
1547 graph <- io (GHC.getModuleGraph session)
1548 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1550 showBindings :: GHCi ()
1553 bindings <- io (GHC.getBindings s)
1554 docs <- io$ pprTypeAndContents s
1555 [ id | AnId id <- sortBy compareTyThings bindings]
1556 printForUserPartWay docs
1558 compareTyThings :: TyThing -> TyThing -> Ordering
1559 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1561 printTyThing :: TyThing -> GHCi ()
1562 printTyThing tyth = do dflags <- getDynFlags
1563 let pefas = dopt Opt_PrintExplicitForalls dflags
1564 printForUser (pprTyThing pefas tyth)
1566 showBkptTable :: GHCi ()
1569 printForUser $ prettyLocations (breaks st)
1571 showContext :: GHCi ()
1573 session <- getSession
1574 resumes <- io $ GHC.getResumeContext session
1575 printForUser $ vcat (map pp_resume (reverse resumes))
1578 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1579 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1581 showPackages :: GHCi ()
1583 pkg_flags <- fmap packageFlags getDynFlags
1584 io $ putStrLn $ showSDoc $ vcat $
1585 text ("active package flags:"++if null pkg_flags then " none" else "")
1586 : map showFlag pkg_flags
1587 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1588 io $ putStrLn $ showSDoc $ vcat $
1589 text "packages currently loaded:"
1590 : map (nest 2 . text . packageIdString) pkg_ids
1591 where showFlag (ExposePackage p) = text $ " -package " ++ p
1592 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1593 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1595 showLanguages :: GHCi ()
1597 dflags <- getDynFlags
1598 io $ putStrLn $ showSDoc $ vcat $
1599 text "active language flags:" :
1600 [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1602 -- -----------------------------------------------------------------------------
1605 completeNone :: String -> IO [String]
1606 completeNone _w = return []
1608 completeMacro, completeIdentifier, completeModule,
1609 completeHomeModule, completeSetOptions, completeFilename,
1610 completeHomeModuleOrFile
1611 :: String -> IO [String]
1614 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1615 completeWord w start end = do
1616 line <- Readline.getLineBuffer
1617 let line_words = words (dropWhile isSpace line)
1619 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1621 | ((':':c) : _) <- line_words -> do
1622 maybe_cmd <- lookupCommand' c
1623 let (n,w') = selectWord (words' 0 line)
1625 Nothing -> return Nothing
1626 Just (_,_,False,complete) -> wrapCompleter complete w
1627 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1628 return (map (drop n) rets)
1629 in wrapCompleter complete' w'
1630 | ("import" : _) <- line_words ->
1631 wrapCompleter completeModule w
1633 --printf "complete %s, start = %d, end = %d\n" w start end
1634 wrapCompleter completeIdentifier w
1635 where words' _ [] = []
1636 words' n str = let (w,r) = break isSpace str
1637 (s,r') = span isSpace r
1638 in (n,w):words' (n+length w+length s) r'
1639 -- In a Haskell expression we want to parse 'a-b' as three words
1640 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1641 -- only be a single word.
1642 selectWord [] = (0,w)
1643 selectWord ((offset,x):xs)
1644 | offset+length x >= start = (start-offset,take (end-offset) x)
1645 | otherwise = selectWord xs
1647 completeCmd :: String -> IO [String]
1649 cmds <- readIORef macros_ref
1650 return (filter (w `isPrefixOf`) (map (':':)
1651 (map cmdName (builtin_commands ++ cmds))))
1653 completeMacro w = do
1654 cmds <- readIORef macros_ref
1655 return (filter (w `isPrefixOf`) (map cmdName cmds))
1657 completeIdentifier w = do
1659 rdrs <- GHC.getRdrNamesInScope s
1660 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1662 completeModule w = do
1664 dflags <- GHC.getSessionDynFlags s
1665 let pkg_mods = allExposedModules dflags
1666 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1668 completeHomeModule w = do
1670 g <- GHC.getModuleGraph s
1671 let home_mods = map GHC.ms_mod_name g
1672 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1674 completeSetOptions w = do
1675 return (filter (w `isPrefixOf`) options)
1676 where options = "args":"prog":allFlags
1678 completeFilename = Readline.filenameCompletionFunction
1680 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1682 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1683 unionComplete f1 f2 w = do
1688 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1689 wrapCompleter fun w = do
1692 [] -> return Nothing
1693 [x] -> return (Just (x,[]))
1694 xs -> case getCommonPrefix xs of
1695 "" -> return (Just ("",xs))
1696 pref -> return (Just (pref,xs))
1698 getCommonPrefix :: [String] -> String
1699 getCommonPrefix [] = ""
1700 getCommonPrefix (s:ss) = foldl common s ss
1701 where common _s "" = ""
1703 common (c:cs) (d:ds)
1704 | c == d = c : common cs ds
1707 allExposedModules :: DynFlags -> [ModuleName]
1708 allExposedModules dflags
1709 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1711 pkg_db = pkgIdMap (pkgState dflags)
1713 completeMacro = completeNone
1714 completeIdentifier = completeNone
1715 completeModule = completeNone
1716 completeHomeModule = completeNone
1717 completeSetOptions = completeNone
1718 completeFilename = completeNone
1719 completeHomeModuleOrFile=completeNone
1722 -- ---------------------------------------------------------------------------
1723 -- User code exception handling
1725 -- This is the exception handler for exceptions generated by the
1726 -- user's code and exceptions coming from children sessions;
1727 -- it normally just prints out the exception. The
1728 -- handler must be recursive, in case showing the exception causes
1729 -- more exceptions to be raised.
1731 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1732 -- raising another exception. We therefore don't put the recursive
1733 -- handler arond the flushing operation, so if stderr is closed
1734 -- GHCi will just die gracefully rather than going into an infinite loop.
1735 handler :: Exception -> GHCi Bool
1737 handler exception = do
1739 io installSignalHandlers
1740 ghciHandle handler (showException exception >> return False)
1742 showException :: Exception -> GHCi ()
1743 showException (DynException dyn) =
1744 case fromDynamic dyn of
1745 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1746 Just Interrupted -> io (putStrLn "Interrupted.")
1747 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1748 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1749 Just other_ghc_ex -> io (print other_ghc_ex)
1751 showException other_exception
1752 = io (putStrLn ("*** Exception: " ++ show other_exception))
1754 -----------------------------------------------------------------------------
1755 -- recursive exception handlers
1757 -- Don't forget to unblock async exceptions in the handler, or if we're
1758 -- in an exception loop (eg. let a = error a in a) the ^C exception
1759 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1761 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1762 ghciHandle h (GHCi m) = GHCi $ \s ->
1763 Exception.catch (m s)
1764 (\e -> unGHCi (ghciUnblock (h e)) s)
1766 ghciUnblock :: GHCi a -> GHCi a
1767 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1770 -- ----------------------------------------------------------------------------
1773 expandPath :: String -> GHCi String
1775 case dropWhile isSpace path of
1777 tilde <- io getHomeDirectory -- will fail if HOME not defined
1778 return (tilde ++ '/':d)
1782 wantInterpretedModule :: String -> GHCi Module
1783 wantInterpretedModule str = do
1784 session <- getSession
1785 modl <- lookupModule str
1786 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1787 when (not is_interpreted) $
1788 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1791 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1792 -> (Name -> GHCi ())
1794 wantNameFromInterpretedModule noCanDo str and_then = do
1795 session <- getSession
1796 names <- io $ GHC.parseName session str
1800 let modl = GHC.nameModule n
1801 if not (GHC.isExternalName n)
1802 then noCanDo n $ ppr n <>
1803 text " is not defined in an interpreted module"
1805 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1806 if not is_interpreted
1807 then noCanDo n $ text "module " <> ppr modl <>
1808 text " is not interpreted"
1811 -- -----------------------------------------------------------------------------
1812 -- commands for debugger
1814 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1815 sprintCmd = pprintCommand False False
1816 printCmd = pprintCommand True False
1817 forceCmd = pprintCommand False True
1819 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1820 pprintCommand bind force str = do
1821 session <- getSession
1822 io $ pprintClosureCommand session bind force str
1824 stepCmd :: String -> GHCi ()
1825 stepCmd [] = doContinue (const True) GHC.SingleStep
1826 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1828 stepLocalCmd :: String -> GHCi ()
1829 stepLocalCmd [] = do
1830 mb_span <- getCurrentBreakSpan
1832 Nothing -> stepCmd []
1834 Just mod <- getCurrentBreakModule
1835 current_toplevel_decl <- enclosingTickSpan mod loc
1836 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1838 stepLocalCmd expression = stepCmd expression
1840 stepModuleCmd :: String -> GHCi ()
1841 stepModuleCmd [] = do
1842 mb_span <- getCurrentBreakSpan
1844 Nothing -> stepCmd []
1846 Just span <- getCurrentBreakSpan
1847 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1848 doContinue f GHC.SingleStep
1850 stepModuleCmd expression = stepCmd expression
1852 -- | Returns the span of the largest tick containing the srcspan given
1853 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1854 enclosingTickSpan mod src = do
1855 ticks <- getTickArray mod
1856 let line = srcSpanStartLine src
1857 ASSERT (inRange (bounds ticks) line) do
1858 let enclosing_spans = [ span | (_,span) <- ticks ! line
1859 , srcSpanEnd span >= srcSpanEnd src]
1860 return . head . sortBy leftmost_largest $ enclosing_spans
1862 traceCmd :: String -> GHCi ()
1863 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1864 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1866 continueCmd :: String -> GHCi ()
1867 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1869 -- doContinue :: SingleStep -> GHCi ()
1870 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1871 doContinue pred step = do
1872 session <- getSession
1873 runResult <- io $ GHC.resume session step
1874 afterRunStmt pred runResult
1877 abandonCmd :: String -> GHCi ()
1878 abandonCmd = noArgs $ do
1880 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1881 when (not b) $ io $ putStrLn "There is no computation running."
1884 deleteCmd :: String -> GHCi ()
1885 deleteCmd argLine = do
1886 deleteSwitch $ words argLine
1888 deleteSwitch :: [String] -> GHCi ()
1890 io $ putStrLn "The delete command requires at least one argument."
1891 -- delete all break points
1892 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1893 deleteSwitch idents = do
1894 mapM_ deleteOneBreak idents
1896 deleteOneBreak :: String -> GHCi ()
1898 | all isDigit str = deleteBreak (read str)
1899 | otherwise = return ()
1901 historyCmd :: String -> GHCi ()
1903 | null arg = history 20
1904 | all isDigit arg = history (read arg)
1905 | otherwise = io $ putStrLn "Syntax: :history [num]"
1909 resumes <- io $ GHC.getResumeContext s
1911 [] -> io $ putStrLn "Not stopped at a breakpoint"
1913 let hist = GHC.resumeHistory r
1914 (took,rest) = splitAt num hist
1916 [] -> io $ putStrLn $
1917 "Empty history. Perhaps you forgot to use :trace?"
1919 spans <- mapM (io . GHC.getHistorySpan s) took
1920 let nums = map (printf "-%-3d:") [(1::Int)..]
1921 names = map GHC.historyEnclosingDecl took
1922 printForUser (vcat(zipWith3
1923 (\x y z -> x <+> y <+> z)
1925 (map (bold . ppr) names)
1926 (map (parens . ppr) spans)))
1927 io $ putStrLn $ if null rest then "<end of history>" else "..."
1929 bold :: SDoc -> SDoc
1930 bold c | do_bold = text start_bold <> c <> text end_bold
1933 backCmd :: String -> GHCi ()
1934 backCmd = noArgs $ do
1936 (names, _, span) <- io $ GHC.back s
1937 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1938 printTypeOfNames s names
1939 -- run the command set with ":set stop <cmd>"
1941 enqueueCommands [stop st]
1943 forwardCmd :: String -> GHCi ()
1944 forwardCmd = noArgs $ do
1946 (names, ix, span) <- io $ GHC.forward s
1947 printForUser $ (if (ix == 0)
1948 then ptext SLIT("Stopped at")
1949 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1950 printTypeOfNames s names
1951 -- run the command set with ":set stop <cmd>"
1953 enqueueCommands [stop st]
1955 -- handle the "break" command
1956 breakCmd :: String -> GHCi ()
1957 breakCmd argLine = do
1958 session <- getSession
1959 breakSwitch session $ words argLine
1961 breakSwitch :: Session -> [String] -> GHCi ()
1962 breakSwitch _session [] = do
1963 io $ putStrLn "The break command requires at least one argument."
1964 breakSwitch session (arg1:rest)
1965 | looksLikeModuleName arg1 = do
1966 mod <- wantInterpretedModule arg1
1967 breakByModule mod rest
1968 | all isDigit arg1 = do
1969 (toplevel, _) <- io $ GHC.getContext session
1971 (mod : _) -> breakByModuleLine mod (read arg1) rest
1973 io $ putStrLn "Cannot find default module for breakpoint."
1974 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1975 | otherwise = do -- try parsing it as an identifier
1976 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1977 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1978 if GHC.isGoodSrcLoc loc
1979 then findBreakAndSet (GHC.nameModule name) $
1980 findBreakByCoord (Just (GHC.srcLocFile loc))
1981 (GHC.srcLocLine loc,
1983 else noCanDo name $ text "can't find its location: " <> ppr loc
1985 noCanDo n why = printForUser $
1986 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1988 breakByModule :: Module -> [String] -> GHCi ()
1989 breakByModule mod (arg1:rest)
1990 | all isDigit arg1 = do -- looks like a line number
1991 breakByModuleLine mod (read arg1) rest
1995 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1996 breakByModuleLine mod line args
1997 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1998 | [col] <- args, all isDigit col =
1999 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2000 | otherwise = breakSyntax
2003 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2005 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2006 findBreakAndSet mod lookupTickTree = do
2007 tickArray <- getTickArray mod
2008 (breakArray, _) <- getModBreak mod
2009 case lookupTickTree tickArray of
2010 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2011 Just (tick, span) -> do
2012 success <- io $ setBreakFlag True breakArray tick
2016 recordBreak $ BreakLocation
2023 text "Breakpoint " <> ppr nm <>
2025 then text " was already set at " <> ppr span
2026 else text " activated at " <> ppr span
2028 printForUser $ text "Breakpoint could not be activated at"
2031 -- When a line number is specified, the current policy for choosing
2032 -- the best breakpoint is this:
2033 -- - the leftmost complete subexpression on the specified line, or
2034 -- - the leftmost subexpression starting on the specified line, or
2035 -- - the rightmost subexpression enclosing the specified line
2037 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2038 findBreakByLine line arr
2039 | not (inRange (bounds arr) line) = Nothing
2041 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2042 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2043 listToMaybe (sortBy (rightmost `on` snd) ticks)
2047 starts_here = [ tick | tick@(_,span) <- ticks,
2048 GHC.srcSpanStartLine span == line ]
2050 (complete,incomplete) = partition ends_here starts_here
2051 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2053 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2054 -> Maybe (BreakIndex,SrcSpan)
2055 findBreakByCoord mb_file (line, col) arr
2056 | not (inRange (bounds arr) line) = Nothing
2058 listToMaybe (sortBy (rightmost `on` snd) contains ++
2059 sortBy (leftmost_smallest `on` snd) after_here)
2063 -- the ticks that span this coordinate
2064 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2065 is_correct_file span ]
2067 is_correct_file span
2068 | Just f <- mb_file = GHC.srcSpanFile span == f
2071 after_here = [ tick | tick@(_,span) <- ticks,
2072 GHC.srcSpanStartLine span == line,
2073 GHC.srcSpanStartCol span >= col ]
2075 -- For now, use ANSI bold on terminals that we know support it.
2076 -- Otherwise, we add a line of carets under the active expression instead.
2077 -- In particular, on Windows and when running the testsuite (which sets
2078 -- TERM to vt100 for other reasons) we get carets.
2079 -- We really ought to use a proper termcap/terminfo library.
2081 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2082 where mTerm = System.Environment.getEnv "TERM"
2083 `Exception.catch` \_ -> return "TERM not set"
2085 start_bold :: String
2086 start_bold = "\ESC[1m"
2088 end_bold = "\ESC[0m"
2090 listCmd :: String -> GHCi ()
2092 mb_span <- getCurrentBreakSpan
2094 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
2095 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
2096 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
2097 listCmd str = list2 (words str)
2099 list2 :: [String] -> GHCi ()
2100 list2 [arg] | all isDigit arg = do
2101 session <- getSession
2102 (toplevel, _) <- io $ GHC.getContext session
2104 [] -> io $ putStrLn "No module to list"
2105 (mod : _) -> listModuleLine mod (read arg)
2106 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2107 mod <- wantInterpretedModule arg1
2108 listModuleLine mod (read arg2)
2110 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2111 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2112 if GHC.isGoodSrcLoc loc
2114 tickArray <- getTickArray (GHC.nameModule name)
2115 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2116 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2119 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2120 Just (_,span) -> io $ listAround span False
2122 noCanDo name $ text "can't find its location: " <>
2125 noCanDo n why = printForUser $
2126 text "cannot list source code for " <> ppr n <> text ": " <> why
2128 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2130 listModuleLine :: Module -> Int -> GHCi ()
2131 listModuleLine modl line = do
2132 session <- getSession
2133 graph <- io (GHC.getModuleGraph session)
2134 let this = filter ((== modl) . GHC.ms_mod) graph
2136 [] -> panic "listModuleLine"
2138 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2139 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2140 io $ listAround (GHC.srcLocSpan loc) False
2142 -- | list a section of a source file around a particular SrcSpan.
2143 -- If the highlight flag is True, also highlight the span using
2144 -- start_bold/end_bold.
2145 listAround :: SrcSpan -> Bool -> IO ()
2146 listAround span do_highlight = do
2147 contents <- BS.readFile (unpackFS file)
2149 lines = BS.split '\n' contents
2150 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2151 drop (line1 - 1 - pad_before) $ lines
2152 fst_line = max 1 (line1 - pad_before)
2153 line_nos = [ fst_line .. ]
2155 highlighted | do_highlight = zipWith highlight line_nos these_lines
2156 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2158 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2159 prefixed = zipWith ($) highlighted bs_line_nos
2161 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2163 file = GHC.srcSpanFile span
2164 line1 = GHC.srcSpanStartLine span
2165 col1 = GHC.srcSpanStartCol span
2166 line2 = GHC.srcSpanEndLine span
2167 col2 = GHC.srcSpanEndCol span
2169 pad_before | line1 == 1 = 0
2173 highlight | do_bold = highlight_bold
2174 | otherwise = highlight_carets
2176 highlight_bold no line prefix
2177 | no == line1 && no == line2
2178 = let (a,r) = BS.splitAt col1 line
2179 (b,c) = BS.splitAt (col2-col1) r
2181 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2183 = let (a,b) = BS.splitAt col1 line in
2184 BS.concat [prefix, a, BS.pack start_bold, b]
2186 = let (a,b) = BS.splitAt col2 line in
2187 BS.concat [prefix, a, BS.pack end_bold, b]
2188 | otherwise = BS.concat [prefix, line]
2190 highlight_carets no line prefix
2191 | no == line1 && no == line2
2192 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2193 BS.replicate (col2-col1) '^']
2195 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2198 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2200 | otherwise = BS.concat [prefix, line]
2202 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2203 nl = BS.singleton '\n'
2205 -- --------------------------------------------------------------------------
2208 getTickArray :: Module -> GHCi TickArray
2209 getTickArray modl = do
2211 let arrmap = tickarrays st
2212 case lookupModuleEnv arrmap modl of
2213 Just arr -> return arr
2215 (_breakArray, ticks) <- getModBreak modl
2216 let arr = mkTickArray (assocs ticks)
2217 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2220 discardTickArrays :: GHCi ()
2221 discardTickArrays = do
2223 setGHCiState st{tickarrays = emptyModuleEnv}
2225 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2227 = accumArray (flip (:)) [] (1, max_line)
2228 [ (line, (nm,span)) | (nm,span) <- ticks,
2229 line <- srcSpanLines span ]
2231 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2232 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2233 GHC.srcSpanEndLine span ]
2235 lookupModule :: String -> GHCi Module
2236 lookupModule modName
2237 = do session <- getSession
2238 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2240 -- don't reset the counter back to zero?
2241 discardActiveBreakPoints :: GHCi ()
2242 discardActiveBreakPoints = do
2244 mapM (turnOffBreak.snd) (breaks st)
2245 setGHCiState $ st { breaks = [] }
2247 deleteBreak :: Int -> GHCi ()
2248 deleteBreak identity = do
2250 let oldLocations = breaks st
2251 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2253 then printForUser (text "Breakpoint" <+> ppr identity <+>
2254 text "does not exist")
2256 mapM (turnOffBreak.snd) this
2257 setGHCiState $ st { breaks = rest }
2259 turnOffBreak :: BreakLocation -> GHCi Bool
2260 turnOffBreak loc = do
2261 (arr, _) <- getModBreak (breakModule loc)
2262 io $ setBreakFlag False arr (breakTick loc)
2264 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2265 getModBreak mod = do
2266 session <- getSession
2267 Just mod_info <- io $ GHC.getModuleInfo session mod
2268 let modBreaks = GHC.modInfoModBreaks mod_info
2269 let array = GHC.modBreaks_flags modBreaks
2270 let ticks = GHC.modBreaks_locs modBreaks
2271 return (array, ticks)
2273 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2274 setBreakFlag toggle array index
2275 | toggle = GHC.setBreakOn array index
2276 | otherwise = GHC.setBreakOff array index