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, Id )
32 import HscTypes ( implicitTyThings )
33 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
34 import Outputable hiding (printForUser)
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 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
102 cmdName :: Command -> String
103 cmdName (n,_,_,_) = n
105 macros_ref :: IORef [Command]
106 GLOBAL_VAR(macros_ref, [], [Command])
108 builtin_commands :: [Command]
110 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
111 ("?", keepGoing help, False, completeNone),
112 ("add", keepGoingPaths addModule, False, completeFilename),
113 ("abandon", keepGoing abandonCmd, False, completeNone),
114 ("break", keepGoing breakCmd, False, completeIdentifier),
115 ("back", keepGoing backCmd, False, completeNone),
116 ("browse", keepGoing (browseCmd False), False, completeModule),
117 ("browse!", keepGoing (browseCmd True), False, completeModule),
118 ("cd", keepGoing changeDirectory, False, completeFilename),
119 ("check", keepGoing checkModule, False, completeHomeModule),
120 ("continue", keepGoing continueCmd, False, completeNone),
121 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
122 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
123 ("def", keepGoing (defineMacro False), False, completeIdentifier),
124 ("def!", keepGoing (defineMacro True), False, completeIdentifier),
125 ("delete", keepGoing deleteCmd, False, completeNone),
126 ("e", keepGoing editFile, False, completeFilename),
127 ("edit", keepGoing editFile, False, completeFilename),
128 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
129 ("force", keepGoing forceCmd, False, completeIdentifier),
130 ("forward", keepGoing forwardCmd, False, completeNone),
131 ("help", keepGoing help, False, completeNone),
132 ("history", keepGoing historyCmd, False, completeNone),
133 ("info", keepGoing info, False, completeIdentifier),
134 ("kind", keepGoing kindOfType, False, completeIdentifier),
135 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
136 ("list", keepGoing listCmd, False, completeNone),
137 ("module", keepGoing setContext, False, completeModule),
138 ("main", keepGoing runMain, False, completeIdentifier),
139 ("print", keepGoing printCmd, False, completeIdentifier),
140 ("quit", quit, False, completeNone),
141 ("reload", keepGoing reloadModule, False, completeNone),
142 ("set", keepGoing setCmd, True, completeSetOptions),
143 ("show", keepGoing showCmd, False, completeNone),
144 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
145 ("step", keepGoing stepCmd, False, completeIdentifier),
146 ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
147 ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
148 ("type", keepGoing typeOfExpr, False, completeIdentifier),
149 ("trace", keepGoing traceCmd, False, completeIdentifier),
150 ("undef", keepGoing undefineMacro, False, completeMacro),
151 ("unset", keepGoing unsetOptions, True, completeSetOptions)
154 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
155 keepGoing a str = a str >> return False
157 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
158 keepGoingPaths a str = a (toArgs str) >> return False
160 shortHelpText :: String
161 shortHelpText = "use :? for help.\n"
165 " Commands available from the prompt:\n" ++
167 " <statement> evaluate/run <statement>\n" ++
168 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
169 " :add <filename> ... add module(s) to the current target set\n" ++
170 " :browse[!] [-s] [[*]<mod>] display the names defined by module <mod>\n" ++
171 " (!: more details; -s: sort; *: all top-level names)\n" ++
172 " :cd <dir> change directory to <dir>\n" ++
173 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
174 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
175 " :def <cmd> <expr> define a command :<cmd>\n" ++
176 " :edit <file> edit file\n" ++
177 " :edit edit last module\n" ++
178 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
179 " :help, :? display this list of commands\n" ++
180 " :info [<name> ...] display information about the given names\n" ++
181 " :kind <type> show the kind of <type>\n" ++
182 " :load <filename> ... load module(s) and their dependents\n" ++
183 " :main [<arguments> ...] run the main function with the given arguments\n" ++
184 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
185 " :quit exit GHCi\n" ++
186 " :reload reload the current module set\n" ++
187 " :type <expr> show the type of <expr>\n" ++
188 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
189 " :!<command> run the shell command <command>\n" ++
191 " -- Commands for debugging:\n" ++
193 " :abandon at a breakpoint, abandon current computation\n" ++
194 " :back go back in the history (after :trace)\n" ++
195 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
196 " :break <name> set a breakpoint on the specified function\n" ++
197 " :continue resume after a breakpoint\n" ++
198 " :delete <number> delete the specified breakpoint\n" ++
199 " :delete * delete all breakpoints\n" ++
200 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
201 " :forward go forward in the history (after :back)\n" ++
202 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
203 " :print [<name> ...] prints a value without forcing its computation\n" ++
204 " :sprint [<name> ...] simplifed version of :print\n" ++
205 " :step single-step after stopping at a breakpoint\n"++
206 " :step <expr> single-step into <expr>\n"++
207 " :steplocal single-step restricted to the current top level decl.\n"++
208 " :stepmodule single-step restricted to the current module\n"++
209 " :trace trace after stopping at a breakpoint\n"++
210 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
213 " -- Commands for changing settings:\n" ++
215 " :set <option> ... set options\n" ++
216 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
217 " :set prog <progname> set the value returned by System.getProgName\n" ++
218 " :set prompt <prompt> set the prompt used in GHCi\n" ++
219 " :set editor <cmd> set the command used for :edit\n" ++
220 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
221 " :unset <option> ... unset options\n" ++
223 " Options for ':set' and ':unset':\n" ++
225 " +r revert top-level expressions after each evaluation\n" ++
226 " +s print timing/memory stats after each evaluation\n" ++
227 " +t print type after evaluation\n" ++
228 " -<flags> most GHC command line flags can also be set here\n" ++
229 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
230 " for GHCi-specific flags, see User's Guide,\n"++
231 " Flag reference, Interactive-mode options\n" ++
233 " -- Commands for displaying information:\n" ++
235 " :show bindings show the current bindings made at the prompt\n" ++
236 " :show breaks show the active breakpoints\n" ++
237 " :show context show the breakpoint context\n" ++
238 " :show modules show the currently loaded modules\n" ++
239 " :show packages show the currently active package flags\n" ++
240 " :show languages show the currently active language flags\n" ++
241 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
244 findEditor :: IO String
249 win <- System.Win32.getWindowsDirectory
250 return (win `joinFileName` "notepad.exe")
255 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
256 interactiveUI session srcs maybe_expr = do
257 -- HACK! If we happen to get into an infinite loop (eg the user
258 -- types 'let x=x in x' at the prompt), then the thread will block
259 -- on a blackhole, and become unreachable during GC. The GC will
260 -- detect that it is unreachable and send it the NonTermination
261 -- exception. However, since the thread is unreachable, everything
262 -- it refers to might be finalized, including the standard Handles.
263 -- This sounds like a bug, but we don't have a good solution right
269 -- Initialise buffering for the *interpreted* I/O system
270 initInterpBuffering session
272 when (isNothing maybe_expr) $ do
273 -- Only for GHCi (not runghc and ghc -e):
275 -- Turn buffering off for the compiled program's stdout/stderr
277 -- Turn buffering off for GHCi's stdout
279 hSetBuffering stdout NoBuffering
280 -- We don't want the cmd line to buffer any input that might be
281 -- intended for the program, so unbuffer stdin.
282 hSetBuffering stdin NoBuffering
284 -- initial context is just the Prelude
285 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
287 GHC.setContext session [] [prel_mod]
291 Readline.setAttemptedCompletionFunction (Just completeWord)
292 --Readline.parseAndBind "set show-all-if-ambiguous 1"
294 let symbols = "!#$%&*+/<=>?@\\^|-~"
295 specials = "(),;[]`{}"
297 word_break_chars = spaces ++ specials ++ symbols
299 Readline.setBasicWordBreakCharacters word_break_chars
300 Readline.setCompleterWordBreakCharacters word_break_chars
303 default_editor <- findEditor
305 startGHCi (runGHCi srcs maybe_expr)
306 GHCiState{ progname = "<interactive>",
310 editor = default_editor,
316 tickarrays = emptyModuleEnv,
321 Readline.resetTerminal Nothing
326 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
327 runGHCi paths maybe_expr = do
328 let read_dot_files = not opt_IgnoreDotGhci
330 when (read_dot_files) $ do
333 exists <- io (doesFileExist file)
335 dir_ok <- io (checkPerms ".")
336 file_ok <- io (checkPerms file)
337 when (dir_ok && file_ok) $ do
338 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
341 Right hdl -> runCommands (fileLoop hdl False False)
343 when (read_dot_files) $ do
344 -- Read in $HOME/.ghci
345 either_dir <- io (IO.try getHomeDirectory)
349 cwd <- io (getCurrentDirectory)
350 when (dir /= cwd) $ do
351 let file = dir ++ "/.ghci"
352 ok <- io (checkPerms file)
354 either_hdl <- io (IO.try (openFile file ReadMode))
357 Right hdl -> runCommands (fileLoop hdl False False)
359 -- Perform a :load for files given on the GHCi command line
360 -- When in -e mode, if the load fails then we want to stop
361 -- immediately rather than going on to evaluate the expression.
362 when (not (null paths)) $ do
363 ok <- ghciHandle (\e -> do showException e; return Failed) $
365 when (isJust maybe_expr && failed ok) $
366 io (exitWith (ExitFailure 1))
368 -- if verbosity is greater than 0, or we are connected to a
369 -- terminal, display the prompt in the interactive loop.
370 is_tty <- io (hIsTerminalDevice stdin)
371 dflags <- getDynFlags
372 let show_prompt = verbosity dflags > 0 || is_tty
377 #if defined(mingw32_HOST_OS)
378 -- The win32 Console API mutates the first character of
379 -- type-ahead when reading from it in a non-buffered manner. Work
380 -- around this by flushing the input buffer of type-ahead characters,
381 -- but only if stdin is available.
382 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
384 Left err | isDoesNotExistError err -> return ()
385 | otherwise -> io (ioError err)
386 Right () -> return ()
388 -- enter the interactive loop
389 interactiveLoop is_tty show_prompt
391 -- just evaluate the expression we were given
396 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
399 interactiveLoop :: Bool -> Bool -> GHCi ()
400 interactiveLoop is_tty show_prompt =
401 -- Ignore ^C exceptions caught here
402 ghciHandleDyn (\e -> case e of
404 #if defined(mingw32_HOST_OS)
407 interactiveLoop is_tty show_prompt
408 _other -> return ()) $
410 ghciUnblock $ do -- unblock necessary if we recursed from the
411 -- exception handler above.
413 -- read commands from stdin
416 then runCommands readlineLoop
417 else runCommands (fileLoop stdin show_prompt is_tty)
419 runCommands (fileLoop stdin show_prompt is_tty)
423 -- NOTE: We only read .ghci files if they are owned by the current user,
424 -- and aren't world writable. Otherwise, we could be accidentally
425 -- running code planted by a malicious third party.
427 -- Furthermore, We only read ./.ghci if . is owned by the current user
428 -- and isn't writable by anyone else. I think this is sufficient: we
429 -- don't need to check .. and ../.. etc. because "." always refers to
430 -- the same directory while a process is running.
432 checkPerms :: String -> IO Bool
433 #ifdef mingw32_HOST_OS
438 Util.handle (\_ -> return False) $ do
439 st <- getFileStatus name
441 if fileOwner st /= me then do
442 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
445 let mode = fileMode st
446 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
447 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
449 putStrLn $ "*** WARNING: " ++ name ++
450 " is writable by someone else, IGNORING!"
455 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
456 fileLoop hdl show_prompt is_tty = do
457 when show_prompt $ do
460 l <- io (IO.try (hGetLine hdl))
462 Left e | isEOFError e -> return Nothing
463 | InvalidArgument <- etype -> return Nothing
464 | otherwise -> io (ioError e)
465 where etype = ioeGetErrorType e
466 -- treat InvalidArgument in the same way as EOF:
467 -- this can happen if the user closed stdin, or
468 -- perhaps did getContents which closes stdin at
471 str <- io $ consoleInputToUnicode is_tty l
474 #ifdef mingw32_HOST_OS
475 -- Convert the console input into Unicode according to the current code page.
476 -- The Windows console stores Unicode characters directly, so this is a
477 -- rather roundabout way of doing things... oh well.
478 -- See #782, #1483, #1649
479 consoleInputToUnicode :: Bool -> String -> IO String
480 consoleInputToUnicode is_tty str
482 cp <- System.Win32.getConsoleCP
483 System.Win32.stringToUnicode cp str
485 decodeStringAsUTF8 str
487 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
489 consoleInputToUnicode :: Bool -> String -> IO String
490 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
493 decodeStringAsUTF8 :: String -> IO String
494 decodeStringAsUTF8 str =
495 withCStringLen str $ \(cstr,len) ->
496 utf8DecodeString (castPtr cstr :: Ptr Word8) len
498 mkPrompt :: GHCi String
500 session <- getSession
501 (toplevs,exports) <- io (GHC.getContext session)
502 resumes <- io $ GHC.getResumeContext session
508 let ix = GHC.resumeHistoryIx r
510 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
512 let hist = GHC.resumeHistory r !! (ix-1)
513 span <- io$ GHC.getHistorySpan session hist
514 return (brackets (ppr (negate ix) <> char ':'
515 <+> ppr span) <> space)
517 dots | _:rs <- resumes, not (null rs) = text "... "
521 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
522 hsep (map (ppr . GHC.moduleName) exports)
524 deflt_prompt = dots <> context_bit <> modules_bit
526 f ('%':'s':xs) = deflt_prompt <> f xs
527 f ('%':'%':xs) = char '%' <> f xs
528 f (x:xs) = char x <> f xs
532 return (showSDoc (f (prompt st)))
536 readlineLoop :: GHCi (Maybe String)
539 saveSession -- for use by completion
541 l <- io (readline prompt `finally` setNonBlockingFD 0)
542 -- readline sometimes puts stdin into blocking mode,
543 -- so we need to put it back for the IO library
546 Nothing -> return Nothing
549 str <- io $ consoleInputToUnicode True l
553 queryQueue :: GHCi (Maybe String)
558 c:cs -> do setGHCiState st{ cmdqueue = cs }
561 runCommands :: GHCi (Maybe String) -> GHCi ()
562 runCommands getCmd = do
563 mb_cmd <- noSpace queryQueue
564 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
568 b <- ghciHandle handler (doCommand c)
569 if b then return () else runCommands getCmd
571 noSpace q = q >>= maybe (return Nothing)
572 (\c->case removeSpaces c of
574 ":{" -> multiLineCmd q
575 c -> return (Just c) )
579 setGHCiState st{ prompt = "%s| " }
580 mb_cmd <- collectCommand q ""
581 getGHCiState >>= \st->setGHCiState st{ prompt = p }
583 -- we can't use removeSpaces for the sublines here, so
584 -- multiline commands are somewhat more brittle against
585 -- fileformat errors (such as \r in dos input on unix),
586 -- we get rid of any extra spaces for the ":}" test;
587 -- we also avoid silent failure if ":}" is not found;
588 -- and since there is no (?) valid occurrence of \r (as
589 -- opposed to its String representation, "\r") inside a
590 -- ghci command, we replace any such with ' ' (argh:-(
591 collectCommand q c = q >>=
592 maybe (io (ioError collectError))
593 (\l->if removeSpaces l == ":}"
594 then return (Just $ removeSpaces c)
595 else collectCommand q (c++map normSpace l))
596 where normSpace '\r' = ' '
598 -- QUESTION: is userError the one to use here?
599 collectError = userError "unterminated multiline command :{ .. :}"
600 doCommand (':' : cmd) = specialCommand cmd
601 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
604 enqueueCommands :: [String] -> GHCi ()
605 enqueueCommands cmds = do
607 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
610 -- This version is for the GHC command-line option -e. The only difference
611 -- from runCommand is that it catches the ExitException exception and
612 -- exits, rather than printing out the exception.
613 runCommandEval :: String -> GHCi Bool
614 runCommandEval c = ghciHandle handleEval (doCommand c)
616 handleEval (ExitException code) = io (exitWith code)
617 handleEval e = do handler e
618 io (exitWith (ExitFailure 1))
620 doCommand (':' : command) = specialCommand command
622 = do r <- runStmt stmt GHC.RunToCompletion
624 False -> io (exitWith (ExitFailure 1))
625 -- failure to run the command causes exit(1) for ghc -e.
628 runStmt :: String -> SingleStep -> GHCi Bool
630 | null (filter (not.isSpace) stmt) = return False
631 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
633 = do st <- getGHCiState
634 session <- getSession
635 result <- io $ withProgName (progname st) $ withArgs (args st) $
636 GHC.runStmt session stmt step
637 afterRunStmt (const True) result
640 --afterRunStmt :: GHC.RunResult -> GHCi Bool
641 -- False <=> the statement failed to compile
642 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
643 afterRunStmt _ (GHC.RunException e) = throw e
644 afterRunStmt step_here run_result = do
645 session <- getSession
646 resumes <- io $ GHC.getResumeContext session
648 GHC.RunOk names -> do
649 show_types <- isOptionSet ShowType
650 when show_types $ printTypeOfNames session names
651 GHC.RunBreak _ names mb_info
652 | isNothing mb_info ||
653 step_here (GHC.resumeSpan $ head resumes) -> do
654 printForUser $ ptext SLIT("Stopped at") <+>
655 ppr (GHC.resumeSpan $ head resumes)
656 -- printTypeOfNames session names
657 let namesSorted = sortBy compareNames names
658 tythings <- catMaybes `liftM`
659 io (mapM (GHC.lookupName session) namesSorted)
661 printTypeAndContents session [id | AnId id <- tythings]
662 maybe (return ()) runBreakCmd mb_info
663 -- run the command set with ":set stop <cmd>"
665 enqueueCommands [stop st]
667 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
668 afterRunStmt step_here >> return ()
672 io installSignalHandlers
673 b <- isOptionSet RevertCAFs
674 io (when b revertCAFs)
676 return (case run_result of GHC.RunOk _ -> True; _ -> False)
678 runBreakCmd :: GHC.BreakInfo -> GHCi ()
679 runBreakCmd info = do
680 let mod = GHC.breakInfo_module info
681 nm = GHC.breakInfo_number info
683 case [ loc | (_,loc) <- breaks st,
684 breakModule loc == mod, breakTick loc == nm ] of
686 loc:_ | null cmd -> return ()
687 | otherwise -> do enqueueCommands [cmd]; return ()
688 where cmd = onBreakCmd loc
690 printTypeOfNames :: Session -> [Name] -> GHCi ()
691 printTypeOfNames session names
692 = mapM_ (printTypeOfName session) $ sortBy compareNames names
694 compareNames :: Name -> Name -> Ordering
695 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
696 where compareWith n = (getOccString n, getSrcSpan n)
698 printTypeOfName :: Session -> Name -> GHCi ()
699 printTypeOfName session n
700 = do maybe_tything <- io (GHC.lookupName session n)
701 case maybe_tything of
703 Just thing -> printTyThing thing
705 printTypeAndContents :: Session -> [Id] -> GHCi ()
706 printTypeAndContents session ids = do
707 dflags <- getDynFlags
708 let pefas = dopt Opt_PrintExplicitForalls dflags
709 pcontents = dopt Opt_PrintBindContents dflags
713 terms <- mapM (io . GHC.obtainTermB session depthBound False) ids
714 docs_terms <- mapM (io . showTerm session) terms
715 printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
716 (map (pprTyThing pefas . AnId) ids)
718 else printForUser $ vcat $ map (pprTyThing pefas . AnId) ids
721 specialCommand :: String -> GHCi Bool
722 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
723 specialCommand str = do
724 let (cmd,rest) = break isSpace str
725 maybe_cmd <- io (lookupCommand cmd)
727 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
728 ++ shortHelpText) >> return False)
729 Just (_,f,_,_) -> f (dropWhile isSpace rest)
731 lookupCommand :: String -> IO (Maybe Command)
732 lookupCommand str = do
733 macros <- readIORef macros_ref
734 let cmds = builtin_commands ++ macros
735 -- look for exact match first, then the first prefix match
736 case [ c | c <- cmds, str == cmdName c ] of
737 c:_ -> return (Just c)
738 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
740 c:_ -> return (Just c)
743 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
744 getCurrentBreakSpan = do
745 session <- getSession
746 resumes <- io $ GHC.getResumeContext session
750 let ix = GHC.resumeHistoryIx r
752 then return (Just (GHC.resumeSpan r))
754 let hist = GHC.resumeHistory r !! (ix-1)
755 span <- io $ GHC.getHistorySpan session hist
758 getCurrentBreakModule :: GHCi (Maybe Module)
759 getCurrentBreakModule = do
760 session <- getSession
761 resumes <- io $ GHC.getResumeContext session
765 let ix = GHC.resumeHistoryIx r
767 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
769 let hist = GHC.resumeHistory r !! (ix-1)
770 return $ Just $ GHC.getHistoryModule hist
772 -----------------------------------------------------------------------------
775 noArgs :: GHCi () -> String -> GHCi ()
777 noArgs _ _ = io $ putStrLn "This command takes no arguments"
779 help :: String -> GHCi ()
780 help _ = io (putStr helpText)
782 info :: String -> GHCi ()
783 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
784 info s = do { let names = words s
785 ; session <- getSession
786 ; dflags <- getDynFlags
787 ; let pefas = dopt Opt_PrintExplicitForalls dflags
788 ; mapM_ (infoThing pefas session) names }
790 infoThing pefas session str = io $ do
791 names <- GHC.parseName session str
792 mb_stuffs <- mapM (GHC.getInfo session) names
793 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
794 unqual <- GHC.getPrintUnqual session
795 putStrLn (showSDocForUser unqual $
796 vcat (intersperse (text "") $
797 map (pprInfo pefas) filtered))
799 -- Filter out names whose parent is also there Good
800 -- example is '[]', which is both a type and data
801 -- constructor in the same type
802 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
803 filterOutChildren get_thing xs
804 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
806 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
808 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
809 pprInfo pefas (thing, fixity, insts)
810 = pprTyThingInContextLoc pefas thing
811 $$ show_fixity fixity
812 $$ vcat (map GHC.pprInstance insts)
815 | fix == GHC.defaultFixity = empty
816 | otherwise = ppr fix <+> ppr (GHC.getName thing)
818 runMain :: String -> GHCi ()
820 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
821 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
823 addModule :: [FilePath] -> GHCi ()
825 io (revertCAFs) -- always revert CAFs on load/add.
826 files <- mapM expandPath files
827 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
828 session <- getSession
829 io (mapM_ (GHC.addTarget session) targets)
830 ok <- io (GHC.load session LoadAllTargets)
831 afterLoad ok session Nothing
833 changeDirectory :: String -> GHCi ()
834 changeDirectory dir = do
835 session <- getSession
836 graph <- io (GHC.getModuleGraph session)
837 when (not (null graph)) $
838 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
839 io (GHC.setTargets session [])
840 io (GHC.load session LoadAllTargets)
841 setContextAfterLoad session []
842 io (GHC.workingDirectoryChanged session)
843 dir <- expandPath dir
844 io (setCurrentDirectory dir)
846 editFile :: String -> GHCi ()
848 do file <- if null str then chooseEditFile else return str
852 $ throwDyn (CmdLineError "editor not set, use :set editor")
853 io $ system (cmd ++ ' ':file)
856 -- The user didn't specify a file so we pick one for them.
857 -- Our strategy is to pick the first module that failed to load,
858 -- or otherwise the first target.
860 -- XXX: Can we figure out what happened if the depndecy analysis fails
861 -- (e.g., because the porgrammeer mistyped the name of a module)?
862 -- XXX: Can we figure out the location of an error to pass to the editor?
863 -- XXX: if we could figure out the list of errors that occured during the
864 -- last load/reaload, then we could start the editor focused on the first
866 chooseEditFile :: GHCi String
868 do session <- getSession
869 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
871 graph <- io (GHC.getModuleGraph session)
872 failed_graph <- filterM hasFailed graph
873 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
875 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
878 case pick (order failed_graph) of
879 Just file -> return file
881 do targets <- io (GHC.getTargets session)
882 case msum (map fromTarget targets) of
883 Just file -> return file
884 Nothing -> throwDyn (CmdLineError "No files to edit.")
886 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
887 fromTarget _ = Nothing -- when would we get a module target?
889 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
890 defineMacro overwrite s = do
891 let (macro_name, definition) = break isSpace s
892 macros <- io (readIORef macros_ref)
893 let defined = map cmdName macros
896 then io $ putStrLn "no macros defined"
897 else io $ putStr ("the following macros are defined:\n" ++
900 if (not overwrite && macro_name `elem` defined)
901 then throwDyn (CmdLineError
902 ("macro '" ++ macro_name ++ "' is already defined"))
905 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
907 -- give the expression a type signature, so we can be sure we're getting
908 -- something of the right type.
909 let new_expr = '(' : definition ++ ") :: String -> IO String"
911 -- compile the expression
913 maybe_hv <- io (GHC.compileExpr cms new_expr)
916 Just hv -> io (writeIORef macros_ref --
917 (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
919 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
921 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
922 enqueueCommands (lines str)
925 undefineMacro :: String -> GHCi ()
926 undefineMacro str = mapM_ undef (words str)
927 where undef macro_name = do
928 cmds <- io (readIORef macros_ref)
929 if (macro_name `notElem` map cmdName cmds)
930 then throwDyn (CmdLineError
931 ("macro '" ++ macro_name ++ "' is not defined"))
933 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
935 cmdCmd :: String -> GHCi ()
937 let expr = '(' : str ++ ") :: IO String"
938 session <- getSession
939 maybe_hv <- io (GHC.compileExpr session expr)
943 cmds <- io $ (unsafeCoerce# hv :: IO String)
944 enqueueCommands (lines cmds)
947 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
948 loadModule fs = timeIt (loadModule' fs)
950 loadModule_ :: [FilePath] -> GHCi ()
951 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
953 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
954 loadModule' files = do
955 session <- getSession
958 discardActiveBreakPoints
959 io (GHC.setTargets session [])
960 io (GHC.load session LoadAllTargets)
963 let (filenames, phases) = unzip files
964 exp_filenames <- mapM expandPath filenames
965 let files' = zip exp_filenames phases
966 targets <- io (mapM (uncurry GHC.guessTarget) files')
968 -- NOTE: we used to do the dependency anal first, so that if it
969 -- fails we didn't throw away the current set of modules. This would
970 -- require some re-working of the GHC interface, so we'll leave it
971 -- as a ToDo for now.
973 io (GHC.setTargets session targets)
974 doLoad session False LoadAllTargets
976 checkModule :: String -> GHCi ()
978 let modl = GHC.mkModuleName m
979 session <- getSession
980 result <- io (GHC.checkModule session modl False)
982 Nothing -> io $ putStrLn "Nothing"
983 Just r -> io $ putStrLn (showSDoc (
984 case GHC.checkedModuleInfo r of
985 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
987 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
989 (text "global names: " <+> ppr global) $$
990 (text "local names: " <+> ppr local)
992 afterLoad (successIf (isJust result)) session Nothing
994 reloadModule :: String -> GHCi ()
996 session <- getSession
997 doLoad session True $ if null m then LoadAllTargets
998 else LoadUpTo (GHC.mkModuleName m)
1001 doLoad :: Session -> Bool -> LoadHowMuch -> GHCi SuccessFlag
1002 doLoad session retain_context howmuch = do
1003 -- turn off breakpoints before we load: we can't turn them off later, because
1004 -- the ModBreaks will have gone away.
1005 discardActiveBreakPoints
1006 context <- io $ GHC.getContext session
1007 ok <- io (GHC.load session howmuch)
1008 afterLoad ok session (if retain_context then Just context else Nothing)
1011 afterLoad :: SuccessFlag -> Session -> Maybe ([Module],[Module]) -> GHCi ()
1012 afterLoad ok session maybe_context = do
1013 io (revertCAFs) -- always revert CAFs on load.
1015 loaded_mods <- getLoadedModules session
1017 -- try to retain the old module context for :reload. This might
1018 -- not be possible, for example if some modules have gone away, so
1019 -- we attempt to set the same context, backing off to the default
1020 -- context if that fails.
1021 case maybe_context of
1022 Nothing -> setContextAfterLoad session loaded_mods
1024 r <- io $ Exception.try (GHC.setContext session as bs)
1026 Left _err -> setContextAfterLoad session loaded_mods
1027 Right _ -> return ()
1029 modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
1031 setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi ()
1032 setContextAfterLoad session [] = do
1033 prel_mod <- getPrelude
1034 io (GHC.setContext session [] [prel_mod])
1035 setContextAfterLoad session ms = do
1036 -- load a target if one is available, otherwise load the topmost module.
1037 targets <- io (GHC.getTargets session)
1038 case [ m | Just m <- map (findTarget ms) targets ] of
1040 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1041 load_this (last graph')
1046 = case filter (`matches` t) ms of
1050 summary `matches` Target (TargetModule m) _
1051 = GHC.ms_mod_name summary == m
1052 summary `matches` Target (TargetFile f _) _
1053 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1057 load_this summary | m <- GHC.ms_mod summary = do
1058 b <- io (GHC.moduleIsInterpreted session m)
1059 if b then io (GHC.setContext session [m] [])
1061 prel_mod <- getPrelude
1062 io (GHC.setContext session [] [prel_mod,m])
1065 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1066 modulesLoadedMsg ok mods = do
1067 dflags <- getDynFlags
1068 when (verbosity dflags > 0) $ do
1070 | null mods = text "none."
1071 | otherwise = hsep (
1072 punctuate comma (map ppr mods)) <> text "."
1075 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1077 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1080 typeOfExpr :: String -> GHCi ()
1082 = do cms <- getSession
1083 maybe_ty <- io (GHC.exprType cms str)
1085 Nothing -> return ()
1086 Just ty -> do dflags <- getDynFlags
1087 let pefas = dopt Opt_PrintExplicitForalls dflags
1088 printForUser $ text str <+> dcolon
1089 <+> pprTypeForUser pefas ty
1091 kindOfType :: String -> GHCi ()
1093 = do cms <- getSession
1094 maybe_ty <- io (GHC.typeKind cms str)
1096 Nothing -> return ()
1097 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1099 quit :: String -> GHCi Bool
1100 quit _ = return True
1102 shellEscape :: String -> GHCi Bool
1103 shellEscape str = io (system str >> return False)
1105 -----------------------------------------------------------------------------
1106 -- Browsing a module's contents
1108 browseCmd :: Bool -> String -> GHCi ()
1111 ['*':s] | looksLikeModuleName s -> do
1112 m <- wantInterpretedModule s
1113 browseModule bang m False
1114 [s] | looksLikeModuleName s -> do
1116 browseModule bang m True
1119 (as,bs) <- io $ GHC.getContext s
1120 -- Guess which module the user wants to browse. Pick
1121 -- modules that are interpreted first. The most
1122 -- recently-added module occurs last, it seems.
1124 (as@(_:_), _) -> browseModule bang (last as) True
1125 ([], bs@(_:_)) -> browseModule bang (last bs) True
1126 ([], []) -> throwDyn (CmdLineError ":browse: no current module")
1127 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1129 -- without bang, show items in context of their parents and omit children
1130 -- with bang, show class methods and data constructors separately, and
1131 -- indicate import modules, to aid qualifying unqualified names
1132 -- with sorted, sort items alphabetically
1133 browseModule :: Bool -> Module -> Bool -> GHCi ()
1134 browseModule bang modl exports_only = do
1136 -- Temporarily set the context to the module we're interested in,
1137 -- just so we can get an appropriate PrintUnqualified
1138 (as,bs) <- io (GHC.getContext s)
1139 prel_mod <- getPrelude
1140 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1141 else GHC.setContext s [modl] [])
1142 unqual <- io (GHC.getPrintUnqual s)
1143 io (GHC.setContext s as bs)
1145 mb_mod_info <- io $ GHC.getModuleInfo s modl
1147 Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1148 GHC.moduleNameString (GHC.moduleName modl)))
1150 dflags <- getDynFlags
1152 | exports_only = GHC.modInfoExports mod_info
1153 | otherwise = GHC.modInfoTopLevelScope mod_info
1156 -- sort alphabetically name, but putting
1157 -- locally-defined identifiers first.
1158 -- We would like to improve this; see #1799.
1159 sorted_names = loc_sort local ++ occ_sort external
1161 (local,external) = partition ((==modl) . nameModule) names
1162 occ_sort = sortBy (compare `on` nameOccName)
1163 -- try to sort by src location. If the first name in
1164 -- our list has a good source location, then they all should.
1166 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1167 = sortBy (compare `on` nameSrcSpan) names
1171 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1172 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1174 rdr_env <- io $ GHC.getGRE s
1176 let pefas = dopt Opt_PrintExplicitForalls dflags
1177 things | bang = catMaybes mb_things
1178 | otherwise = filtered_things
1179 pretty | bang = pprTyThing
1180 | otherwise = pprTyThingInContext
1182 labels [] = text "-- not currently imported"
1183 labels l = text $ intercalate "\n" $ map qualifier l
1184 qualifier = maybe "-- defined locally"
1185 (("-- imported from "++) . intercalate ", "
1186 . map GHC.moduleNameString)
1187 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1188 modNames = map (importInfo . GHC.getName) things
1190 -- annotate groups of imports with their import modules
1191 -- the default ordering is somewhat arbitrary, so we group
1192 -- by header and sort groups; the names themselves should
1193 -- really come in order of source appearance.. (trac #1799)
1194 annotate mts = concatMap (\(m,ts)->labels m:ts)
1195 $ sortBy cmpQualifiers $ group mts
1196 where cmpQualifiers =
1197 compare `on` (map (fmap (map moduleNameFS)) . fst)
1199 group mts@((m,_):_) = (m,map snd g) : group ng
1200 where (g,ng) = partition ((==m).fst) mts
1202 let prettyThings = map (pretty pefas) things
1203 prettyThings' | bang = annotate $ zip modNames prettyThings
1204 | otherwise = prettyThings
1205 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1206 -- ToDo: modInfoInstances currently throws an exception for
1207 -- package modules. When it works, we can do this:
1208 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1210 -----------------------------------------------------------------------------
1211 -- Setting the module context
1213 setContext :: String -> GHCi ()
1215 | all sensible mods = fn mods
1216 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1218 (fn, mods) = case str of
1219 '+':stuff -> (addToContext, words stuff)
1220 '-':stuff -> (removeFromContext, words stuff)
1221 stuff -> (newContext, words stuff)
1223 sensible ('*':m) = looksLikeModuleName m
1224 sensible m = looksLikeModuleName m
1226 separate :: Session -> [String] -> [Module] -> [Module]
1227 -> GHCi ([Module],[Module])
1228 separate _ [] as bs = return (as,bs)
1229 separate session (('*':str):ms) as bs = do
1230 m <- wantInterpretedModule str
1231 separate session ms (m:as) bs
1232 separate session (str:ms) as bs = do
1233 m <- lookupModule str
1234 separate session ms as (m:bs)
1236 newContext :: [String] -> GHCi ()
1237 newContext strs = do
1239 (as,bs) <- separate s strs [] []
1240 prel_mod <- getPrelude
1241 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1242 io $ GHC.setContext s as bs'
1245 addToContext :: [String] -> GHCi ()
1246 addToContext strs = do
1248 (as,bs) <- io $ GHC.getContext s
1250 (new_as,new_bs) <- separate s strs [] []
1252 let as_to_add = new_as \\ (as ++ bs)
1253 bs_to_add = new_bs \\ (as ++ bs)
1255 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1258 removeFromContext :: [String] -> GHCi ()
1259 removeFromContext strs = do
1261 (as,bs) <- io $ GHC.getContext s
1263 (as_to_remove,bs_to_remove) <- separate s strs [] []
1265 let as' = as \\ (as_to_remove ++ bs_to_remove)
1266 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1268 io $ GHC.setContext s as' bs'
1270 ----------------------------------------------------------------------------
1273 -- set options in the interpreter. Syntax is exactly the same as the
1274 -- ghc command line, except that certain options aren't available (-C,
1277 -- This is pretty fragile: most options won't work as expected. ToDo:
1278 -- figure out which ones & disallow them.
1280 setCmd :: String -> GHCi ()
1282 = do st <- getGHCiState
1283 let opts = options st
1284 io $ putStrLn (showSDoc (
1285 text "options currently set: " <>
1288 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1290 dflags <- getDynFlags
1291 io $ putStrLn (showSDoc (
1292 vcat (text "GHCi-specific dynamic flag settings:"
1293 :map (flagSetting dflags) ghciFlags)
1295 io $ putStrLn (showSDoc (
1296 vcat (text "other dynamic, non-language, flag settings:"
1297 :map (flagSetting dflags) nonLanguageDynFlags)
1299 where flagSetting dflags (str,f)
1300 | dopt f dflags = text " " <> text "-f" <> text str
1301 | otherwise = text " " <> text "-fno-" <> text str
1302 (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
1304 nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1306 flags = [Opt_PrintExplicitForalls
1307 ,Opt_PrintBindResult
1308 ,Opt_BreakOnException
1310 ,Opt_PrintEvldWithShow
1313 = case toArgs str of
1314 ("args":args) -> setArgs args
1315 ("prog":prog) -> setProg prog
1316 ("prompt":_) -> setPrompt (after 6)
1317 ("editor":_) -> setEditor (after 6)
1318 ("stop":_) -> setStop (after 4)
1319 wds -> setOptions wds
1320 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1322 setArgs, setProg, setOptions :: [String] -> GHCi ()
1323 setEditor, setStop, setPrompt :: String -> GHCi ()
1327 setGHCiState st{ args = args }
1331 setGHCiState st{ progname = prog }
1333 io (hPutStrLn stderr "syntax: :set prog <progname>")
1337 setGHCiState st{ editor = cmd }
1339 setStop str@(c:_) | isDigit c
1340 = do let (nm_str,rest) = break (not.isDigit) str
1343 let old_breaks = breaks st
1344 if all ((/= nm) . fst) old_breaks
1345 then printForUser (text "Breakpoint" <+> ppr nm <+>
1346 text "does not exist")
1348 let new_breaks = map fn old_breaks
1349 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1350 | otherwise = (i,loc)
1351 setGHCiState st{ breaks = new_breaks }
1354 setGHCiState st{ stop = cmd }
1356 setPrompt value = do
1359 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1360 else setGHCiState st{ prompt = remQuotes value }
1362 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1366 do -- first, deal with the GHCi opts (+s, +t, etc.)
1367 let (plus_opts, minus_opts) = partitionWith isPlus wds
1368 mapM_ setOpt plus_opts
1369 -- then, dynamic flags
1370 newDynFlags minus_opts
1372 newDynFlags :: [String] -> GHCi ()
1373 newDynFlags minus_opts = do
1374 dflags <- getDynFlags
1375 let pkg_flags = packageFlags dflags
1376 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1378 if (not (null leftovers))
1379 then throwDyn (CmdLineError ("unrecognised flags: " ++
1383 new_pkgs <- setDynFlags dflags'
1385 -- if the package flags changed, we should reset the context
1386 -- and link the new packages.
1387 dflags <- getDynFlags
1388 when (packageFlags dflags /= pkg_flags) $ do
1389 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1390 session <- getSession
1391 io (GHC.setTargets session [])
1392 io (GHC.load session LoadAllTargets)
1393 io (linkPackages dflags new_pkgs)
1394 setContextAfterLoad session []
1398 unsetOptions :: String -> GHCi ()
1400 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1401 let opts = words str
1402 (minus_opts, rest1) = partition isMinus opts
1403 (plus_opts, rest2) = partitionWith isPlus rest1
1405 if (not (null rest2))
1406 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1409 mapM_ unsetOpt plus_opts
1411 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1412 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1414 no_flags <- mapM no_flag minus_opts
1415 newDynFlags no_flags
1417 isMinus :: String -> Bool
1418 isMinus ('-':_) = True
1421 isPlus :: String -> Either String String
1422 isPlus ('+':opt) = Left opt
1423 isPlus other = Right other
1425 setOpt, unsetOpt :: String -> GHCi ()
1428 = case strToGHCiOpt str of
1429 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1430 Just o -> setOption o
1433 = case strToGHCiOpt str of
1434 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1435 Just o -> unsetOption o
1437 strToGHCiOpt :: String -> (Maybe GHCiOption)
1438 strToGHCiOpt "s" = Just ShowTiming
1439 strToGHCiOpt "t" = Just ShowType
1440 strToGHCiOpt "r" = Just RevertCAFs
1441 strToGHCiOpt _ = Nothing
1443 optToStr :: GHCiOption -> String
1444 optToStr ShowTiming = "s"
1445 optToStr ShowType = "t"
1446 optToStr RevertCAFs = "r"
1448 -- ---------------------------------------------------------------------------
1451 showCmd :: String -> GHCi ()
1455 ["args"] -> io $ putStrLn (show (args st))
1456 ["prog"] -> io $ putStrLn (show (progname st))
1457 ["prompt"] -> io $ putStrLn (show (prompt st))
1458 ["editor"] -> io $ putStrLn (show (editor st))
1459 ["stop"] -> io $ putStrLn (show (stop st))
1460 ["modules" ] -> showModules
1461 ["bindings"] -> showBindings
1462 ["linker"] -> io showLinkerState
1463 ["breaks"] -> showBkptTable
1464 ["context"] -> showContext
1465 ["packages"] -> showPackages
1466 ["languages"] -> showLanguages
1467 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1469 showModules :: GHCi ()
1471 session <- getSession
1472 loaded_mods <- getLoadedModules session
1473 -- we want *loaded* modules only, see #1734
1474 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1475 mapM_ show_one loaded_mods
1477 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1478 getLoadedModules session = do
1479 graph <- io (GHC.getModuleGraph session)
1480 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1482 showBindings :: GHCi ()
1485 bindings <- io (GHC.getBindings s)
1486 printTypeAndContents s [ id | AnId id <- sortBy compareTyThings bindings]
1488 compareTyThings :: TyThing -> TyThing -> Ordering
1489 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1491 printTyThing :: TyThing -> GHCi ()
1492 printTyThing tyth = do dflags <- getDynFlags
1493 let pefas = dopt Opt_PrintExplicitForalls dflags
1494 printForUser (pprTyThing pefas tyth)
1496 showBkptTable :: GHCi ()
1499 printForUser $ prettyLocations (breaks st)
1501 showContext :: GHCi ()
1503 session <- getSession
1504 resumes <- io $ GHC.getResumeContext session
1505 printForUser $ vcat (map pp_resume (reverse resumes))
1508 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1509 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1511 showPackages :: GHCi ()
1513 pkg_flags <- fmap packageFlags getDynFlags
1514 io $ putStrLn $ showSDoc $ vcat $
1515 text ("active package flags:"++if null pkg_flags then " none" else "")
1516 : map showFlag pkg_flags
1517 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1518 io $ putStrLn $ showSDoc $ vcat $
1519 text "packages currently loaded:"
1520 : map (nest 2 . text . packageIdString) pkg_ids
1521 where showFlag (ExposePackage p) = text $ " -package " ++ p
1522 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1523 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1525 showLanguages :: GHCi ()
1527 dflags <- getDynFlags
1528 io $ putStrLn $ showSDoc $ vcat $
1529 text "active language flags:" :
1530 [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1532 -- -----------------------------------------------------------------------------
1535 completeNone :: String -> IO [String]
1536 completeNone _w = return []
1538 completeMacro, completeIdentifier, completeModule,
1539 completeHomeModule, completeSetOptions, completeFilename,
1540 completeHomeModuleOrFile
1541 :: String -> IO [String]
1544 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1545 completeWord w start end = do
1546 line <- Readline.getLineBuffer
1547 let line_words = words (dropWhile isSpace line)
1549 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1551 | ((':':c) : _) <- line_words -> do
1552 maybe_cmd <- lookupCommand c
1553 let (n,w') = selectWord (words' 0 line)
1555 Nothing -> return Nothing
1556 Just (_,_,False,complete) -> wrapCompleter complete w
1557 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1558 return (map (drop n) rets)
1559 in wrapCompleter complete' w'
1560 | ("import" : _) <- line_words ->
1561 wrapCompleter completeModule w
1563 --printf "complete %s, start = %d, end = %d\n" w start end
1564 wrapCompleter completeIdentifier w
1565 where words' _ [] = []
1566 words' n str = let (w,r) = break isSpace str
1567 (s,r') = span isSpace r
1568 in (n,w):words' (n+length w+length s) r'
1569 -- In a Haskell expression we want to parse 'a-b' as three words
1570 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1571 -- only be a single word.
1572 selectWord [] = (0,w)
1573 selectWord ((offset,x):xs)
1574 | offset+length x >= start = (start-offset,take (end-offset) x)
1575 | otherwise = selectWord xs
1577 completeCmd :: String -> IO [String]
1579 cmds <- readIORef macros_ref
1580 return (filter (w `isPrefixOf`) (map (':':)
1581 (map cmdName (builtin_commands ++ cmds))))
1583 completeMacro w = do
1584 cmds <- readIORef macros_ref
1585 return (filter (w `isPrefixOf`) (map cmdName cmds))
1587 completeIdentifier w = do
1589 rdrs <- GHC.getRdrNamesInScope s
1590 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1592 completeModule w = do
1594 dflags <- GHC.getSessionDynFlags s
1595 let pkg_mods = allExposedModules dflags
1596 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1598 completeHomeModule w = do
1600 g <- GHC.getModuleGraph s
1601 let home_mods = map GHC.ms_mod_name g
1602 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1604 completeSetOptions w = do
1605 return (filter (w `isPrefixOf`) options)
1606 where options = "args":"prog":allFlags
1608 completeFilename = Readline.filenameCompletionFunction
1610 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1612 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1613 unionComplete f1 f2 w = do
1618 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1619 wrapCompleter fun w = do
1622 [] -> return Nothing
1623 [x] -> return (Just (x,[]))
1624 xs -> case getCommonPrefix xs of
1625 "" -> return (Just ("",xs))
1626 pref -> return (Just (pref,xs))
1628 getCommonPrefix :: [String] -> String
1629 getCommonPrefix [] = ""
1630 getCommonPrefix (s:ss) = foldl common s ss
1631 where common _s "" = ""
1633 common (c:cs) (d:ds)
1634 | c == d = c : common cs ds
1637 allExposedModules :: DynFlags -> [ModuleName]
1638 allExposedModules dflags
1639 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1641 pkg_db = pkgIdMap (pkgState dflags)
1643 completeMacro = completeNone
1644 completeIdentifier = completeNone
1645 completeModule = completeNone
1646 completeHomeModule = completeNone
1647 completeSetOptions = completeNone
1648 completeFilename = completeNone
1649 completeHomeModuleOrFile=completeNone
1652 -- ---------------------------------------------------------------------------
1653 -- User code exception handling
1655 -- This is the exception handler for exceptions generated by the
1656 -- user's code and exceptions coming from children sessions;
1657 -- it normally just prints out the exception. The
1658 -- handler must be recursive, in case showing the exception causes
1659 -- more exceptions to be raised.
1661 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1662 -- raising another exception. We therefore don't put the recursive
1663 -- handler arond the flushing operation, so if stderr is closed
1664 -- GHCi will just die gracefully rather than going into an infinite loop.
1665 handler :: Exception -> GHCi Bool
1667 handler exception = do
1669 io installSignalHandlers
1670 ghciHandle handler (showException exception >> return False)
1672 showException :: Exception -> GHCi ()
1673 showException (DynException dyn) =
1674 case fromDynamic dyn of
1675 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1676 Just Interrupted -> io (putStrLn "Interrupted.")
1677 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1678 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1679 Just other_ghc_ex -> io (print other_ghc_ex)
1681 showException other_exception
1682 = io (putStrLn ("*** Exception: " ++ show other_exception))
1684 -----------------------------------------------------------------------------
1685 -- recursive exception handlers
1687 -- Don't forget to unblock async exceptions in the handler, or if we're
1688 -- in an exception loop (eg. let a = error a in a) the ^C exception
1689 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1691 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1692 ghciHandle h (GHCi m) = GHCi $ \s ->
1693 Exception.catch (m s)
1694 (\e -> unGHCi (ghciUnblock (h e)) s)
1696 ghciUnblock :: GHCi a -> GHCi a
1697 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1700 -- ----------------------------------------------------------------------------
1703 expandPath :: String -> GHCi String
1705 case dropWhile isSpace path of
1707 tilde <- io getHomeDirectory -- will fail if HOME not defined
1708 return (tilde ++ '/':d)
1712 wantInterpretedModule :: String -> GHCi Module
1713 wantInterpretedModule str = do
1714 session <- getSession
1715 modl <- lookupModule str
1716 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1717 when (not is_interpreted) $
1718 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1721 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1722 -> (Name -> GHCi ())
1724 wantNameFromInterpretedModule noCanDo str and_then = do
1725 session <- getSession
1726 names <- io $ GHC.parseName session str
1730 let modl = GHC.nameModule n
1731 if not (GHC.isExternalName n)
1732 then noCanDo n $ ppr n <>
1733 text " is not defined in an interpreted module"
1735 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1736 if not is_interpreted
1737 then noCanDo n $ text "module " <> ppr modl <>
1738 text " is not interpreted"
1741 -- -----------------------------------------------------------------------------
1742 -- commands for debugger
1744 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1745 sprintCmd = pprintCommand False False
1746 printCmd = pprintCommand True False
1747 forceCmd = pprintCommand False True
1749 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1750 pprintCommand bind force str = do
1751 session <- getSession
1752 io $ pprintClosureCommand session bind force str
1754 stepCmd :: String -> GHCi ()
1755 stepCmd [] = doContinue (const True) GHC.SingleStep
1756 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1758 stepLocalCmd :: String -> GHCi ()
1759 stepLocalCmd [] = do
1760 mb_span <- getCurrentBreakSpan
1762 Nothing -> stepCmd []
1764 Just mod <- getCurrentBreakModule
1765 current_toplevel_decl <- enclosingTickSpan mod loc
1766 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1768 stepLocalCmd expression = stepCmd expression
1770 stepModuleCmd :: String -> GHCi ()
1771 stepModuleCmd [] = do
1772 mb_span <- getCurrentBreakSpan
1774 Nothing -> stepCmd []
1776 Just span <- getCurrentBreakSpan
1777 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1778 doContinue f GHC.SingleStep
1780 stepModuleCmd expression = stepCmd expression
1782 -- | Returns the span of the largest tick containing the srcspan given
1783 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1784 enclosingTickSpan mod src = do
1785 ticks <- getTickArray mod
1786 let line = srcSpanStartLine src
1787 ASSERT (inRange (bounds ticks) line) do
1788 let enclosing_spans = [ span | (_,span) <- ticks ! line
1789 , srcSpanEnd span >= srcSpanEnd src]
1790 return . head . sortBy leftmost_largest $ enclosing_spans
1792 traceCmd :: String -> GHCi ()
1793 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1794 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1796 continueCmd :: String -> GHCi ()
1797 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1799 -- doContinue :: SingleStep -> GHCi ()
1800 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1801 doContinue pred step = do
1802 session <- getSession
1803 runResult <- io $ GHC.resume session step
1804 afterRunStmt pred runResult
1807 abandonCmd :: String -> GHCi ()
1808 abandonCmd = noArgs $ do
1810 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1811 when (not b) $ io $ putStrLn "There is no computation running."
1814 deleteCmd :: String -> GHCi ()
1815 deleteCmd argLine = do
1816 deleteSwitch $ words argLine
1818 deleteSwitch :: [String] -> GHCi ()
1820 io $ putStrLn "The delete command requires at least one argument."
1821 -- delete all break points
1822 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1823 deleteSwitch idents = do
1824 mapM_ deleteOneBreak idents
1826 deleteOneBreak :: String -> GHCi ()
1828 | all isDigit str = deleteBreak (read str)
1829 | otherwise = return ()
1831 historyCmd :: String -> GHCi ()
1833 | null arg = history 20
1834 | all isDigit arg = history (read arg)
1835 | otherwise = io $ putStrLn "Syntax: :history [num]"
1839 resumes <- io $ GHC.getResumeContext s
1841 [] -> io $ putStrLn "Not stopped at a breakpoint"
1843 let hist = GHC.resumeHistory r
1844 (took,rest) = splitAt num hist
1845 spans <- mapM (io . GHC.getHistorySpan s) took
1846 let nums = map (printf "-%-3d:") [(1::Int)..]
1847 let names = map GHC.historyEnclosingDecl took
1848 printForUser (vcat(zipWith3
1849 (\x y z -> x <+> y <+> z)
1851 (map (bold . ppr) names)
1852 (map (parens . ppr) spans)))
1853 io $ putStrLn $ if null rest then "<end of history>" else "..."
1855 bold :: SDoc -> SDoc
1856 bold c | do_bold = text start_bold <> c <> text end_bold
1859 backCmd :: String -> GHCi ()
1860 backCmd = noArgs $ do
1862 (names, _, span) <- io $ GHC.back s
1863 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1864 printTypeOfNames s names
1865 -- run the command set with ":set stop <cmd>"
1867 enqueueCommands [stop st]
1869 forwardCmd :: String -> GHCi ()
1870 forwardCmd = noArgs $ do
1872 (names, ix, span) <- io $ GHC.forward s
1873 printForUser $ (if (ix == 0)
1874 then ptext SLIT("Stopped at")
1875 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1876 printTypeOfNames s names
1877 -- run the command set with ":set stop <cmd>"
1879 enqueueCommands [stop st]
1881 -- handle the "break" command
1882 breakCmd :: String -> GHCi ()
1883 breakCmd argLine = do
1884 session <- getSession
1885 breakSwitch session $ words argLine
1887 breakSwitch :: Session -> [String] -> GHCi ()
1888 breakSwitch _session [] = do
1889 io $ putStrLn "The break command requires at least one argument."
1890 breakSwitch session (arg1:rest)
1891 | looksLikeModuleName arg1 = do
1892 mod <- wantInterpretedModule arg1
1893 breakByModule mod rest
1894 | all isDigit arg1 = do
1895 (toplevel, _) <- io $ GHC.getContext session
1897 (mod : _) -> breakByModuleLine mod (read arg1) rest
1899 io $ putStrLn "Cannot find default module for breakpoint."
1900 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1901 | otherwise = do -- try parsing it as an identifier
1902 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1903 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1904 if GHC.isGoodSrcLoc loc
1905 then findBreakAndSet (GHC.nameModule name) $
1906 findBreakByCoord (Just (GHC.srcLocFile loc))
1907 (GHC.srcLocLine loc,
1909 else noCanDo name $ text "can't find its location: " <> ppr loc
1911 noCanDo n why = printForUser $
1912 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1914 breakByModule :: Module -> [String] -> GHCi ()
1915 breakByModule mod (arg1:rest)
1916 | all isDigit arg1 = do -- looks like a line number
1917 breakByModuleLine mod (read arg1) rest
1921 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1922 breakByModuleLine mod line args
1923 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1924 | [col] <- args, all isDigit col =
1925 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1926 | otherwise = breakSyntax
1929 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1931 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1932 findBreakAndSet mod lookupTickTree = do
1933 tickArray <- getTickArray mod
1934 (breakArray, _) <- getModBreak mod
1935 case lookupTickTree tickArray of
1936 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1937 Just (tick, span) -> do
1938 success <- io $ setBreakFlag True breakArray tick
1942 recordBreak $ BreakLocation
1949 text "Breakpoint " <> ppr nm <>
1951 then text " was already set at " <> ppr span
1952 else text " activated at " <> ppr span
1954 printForUser $ text "Breakpoint could not be activated at"
1957 -- When a line number is specified, the current policy for choosing
1958 -- the best breakpoint is this:
1959 -- - the leftmost complete subexpression on the specified line, or
1960 -- - the leftmost subexpression starting on the specified line, or
1961 -- - the rightmost subexpression enclosing the specified line
1963 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1964 findBreakByLine line arr
1965 | not (inRange (bounds arr) line) = Nothing
1967 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1968 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1969 listToMaybe (sortBy (rightmost `on` snd) ticks)
1973 starts_here = [ tick | tick@(_,span) <- ticks,
1974 GHC.srcSpanStartLine span == line ]
1976 (complete,incomplete) = partition ends_here starts_here
1977 where ends_here (_,span) = GHC.srcSpanEndLine span == line
1979 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1980 -> Maybe (BreakIndex,SrcSpan)
1981 findBreakByCoord mb_file (line, col) arr
1982 | not (inRange (bounds arr) line) = Nothing
1984 listToMaybe (sortBy (rightmost `on` snd) contains ++
1985 sortBy (leftmost_smallest `on` snd) after_here)
1989 -- the ticks that span this coordinate
1990 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
1991 is_correct_file span ]
1993 is_correct_file span
1994 | Just f <- mb_file = GHC.srcSpanFile span == f
1997 after_here = [ tick | tick@(_,span) <- ticks,
1998 GHC.srcSpanStartLine span == line,
1999 GHC.srcSpanStartCol span >= col ]
2001 -- For now, use ANSI bold on terminals that we know support it.
2002 -- Otherwise, we add a line of carets under the active expression instead.
2003 -- In particular, on Windows and when running the testsuite (which sets
2004 -- TERM to vt100 for other reasons) we get carets.
2005 -- We really ought to use a proper termcap/terminfo library.
2007 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2008 where mTerm = System.Environment.getEnv "TERM"
2009 `Exception.catch` \_ -> return "TERM not set"
2011 start_bold :: String
2012 start_bold = "\ESC[1m"
2014 end_bold = "\ESC[0m"
2016 listCmd :: String -> GHCi ()
2018 mb_span <- getCurrentBreakSpan
2020 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
2021 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
2022 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
2023 listCmd str = list2 (words str)
2025 list2 :: [String] -> GHCi ()
2026 list2 [arg] | all isDigit arg = do
2027 session <- getSession
2028 (toplevel, _) <- io $ GHC.getContext session
2030 [] -> io $ putStrLn "No module to list"
2031 (mod : _) -> listModuleLine mod (read arg)
2032 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2033 mod <- wantInterpretedModule arg1
2034 listModuleLine mod (read arg2)
2036 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2037 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2038 if GHC.isGoodSrcLoc loc
2040 tickArray <- getTickArray (GHC.nameModule name)
2041 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2042 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2045 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2046 Just (_,span) -> io $ listAround span False
2048 noCanDo name $ text "can't find its location: " <>
2051 noCanDo n why = printForUser $
2052 text "cannot list source code for " <> ppr n <> text ": " <> why
2054 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2056 listModuleLine :: Module -> Int -> GHCi ()
2057 listModuleLine modl line = do
2058 session <- getSession
2059 graph <- io (GHC.getModuleGraph session)
2060 let this = filter ((== modl) . GHC.ms_mod) graph
2062 [] -> panic "listModuleLine"
2064 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2065 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2066 io $ listAround (GHC.srcLocSpan loc) False
2068 -- | list a section of a source file around a particular SrcSpan.
2069 -- If the highlight flag is True, also highlight the span using
2070 -- start_bold/end_bold.
2071 listAround :: SrcSpan -> Bool -> IO ()
2072 listAround span do_highlight = do
2073 contents <- BS.readFile (unpackFS file)
2075 lines = BS.split '\n' contents
2076 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2077 drop (line1 - 1 - pad_before) $ lines
2078 fst_line = max 1 (line1 - pad_before)
2079 line_nos = [ fst_line .. ]
2081 highlighted | do_highlight = zipWith highlight line_nos these_lines
2082 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2084 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2085 prefixed = zipWith ($) highlighted bs_line_nos
2087 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2089 file = GHC.srcSpanFile span
2090 line1 = GHC.srcSpanStartLine span
2091 col1 = GHC.srcSpanStartCol span
2092 line2 = GHC.srcSpanEndLine span
2093 col2 = GHC.srcSpanEndCol span
2095 pad_before | line1 == 1 = 0
2099 highlight | do_bold = highlight_bold
2100 | otherwise = highlight_carets
2102 highlight_bold no line prefix
2103 | no == line1 && no == line2
2104 = let (a,r) = BS.splitAt col1 line
2105 (b,c) = BS.splitAt (col2-col1) r
2107 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2109 = let (a,b) = BS.splitAt col1 line in
2110 BS.concat [prefix, a, BS.pack start_bold, b]
2112 = let (a,b) = BS.splitAt col2 line in
2113 BS.concat [prefix, a, BS.pack end_bold, b]
2114 | otherwise = BS.concat [prefix, line]
2116 highlight_carets no line prefix
2117 | no == line1 && no == line2
2118 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2119 BS.replicate (col2-col1) '^']
2121 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2124 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2126 | otherwise = BS.concat [prefix, line]
2128 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2129 nl = BS.singleton '\n'
2131 -- --------------------------------------------------------------------------
2134 getTickArray :: Module -> GHCi TickArray
2135 getTickArray modl = do
2137 let arrmap = tickarrays st
2138 case lookupModuleEnv arrmap modl of
2139 Just arr -> return arr
2141 (_breakArray, ticks) <- getModBreak modl
2142 let arr = mkTickArray (assocs ticks)
2143 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2146 discardTickArrays :: GHCi ()
2147 discardTickArrays = do
2149 setGHCiState st{tickarrays = emptyModuleEnv}
2151 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2153 = accumArray (flip (:)) [] (1, max_line)
2154 [ (line, (nm,span)) | (nm,span) <- ticks,
2155 line <- srcSpanLines span ]
2157 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2158 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2159 GHC.srcSpanEndLine span ]
2161 lookupModule :: String -> GHCi Module
2162 lookupModule modName
2163 = do session <- getSession
2164 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2166 -- don't reset the counter back to zero?
2167 discardActiveBreakPoints :: GHCi ()
2168 discardActiveBreakPoints = do
2170 mapM (turnOffBreak.snd) (breaks st)
2171 setGHCiState $ st { breaks = [] }
2173 deleteBreak :: Int -> GHCi ()
2174 deleteBreak identity = do
2176 let oldLocations = breaks st
2177 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2179 then printForUser (text "Breakpoint" <+> ppr identity <+>
2180 text "does not exist")
2182 mapM (turnOffBreak.snd) this
2183 setGHCiState $ st { breaks = rest }
2185 turnOffBreak :: BreakLocation -> GHCi Bool
2186 turnOffBreak loc = do
2187 (arr, _) <- getModBreak (breakModule loc)
2188 io $ setBreakFlag False arr (breakTick loc)
2190 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2191 getModBreak mod = do
2192 session <- getSession
2193 Just mod_info <- io $ GHC.getModuleInfo session mod
2194 let modBreaks = GHC.modInfoModBreaks mod_info
2195 let array = GHC.modBreaks_flags modBreaks
2196 let ticks = GHC.modBreaks_locs modBreaks
2197 return (array, ticks)
2199 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2200 setBreakFlag toggle array index
2201 | toggle = GHC.setBreakOn array index
2202 | otherwise = GHC.setBreakOff array index