1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
12 #include "HsVersions.h"
20 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
21 Module, ModuleName, TyThing(..), Phase,
22 BreakIndex, SrcSpan, Resume, SingleStep )
32 import HscTypes ( implicitTyThings )
33 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
34 import Outputable hiding (printForUser, printForUserPartWay)
35 import Module -- for ModuleEnv
39 -- Other random utilities
41 import BasicTypes hiding (isTopLevel)
42 import Panic hiding (showException)
48 import Maybes ( orElse )
52 #ifndef mingw32_HOST_OS
53 import System.Posix hiding (getEnv)
55 import GHC.ConsoleHandler ( flushConsole )
56 import qualified System.Win32
57 import System.FilePath
61 import Control.Concurrent ( yield ) -- Used in readline loop
62 import System.Console.Readline as Readline
67 import Control.Exception as Exception
68 -- import Control.Concurrent
70 import qualified Data.ByteString.Char8 as BS
74 import System.Environment
75 import System.Exit ( exitWith, ExitCode(..) )
76 import System.Directory
78 import System.IO.Error as IO
82 import Control.Monad as Monad
85 import Foreign.C ( withCStringLen )
86 import GHC.Exts ( unsafeCoerce# )
87 import GHC.IOBase ( IOErrorType(InvalidArgument) )
89 import Data.IORef ( IORef, readIORef, writeIORef )
92 import System.Posix.Internals ( setNonBlockingFD )
95 -----------------------------------------------------------------------------
97 ghciWelcomeMsg :: String
98 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
99 ": http://www.haskell.org/ghc/ :? for help"
101 cmdName :: Command -> String
102 cmdName (n,_,_,_) = n
104 macros_ref :: IORef [Command]
105 GLOBAL_VAR(macros_ref, [], [Command])
107 builtin_commands :: [Command]
109 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
110 ("?", keepGoing help, Nothing, completeNone),
111 ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename),
112 ("abandon", keepGoing abandonCmd, Nothing, completeNone),
113 ("break", keepGoing breakCmd, Nothing, completeIdentifier),
114 ("back", keepGoing backCmd, Nothing, completeNone),
115 ("browse", keepGoing (browseCmd False), Nothing, completeModule),
116 ("browse!", keepGoing (browseCmd True), Nothing, completeModule),
117 ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename),
118 ("check", keepGoing checkModule, Nothing, completeHomeModule),
119 ("continue", keepGoing continueCmd, Nothing, completeNone),
120 ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier),
121 ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename),
122 ("def", keepGoing (defineMacro False), Nothing, completeIdentifier),
123 ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier),
124 ("delete", keepGoing deleteCmd, Nothing, completeNone),
125 ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
126 ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
127 ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename),
128 ("force", keepGoing forceCmd, Nothing, completeIdentifier),
129 ("forward", keepGoing forwardCmd, Nothing, completeNone),
130 ("help", keepGoing help, Nothing, completeNone),
131 ("history", keepGoing historyCmd, Nothing, completeNone),
132 ("info", keepGoing info, Nothing, completeIdentifier),
133 ("kind", keepGoing kindOfType, Nothing, completeIdentifier),
134 ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile),
135 ("list", keepGoing listCmd, Nothing, completeNone),
136 ("module", keepGoing setContext, Nothing, completeModule),
137 ("main", keepGoing runMain, Nothing, completeIdentifier),
138 ("print", keepGoing printCmd, Nothing, completeIdentifier),
139 ("quit", quit, Nothing, completeNone),
140 ("reload", keepGoing reloadModule, Nothing, completeNone),
141 ("run", keepGoing runRun, Nothing, completeIdentifier),
142 ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions),
143 ("show", keepGoing showCmd, Nothing, completeNone),
144 ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier),
145 ("step", keepGoing stepCmd, Nothing, completeIdentifier),
146 ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier),
147 ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier),
148 ("type", keepGoing typeOfExpr, Nothing, completeIdentifier),
149 ("trace", keepGoing traceCmd, Nothing, completeIdentifier),
150 ("undef", keepGoing undefineMacro, Nothing, completeMacro),
151 ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions)
155 -- We initialize readline (in the interactiveUI function) to use
156 -- word_break_chars as the default set of completion word break characters.
157 -- This can be overridden for a particular command (for example, filename
158 -- expansion shouldn't consider '/' to be a word break) by setting the third
159 -- entry in the Command tuple above.
161 -- NOTE: in order for us to override the default correctly, any custom entry
162 -- must be a SUBSET of word_break_chars.
164 word_break_chars :: String
165 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
166 specials = "(),;[]`{}"
168 in spaces ++ specials ++ symbols
171 flagWordBreakChars, filenameWordBreakChars :: String
172 flagWordBreakChars = " \t\n"
173 filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults
176 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
177 keepGoing a str = a str >> return False
179 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
181 = do case toArgs str of
182 Left err -> io (hPutStrLn stderr err)
186 shortHelpText :: String
187 shortHelpText = "use :? for help.\n"
191 " Commands available from the prompt:\n" ++
193 " <statement> evaluate/run <statement>\n" ++
194 " : repeat last command\n" ++
195 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
196 " :add <filename> ... add module(s) to the current target set\n" ++
197 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
198 " (!: more details; *: all top-level names)\n" ++
199 " :cd <dir> change directory to <dir>\n" ++
200 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
201 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
202 " :def <cmd> <expr> define a command :<cmd>\n" ++
203 " :edit <file> edit file\n" ++
204 " :edit edit last module\n" ++
205 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
206 " :help, :? display this list of commands\n" ++
207 " :info [<name> ...] display information about the given names\n" ++
208 " :kind <type> show the kind of <type>\n" ++
209 " :load <filename> ... load module(s) and their dependents\n" ++
210 " :main [<arguments> ...] run the main function with the given arguments\n" ++
211 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
212 " :quit exit GHCi\n" ++
213 " :reload reload the current module set\n" ++
214 " :run function [<arguments> ...] run the function with the given arguments\n" ++
215 " :type <expr> show the type of <expr>\n" ++
216 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
217 " :!<command> run the shell command <command>\n" ++
219 " -- Commands for debugging:\n" ++
221 " :abandon at a breakpoint, abandon current computation\n" ++
222 " :back go back in the history (after :trace)\n" ++
223 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
224 " :break <name> set a breakpoint on the specified function\n" ++
225 " :continue resume after a breakpoint\n" ++
226 " :delete <number> delete the specified breakpoint\n" ++
227 " :delete * delete all breakpoints\n" ++
228 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
229 " :forward go forward in the history (after :back)\n" ++
230 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
231 " :print [<name> ...] prints a value without forcing its computation\n" ++
232 " :sprint [<name> ...] simplifed version of :print\n" ++
233 " :step single-step after stopping at a breakpoint\n"++
234 " :step <expr> single-step into <expr>\n"++
235 " :steplocal single-step restricted to the current top level decl.\n"++
236 " :stepmodule single-step restricted to the current module\n"++
237 " :trace trace after stopping at a breakpoint\n"++
238 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
241 " -- Commands for changing settings:\n" ++
243 " :set <option> ... set options\n" ++
244 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
245 " :set prog <progname> set the value returned by System.getProgName\n" ++
246 " :set prompt <prompt> set the prompt used in GHCi\n" ++
247 " :set editor <cmd> set the command used for :edit\n" ++
248 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
249 " :unset <option> ... unset options\n" ++
251 " Options for ':set' and ':unset':\n" ++
253 " +r revert top-level expressions after each evaluation\n" ++
254 " +s print timing/memory stats after each evaluation\n" ++
255 " +t print type after evaluation\n" ++
256 " -<flags> most GHC command line flags can also be set here\n" ++
257 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
258 " for GHCi-specific flags, see User's Guide,\n"++
259 " Flag reference, Interactive-mode options\n" ++
261 " -- Commands for displaying information:\n" ++
263 " :show bindings show the current bindings made at the prompt\n" ++
264 " :show breaks show the active breakpoints\n" ++
265 " :show context show the breakpoint context\n" ++
266 " :show modules show the currently loaded modules\n" ++
267 " :show packages show the currently active package flags\n" ++
268 " :show languages show the currently active language flags\n" ++
269 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
272 findEditor :: IO String
277 win <- System.Win32.getWindowsDirectory
278 return (win </> "notepad.exe")
283 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
284 interactiveUI session srcs maybe_expr = do
285 -- HACK! If we happen to get into an infinite loop (eg the user
286 -- types 'let x=x in x' at the prompt), then the thread will block
287 -- on a blackhole, and become unreachable during GC. The GC will
288 -- detect that it is unreachable and send it the NonTermination
289 -- exception. However, since the thread is unreachable, everything
290 -- it refers to might be finalized, including the standard Handles.
291 -- This sounds like a bug, but we don't have a good solution right
297 -- Initialise buffering for the *interpreted* I/O system
298 initInterpBuffering session
300 when (isNothing maybe_expr) $ do
301 -- Only for GHCi (not runghc and ghc -e):
303 -- Turn buffering off for the compiled program's stdout/stderr
305 -- Turn buffering off for GHCi's stdout
307 hSetBuffering stdout NoBuffering
308 -- We don't want the cmd line to buffer any input that might be
309 -- intended for the program, so unbuffer stdin.
310 hSetBuffering stdin NoBuffering
313 is_tty <- hIsTerminalDevice stdin
316 Readline.setAttemptedCompletionFunction (Just completeWord)
317 --Readline.parseAndBind "set show-all-if-ambiguous 1"
319 Readline.setBasicWordBreakCharacters word_break_chars
320 Readline.setCompleterWordBreakCharacters word_break_chars
321 Readline.setCompletionAppendCharacter Nothing
324 -- initial context is just the Prelude
325 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
327 GHC.setContext session [] [prel_mod]
329 default_editor <- findEditor
331 startGHCi (runGHCi srcs maybe_expr)
332 GHCiState{ progname = "<interactive>",
336 editor = default_editor,
342 tickarrays = emptyModuleEnv,
343 last_command = Nothing,
345 remembered_ctx = Nothing
349 Readline.resetTerminal Nothing
354 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
355 runGHCi paths maybe_expr = do
356 let read_dot_files = not opt_IgnoreDotGhci
358 when (read_dot_files) $ do
361 exists <- io (doesFileExist file)
363 dir_ok <- io (checkPerms ".")
364 file_ok <- io (checkPerms file)
365 when (dir_ok && file_ok) $ do
366 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
369 Right hdl -> runCommands (fileLoop hdl False False)
371 when (read_dot_files) $ do
372 -- Read in $HOME/.ghci
373 either_dir <- io (IO.try getHomeDirectory)
377 cwd <- io (getCurrentDirectory)
378 when (dir /= cwd) $ do
379 let file = dir ++ "/.ghci"
380 ok <- io (checkPerms file)
382 either_hdl <- io (IO.try (openFile file ReadMode))
385 Right hdl -> runCommands (fileLoop hdl False False)
387 -- Perform a :load for files given on the GHCi command line
388 -- When in -e mode, if the load fails then we want to stop
389 -- immediately rather than going on to evaluate the expression.
390 when (not (null paths)) $ do
391 ok <- ghciHandle (\e -> do showException e; return Failed) $
393 when (isJust maybe_expr && failed ok) $
394 io (exitWith (ExitFailure 1))
396 -- if verbosity is greater than 0, or we are connected to a
397 -- terminal, display the prompt in the interactive loop.
398 is_tty <- io (hIsTerminalDevice stdin)
399 dflags <- getDynFlags
400 let show_prompt = verbosity dflags > 0 || is_tty
405 #if defined(mingw32_HOST_OS)
406 -- The win32 Console API mutates the first character of
407 -- type-ahead when reading from it in a non-buffered manner. Work
408 -- around this by flushing the input buffer of type-ahead characters,
409 -- but only if stdin is available.
410 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
412 Left err | isDoesNotExistError err -> return ()
413 | otherwise -> io (ioError err)
414 Right () -> return ()
416 -- enter the interactive loop
417 interactiveLoop is_tty show_prompt
419 -- just evaluate the expression we were given
420 enqueueCommands [expr]
421 let handleEval (ExitException code) = io (exitWith code)
422 handleEval e = handler e
423 runCommands' handleEval (return Nothing)
426 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
429 interactiveLoop :: Bool -> Bool -> GHCi ()
430 interactiveLoop is_tty show_prompt =
431 -- Ignore ^C exceptions caught here
432 ghciHandleDyn (\e -> case e of
434 #if defined(mingw32_HOST_OS)
437 interactiveLoop is_tty show_prompt
438 _other -> return ()) $
440 ghciUnblock $ do -- unblock necessary if we recursed from the
441 -- exception handler above.
443 -- read commands from stdin
446 then runCommands readlineLoop
447 else runCommands (fileLoop stdin show_prompt is_tty)
449 runCommands (fileLoop stdin show_prompt is_tty)
453 -- NOTE: We only read .ghci files if they are owned by the current user,
454 -- and aren't world writable. Otherwise, we could be accidentally
455 -- running code planted by a malicious third party.
457 -- Furthermore, We only read ./.ghci if . is owned by the current user
458 -- and isn't writable by anyone else. I think this is sufficient: we
459 -- don't need to check .. and ../.. etc. because "." always refers to
460 -- the same directory while a process is running.
462 checkPerms :: String -> IO Bool
463 #ifdef mingw32_HOST_OS
468 Util.handle (\_ -> return False) $ do
469 st <- getFileStatus name
471 if fileOwner st /= me then do
472 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
475 let mode = fileMode st
476 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
477 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
479 putStrLn $ "*** WARNING: " ++ name ++
480 " is writable by someone else, IGNORING!"
485 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
486 fileLoop hdl show_prompt is_tty = do
487 when show_prompt $ do
490 l <- io (IO.try (hGetLine hdl))
492 Left e | isEOFError e -> return Nothing
493 | InvalidArgument <- etype -> return Nothing
494 | otherwise -> io (ioError e)
495 where etype = ioeGetErrorType e
496 -- treat InvalidArgument in the same way as EOF:
497 -- this can happen if the user closed stdin, or
498 -- perhaps did getContents which closes stdin at
501 str <- io $ consoleInputToUnicode is_tty l
504 #ifdef mingw32_HOST_OS
505 -- Convert the console input into Unicode according to the current code page.
506 -- The Windows console stores Unicode characters directly, so this is a
507 -- rather roundabout way of doing things... oh well.
508 -- See #782, #1483, #1649
509 consoleInputToUnicode :: Bool -> String -> IO String
510 consoleInputToUnicode is_tty str
512 cp <- System.Win32.getConsoleCP
513 System.Win32.stringToUnicode cp str
515 decodeStringAsUTF8 str
517 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
519 consoleInputToUnicode :: Bool -> String -> IO String
520 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
523 decodeStringAsUTF8 :: String -> IO String
524 decodeStringAsUTF8 str =
525 withCStringLen str $ \(cstr,len) ->
526 utf8DecodeString (castPtr cstr :: Ptr Word8) len
528 mkPrompt :: GHCi String
530 session <- getSession
531 (toplevs,exports) <- io (GHC.getContext session)
532 resumes <- io $ GHC.getResumeContext session
533 -- st <- getGHCiState
539 let ix = GHC.resumeHistoryIx r
541 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
543 let hist = GHC.resumeHistory r !! (ix-1)
544 span <- io$ GHC.getHistorySpan session hist
545 return (brackets (ppr (negate ix) <> char ':'
546 <+> ppr span) <> space)
548 dots | _:rs <- resumes, not (null rs) = text "... "
555 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
556 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
557 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
558 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
559 hsep (map (ppr . GHC.moduleName) exports)
561 deflt_prompt = dots <> context_bit <> modules_bit
563 f ('%':'s':xs) = deflt_prompt <> f xs
564 f ('%':'%':xs) = char '%' <> f xs
565 f (x:xs) = char x <> f xs
569 return (showSDoc (f (prompt st)))
573 readlineLoop :: GHCi (Maybe String)
576 saveSession -- for use by completion
578 l <- io (readline prompt `finally` setNonBlockingFD 0)
579 -- readline sometimes puts stdin into blocking mode,
580 -- so we need to put it back for the IO library
583 Nothing -> return Nothing
586 str <- io $ consoleInputToUnicode True l
590 queryQueue :: GHCi (Maybe String)
595 c:cs -> do setGHCiState st{ cmdqueue = cs }
598 runCommands :: GHCi (Maybe String) -> GHCi ()
599 runCommands = runCommands' handler
601 runCommands' :: (Exception -> GHCi Bool) -- Exception handler
602 -> GHCi (Maybe String) -> GHCi ()
603 runCommands' eh getCmd = do
604 mb_cmd <- noSpace queryQueue
605 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
609 b <- ghciHandle eh (doCommand c)
610 if b then return () else runCommands getCmd
612 noSpace q = q >>= maybe (return Nothing)
613 (\c->case removeSpaces c of
615 ":{" -> multiLineCmd q
616 c -> return (Just c) )
620 setGHCiState st{ prompt = "%s| " }
621 mb_cmd <- collectCommand q ""
622 getGHCiState >>= \st->setGHCiState st{ prompt = p }
624 -- we can't use removeSpaces for the sublines here, so
625 -- multiline commands are somewhat more brittle against
626 -- fileformat errors (such as \r in dos input on unix),
627 -- we get rid of any extra spaces for the ":}" test;
628 -- we also avoid silent failure if ":}" is not found;
629 -- and since there is no (?) valid occurrence of \r (as
630 -- opposed to its String representation, "\r") inside a
631 -- ghci command, we replace any such with ' ' (argh:-(
632 collectCommand q c = q >>=
633 maybe (io (ioError collectError))
634 (\l->if removeSpaces l == ":}"
635 then return (Just $ removeSpaces c)
636 else collectCommand q (c++map normSpace l))
637 where normSpace '\r' = ' '
639 -- QUESTION: is userError the one to use here?
640 collectError = userError "unterminated multiline command :{ .. :}"
641 doCommand (':' : cmd) = specialCommand cmd
642 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
645 enqueueCommands :: [String] -> GHCi ()
646 enqueueCommands cmds = do
648 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
651 runStmt :: String -> SingleStep -> GHCi Bool
653 | null (filter (not.isSpace) stmt) = return False
654 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
656 = do st <- getGHCiState
657 session <- getSession
658 result <- io $ withProgName (progname st) $ withArgs (args st) $
659 GHC.runStmt session stmt step
660 afterRunStmt (const True) result
663 --afterRunStmt :: GHC.RunResult -> GHCi Bool
664 -- False <=> the statement failed to compile
665 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
666 afterRunStmt _ (GHC.RunException e) = throw e
667 afterRunStmt step_here run_result = do
668 session <- getSession
669 resumes <- io $ GHC.getResumeContext session
671 GHC.RunOk names -> do
672 show_types <- isOptionSet ShowType
673 when show_types $ printTypeOfNames session names
674 GHC.RunBreak _ names mb_info
675 | isNothing mb_info ||
676 step_here (GHC.resumeSpan $ head resumes) -> do
677 printForUser $ ptext SLIT("Stopped at") <+>
678 ppr (GHC.resumeSpan $ head resumes)
679 -- printTypeOfNames session names
680 let namesSorted = sortBy compareNames names
681 tythings <- catMaybes `liftM`
682 io (mapM (GHC.lookupName session) namesSorted)
683 docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
684 printForUserPartWay docs
685 maybe (return ()) runBreakCmd mb_info
686 -- run the command set with ":set stop <cmd>"
688 enqueueCommands [stop st]
690 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
691 afterRunStmt step_here >> return ()
695 io installSignalHandlers
696 b <- isOptionSet RevertCAFs
697 io (when b revertCAFs)
699 return (case run_result of GHC.RunOk _ -> True; _ -> False)
701 runBreakCmd :: GHC.BreakInfo -> GHCi ()
702 runBreakCmd info = do
703 let mod = GHC.breakInfo_module info
704 nm = GHC.breakInfo_number info
706 case [ loc | (_,loc) <- breaks st,
707 breakModule loc == mod, breakTick loc == nm ] of
709 loc:_ | null cmd -> return ()
710 | otherwise -> do enqueueCommands [cmd]; return ()
711 where cmd = onBreakCmd loc
713 printTypeOfNames :: Session -> [Name] -> GHCi ()
714 printTypeOfNames session names
715 = mapM_ (printTypeOfName session) $ sortBy compareNames names
717 compareNames :: Name -> Name -> Ordering
718 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
719 where compareWith n = (getOccString n, getSrcSpan n)
721 printTypeOfName :: Session -> Name -> GHCi ()
722 printTypeOfName session n
723 = do maybe_tything <- io (GHC.lookupName session n)
724 case maybe_tything of
726 Just thing -> printTyThing thing
729 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
731 specialCommand :: String -> GHCi Bool
732 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
733 specialCommand str = do
734 let (cmd,rest) = break isSpace str
735 maybe_cmd <- lookupCommand cmd
737 GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
739 do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
743 do io $ hPutStr stdout ("there is no last command to perform\n"
747 lookupCommand :: String -> GHCi (MaybeCommand)
748 lookupCommand "" = do
750 case last_command st of
751 Just c -> return $ GotCommand c
752 Nothing -> return NoLastCommand
753 lookupCommand str = do
754 mc <- io $ lookupCommand' str
756 setGHCiState st{ last_command = mc }
758 Just c -> GotCommand c
759 Nothing -> BadCommand
761 lookupCommand' :: String -> IO (Maybe Command)
762 lookupCommand' str = do
763 macros <- readIORef macros_ref
764 let cmds = builtin_commands ++ macros
765 -- look for exact match first, then the first prefix match
766 return $ case [ c | c <- cmds, str == cmdName c ] of
768 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
772 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
773 getCurrentBreakSpan = do
774 session <- getSession
775 resumes <- io $ GHC.getResumeContext session
779 let ix = GHC.resumeHistoryIx r
781 then return (Just (GHC.resumeSpan r))
783 let hist = GHC.resumeHistory r !! (ix-1)
784 span <- io $ GHC.getHistorySpan session hist
787 getCurrentBreakModule :: GHCi (Maybe Module)
788 getCurrentBreakModule = do
789 session <- getSession
790 resumes <- io $ GHC.getResumeContext session
794 let ix = GHC.resumeHistoryIx r
796 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
798 let hist = GHC.resumeHistory r !! (ix-1)
799 return $ Just $ GHC.getHistoryModule hist
801 -----------------------------------------------------------------------------
804 noArgs :: GHCi () -> String -> GHCi ()
806 noArgs _ _ = io $ putStrLn "This command takes no arguments"
808 help :: String -> GHCi ()
809 help _ = io (putStr helpText)
811 info :: String -> GHCi ()
812 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
813 info s = do { let names = words s
814 ; session <- getSession
815 ; dflags <- getDynFlags
816 ; let pefas = dopt Opt_PrintExplicitForalls dflags
817 ; mapM_ (infoThing pefas session) names }
819 infoThing pefas session str = io $ do
820 names <- GHC.parseName session str
821 mb_stuffs <- mapM (GHC.getInfo session) names
822 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
823 unqual <- GHC.getPrintUnqual session
824 putStrLn (showSDocForUser unqual $
825 vcat (intersperse (text "") $
826 map (pprInfo pefas) filtered))
828 -- Filter out names whose parent is also there Good
829 -- example is '[]', which is both a type and data
830 -- constructor in the same type
831 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
832 filterOutChildren get_thing xs
833 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
835 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
837 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
838 pprInfo pefas (thing, fixity, insts)
839 = pprTyThingInContextLoc pefas thing
840 $$ show_fixity fixity
841 $$ vcat (map GHC.pprInstance insts)
844 | fix == GHC.defaultFixity = empty
845 | otherwise = ppr fix <+> ppr (GHC.getName thing)
847 runMain :: String -> GHCi ()
848 runMain s = case toArgs s of
849 Left err -> io (hPutStrLn stderr err)
851 do dflags <- getDynFlags
852 case mainFunIs dflags of
853 Nothing -> doWithArgs args "main"
854 Just f -> doWithArgs args f
856 runRun :: String -> GHCi ()
857 runRun s = case toCmdArgs s of
858 Left err -> io (hPutStrLn stderr err)
859 Right (cmd, args) -> doWithArgs args cmd
861 doWithArgs :: [String] -> String -> GHCi ()
862 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
863 show args ++ " (" ++ cmd ++ ")"]
865 addModule :: [FilePath] -> GHCi ()
867 io (revertCAFs) -- always revert CAFs on load/add.
868 files <- mapM expandPath files
869 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
870 session <- getSession
871 io (mapM_ (GHC.addTarget session) targets)
872 prev_context <- io $ GHC.getContext session
873 ok <- io (GHC.load session LoadAllTargets)
874 afterLoad ok session False prev_context
876 changeDirectory :: String -> GHCi ()
877 changeDirectory "" = do
878 -- :cd on its own changes to the user's home directory
879 either_dir <- io (IO.try getHomeDirectory)
882 Right dir -> changeDirectory dir
883 changeDirectory dir = do
884 session <- getSession
885 graph <- io (GHC.getModuleGraph session)
886 when (not (null graph)) $
887 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
888 prev_context <- io $ GHC.getContext session
889 io (GHC.setTargets session [])
890 io (GHC.load session LoadAllTargets)
891 setContextAfterLoad session prev_context []
892 io (GHC.workingDirectoryChanged session)
893 dir <- expandPath dir
894 io (setCurrentDirectory dir)
896 editFile :: String -> GHCi ()
898 do file <- if null str then chooseEditFile else return str
902 $ throwDyn (CmdLineError "editor not set, use :set editor")
903 io $ system (cmd ++ ' ':file)
906 -- The user didn't specify a file so we pick one for them.
907 -- Our strategy is to pick the first module that failed to load,
908 -- or otherwise the first target.
910 -- XXX: Can we figure out what happened if the depndecy analysis fails
911 -- (e.g., because the porgrammeer mistyped the name of a module)?
912 -- XXX: Can we figure out the location of an error to pass to the editor?
913 -- XXX: if we could figure out the list of errors that occured during the
914 -- last load/reaload, then we could start the editor focused on the first
916 chooseEditFile :: GHCi String
918 do session <- getSession
919 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
921 graph <- io (GHC.getModuleGraph session)
922 failed_graph <- filterM hasFailed graph
923 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
925 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
928 case pick (order failed_graph) of
929 Just file -> return file
931 do targets <- io (GHC.getTargets session)
932 case msum (map fromTarget targets) of
933 Just file -> return file
934 Nothing -> throwDyn (CmdLineError "No files to edit.")
936 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
937 fromTarget _ = Nothing -- when would we get a module target?
939 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
940 defineMacro overwrite s = do
941 let (macro_name, definition) = break isSpace s
942 macros <- io (readIORef macros_ref)
943 let defined = map cmdName macros
946 then io $ putStrLn "no macros defined"
947 else io $ putStr ("the following macros are defined:\n" ++
950 if (not overwrite && macro_name `elem` defined)
951 then throwDyn (CmdLineError
952 ("macro '" ++ macro_name ++ "' is already defined"))
955 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
957 -- give the expression a type signature, so we can be sure we're getting
958 -- something of the right type.
959 let new_expr = '(' : definition ++ ") :: String -> IO String"
961 -- compile the expression
963 maybe_hv <- io (GHC.compileExpr cms new_expr)
966 Just hv -> io (writeIORef macros_ref --
967 (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)]))
969 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
971 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
972 enqueueCommands (lines str)
975 undefineMacro :: String -> GHCi ()
976 undefineMacro str = mapM_ undef (words str)
977 where undef macro_name = do
978 cmds <- io (readIORef macros_ref)
979 if (macro_name `notElem` map cmdName cmds)
980 then throwDyn (CmdLineError
981 ("macro '" ++ macro_name ++ "' is not defined"))
983 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
985 cmdCmd :: String -> GHCi ()
987 let expr = '(' : str ++ ") :: IO String"
988 session <- getSession
989 maybe_hv <- io (GHC.compileExpr session expr)
993 cmds <- io $ (unsafeCoerce# hv :: IO String)
994 enqueueCommands (lines cmds)
997 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
998 loadModule fs = timeIt (loadModule' fs)
1000 loadModule_ :: [FilePath] -> GHCi ()
1001 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
1003 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1004 loadModule' files = do
1005 session <- getSession
1006 prev_context <- io $ GHC.getContext session
1009 discardActiveBreakPoints
1010 io (GHC.setTargets session [])
1011 io (GHC.load session LoadAllTargets)
1014 let (filenames, phases) = unzip files
1015 exp_filenames <- mapM expandPath filenames
1016 let files' = zip exp_filenames phases
1017 targets <- io (mapM (uncurry GHC.guessTarget) files')
1019 -- NOTE: we used to do the dependency anal first, so that if it
1020 -- fails we didn't throw away the current set of modules. This would
1021 -- require some re-working of the GHC interface, so we'll leave it
1022 -- as a ToDo for now.
1024 io (GHC.setTargets session targets)
1025 doLoad session False prev_context LoadAllTargets
1027 checkModule :: String -> GHCi ()
1029 let modl = GHC.mkModuleName m
1030 session <- getSession
1031 prev_context <- io $ GHC.getContext session
1032 result <- io (GHC.checkModule session modl False)
1034 Nothing -> io $ putStrLn "Nothing"
1035 Just r -> io $ putStrLn (showSDoc (
1036 case GHC.checkedModuleInfo r of
1037 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1039 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1041 (text "global names: " <+> ppr global) $$
1042 (text "local names: " <+> ppr local)
1044 afterLoad (successIf (isJust result)) session False prev_context
1046 reloadModule :: String -> GHCi ()
1048 session <- getSession
1049 prev_context <- io $ GHC.getContext session
1050 doLoad session True prev_context $
1051 if null m then LoadAllTargets
1052 else LoadUpTo (GHC.mkModuleName m)
1055 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1056 doLoad session retain_context prev_context howmuch = do
1057 -- turn off breakpoints before we load: we can't turn them off later, because
1058 -- the ModBreaks will have gone away.
1059 discardActiveBreakPoints
1060 ok <- io (GHC.load session howmuch)
1061 afterLoad ok session retain_context prev_context
1064 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1065 afterLoad ok session retain_context prev_context = do
1066 io (revertCAFs) -- always revert CAFs on load.
1068 loaded_mod_summaries <- getLoadedModules session
1069 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1070 loaded_mod_names = map GHC.moduleName loaded_mods
1071 modulesLoadedMsg ok loaded_mod_names
1074 if not retain_context
1076 setGHCiState st{ remembered_ctx = Nothing }
1077 setContextAfterLoad session prev_context loaded_mod_summaries
1079 -- figure out which modules we can keep in the context, which we
1080 -- have to put back, and which we have to remember because they
1081 -- are (temporarily) unavailable. See ghci.prog009, #1873, #1360
1082 let (as,bs) = prev_context
1083 as1 = filter isHomeModule as -- package modules are kept anyway
1084 bs1 = filter isHomeModule bs
1085 (as_ok, as_bad) = partition (`elem` loaded_mods) as1
1086 (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1
1087 (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st)
1088 (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as
1089 (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs
1090 as' = nub (as_ok++rem_as_ok)
1091 bs' = nub (bs_ok++rem_bs_ok)
1092 rem_as' = nub (rem_as_bad ++ as_bad)
1093 rem_bs' = nub (rem_bs_bad ++ bs_bad)
1095 -- Put back into the context any modules that we previously had
1096 -- to drop because they weren't available (rem_as_ok, rem_bs_ok).
1097 setContextKeepingPackageModules session prev_context (as',bs')
1099 -- If compilation failed, remember any modules that we are unable
1100 -- to load, so that we can put them back in the context in the future.
1102 Succeeded -> setGHCiState st{ remembered_ctx = Nothing }
1103 Failed -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') }
1107 setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi ()
1108 setContextAfterLoad session prev [] = do
1109 prel_mod <- getPrelude
1110 setContextKeepingPackageModules session prev ([], [prel_mod])
1111 setContextAfterLoad session prev ms = do
1112 -- load a target if one is available, otherwise load the topmost module.
1113 targets <- io (GHC.getTargets session)
1114 case [ m | Just m <- map (findTarget ms) targets ] of
1116 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1117 load_this (last graph')
1122 = case filter (`matches` t) ms of
1126 summary `matches` Target (TargetModule m) _
1127 = GHC.ms_mod_name summary == m
1128 summary `matches` Target (TargetFile f _) _
1129 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1133 load_this summary | m <- GHC.ms_mod summary = do
1134 b <- io (GHC.moduleIsInterpreted session m)
1135 if b then setContextKeepingPackageModules session prev ([m], [])
1137 prel_mod <- getPrelude
1138 setContextKeepingPackageModules session prev ([],[prel_mod,m])
1140 -- | Keep any package modules (except Prelude) when changing the context.
1141 setContextKeepingPackageModules
1143 -> ([Module],[Module]) -- previous context
1144 -> ([Module],[Module]) -- new context
1146 setContextKeepingPackageModules session prev_context (as,bs) = do
1147 let (_,bs0) = prev_context
1148 prel_mod <- getPrelude
1149 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1150 let bs1 = if null as then nub (prel_mod : bs) else bs
1151 io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1153 isHomeModule :: Module -> Bool
1154 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1156 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1157 modulesLoadedMsg ok mods = do
1158 dflags <- getDynFlags
1159 when (verbosity dflags > 0) $ do
1161 | null mods = text "none."
1162 | otherwise = hsep (
1163 punctuate comma (map ppr mods)) <> text "."
1166 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1168 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1171 typeOfExpr :: String -> GHCi ()
1173 = do cms <- getSession
1174 maybe_ty <- io (GHC.exprType cms str)
1176 Nothing -> return ()
1177 Just ty -> do dflags <- getDynFlags
1178 let pefas = dopt Opt_PrintExplicitForalls dflags
1179 printForUser $ text str <+> dcolon
1180 <+> pprTypeForUser pefas ty
1182 kindOfType :: String -> GHCi ()
1184 = do cms <- getSession
1185 maybe_ty <- io (GHC.typeKind cms str)
1187 Nothing -> return ()
1188 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1190 quit :: String -> GHCi Bool
1191 quit _ = return True
1193 shellEscape :: String -> GHCi Bool
1194 shellEscape str = io (system str >> return False)
1196 -----------------------------------------------------------------------------
1197 -- Browsing a module's contents
1199 browseCmd :: Bool -> String -> GHCi ()
1202 ['*':s] | looksLikeModuleName s -> do
1203 m <- wantInterpretedModule s
1204 browseModule bang m False
1205 [s] | looksLikeModuleName s -> do
1207 browseModule bang m True
1210 (as,bs) <- io $ GHC.getContext s
1211 -- Guess which module the user wants to browse. Pick
1212 -- modules that are interpreted first. The most
1213 -- recently-added module occurs last, it seems.
1215 (as@(_:_), _) -> browseModule bang (last as) True
1216 ([], bs@(_:_)) -> browseModule bang (last bs) True
1217 ([], []) -> throwDyn (CmdLineError ":browse: no current module")
1218 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1220 -- without bang, show items in context of their parents and omit children
1221 -- with bang, show class methods and data constructors separately, and
1222 -- indicate import modules, to aid qualifying unqualified names
1223 -- with sorted, sort items alphabetically
1224 browseModule :: Bool -> Module -> Bool -> GHCi ()
1225 browseModule bang modl exports_only = do
1227 -- :browse! reports qualifiers wrt current context
1228 current_unqual <- io (GHC.getPrintUnqual s)
1229 -- Temporarily set the context to the module we're interested in,
1230 -- just so we can get an appropriate PrintUnqualified
1231 (as,bs) <- io (GHC.getContext s)
1232 prel_mod <- getPrelude
1233 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1234 else GHC.setContext s [modl] [])
1235 target_unqual <- io (GHC.getPrintUnqual s)
1236 io (GHC.setContext s as bs)
1238 let unqual = if bang then current_unqual else target_unqual
1240 mb_mod_info <- io $ GHC.getModuleInfo s modl
1242 Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1243 GHC.moduleNameString (GHC.moduleName modl)))
1245 dflags <- getDynFlags
1247 | exports_only = GHC.modInfoExports mod_info
1248 | otherwise = GHC.modInfoTopLevelScope mod_info
1251 -- sort alphabetically name, but putting
1252 -- locally-defined identifiers first.
1253 -- We would like to improve this; see #1799.
1254 sorted_names = loc_sort local ++ occ_sort external
1256 (local,external) = partition ((==modl) . nameModule) names
1257 occ_sort = sortBy (compare `on` nameOccName)
1258 -- try to sort by src location. If the first name in
1259 -- our list has a good source location, then they all should.
1261 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1262 = sortBy (compare `on` nameSrcSpan) names
1266 mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1267 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1269 rdr_env <- io $ GHC.getGRE s
1271 let pefas = dopt Opt_PrintExplicitForalls dflags
1272 things | bang = catMaybes mb_things
1273 | otherwise = filtered_things
1274 pretty | bang = pprTyThing
1275 | otherwise = pprTyThingInContext
1277 labels [] = text "-- not currently imported"
1278 labels l = text $ intercalate "\n" $ map qualifier l
1279 qualifier = maybe "-- defined locally"
1280 (("-- imported via "++) . intercalate ", "
1281 . map GHC.moduleNameString)
1282 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1283 modNames = map (importInfo . GHC.getName) things
1285 -- annotate groups of imports with their import modules
1286 -- the default ordering is somewhat arbitrary, so we group
1287 -- by header and sort groups; the names themselves should
1288 -- really come in order of source appearance.. (trac #1799)
1289 annotate mts = concatMap (\(m,ts)->labels m:ts)
1290 $ sortBy cmpQualifiers $ group mts
1291 where cmpQualifiers =
1292 compare `on` (map (fmap (map moduleNameFS)) . fst)
1294 group mts@((m,_):_) = (m,map snd g) : group ng
1295 where (g,ng) = partition ((==m).fst) mts
1297 let prettyThings = map (pretty pefas) things
1298 prettyThings' | bang = annotate $ zip modNames prettyThings
1299 | otherwise = prettyThings
1300 io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1301 -- ToDo: modInfoInstances currently throws an exception for
1302 -- package modules. When it works, we can do this:
1303 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1305 -----------------------------------------------------------------------------
1306 -- Setting the module context
1308 setContext :: String -> GHCi ()
1310 | all sensible mods = fn mods
1311 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1313 (fn, mods) = case str of
1314 '+':stuff -> (addToContext, words stuff)
1315 '-':stuff -> (removeFromContext, words stuff)
1316 stuff -> (newContext, words stuff)
1318 sensible ('*':m) = looksLikeModuleName m
1319 sensible m = looksLikeModuleName m
1321 separate :: Session -> [String] -> [Module] -> [Module]
1322 -> GHCi ([Module],[Module])
1323 separate _ [] as bs = return (as,bs)
1324 separate session (('*':str):ms) as bs = do
1325 m <- wantInterpretedModule str
1326 separate session ms (m:as) bs
1327 separate session (str:ms) as bs = do
1328 m <- lookupModule str
1329 separate session ms as (m:bs)
1331 newContext :: [String] -> GHCi ()
1332 newContext strs = do
1334 (as,bs) <- separate s strs [] []
1335 prel_mod <- getPrelude
1336 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1337 io $ GHC.setContext s as bs'
1340 addToContext :: [String] -> GHCi ()
1341 addToContext strs = do
1343 (as,bs) <- io $ GHC.getContext s
1345 (new_as,new_bs) <- separate s strs [] []
1347 let as_to_add = new_as \\ (as ++ bs)
1348 bs_to_add = new_bs \\ (as ++ bs)
1350 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1353 removeFromContext :: [String] -> GHCi ()
1354 removeFromContext strs = do
1356 (as,bs) <- io $ GHC.getContext s
1358 (as_to_remove,bs_to_remove) <- separate s strs [] []
1360 let as' = as \\ (as_to_remove ++ bs_to_remove)
1361 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1363 io $ GHC.setContext s as' bs'
1365 ----------------------------------------------------------------------------
1368 -- set options in the interpreter. Syntax is exactly the same as the
1369 -- ghc command line, except that certain options aren't available (-C,
1372 -- This is pretty fragile: most options won't work as expected. ToDo:
1373 -- figure out which ones & disallow them.
1375 setCmd :: String -> GHCi ()
1377 = do st <- getGHCiState
1378 let opts = options st
1379 io $ putStrLn (showSDoc (
1380 text "options currently set: " <>
1383 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1385 dflags <- getDynFlags
1386 io $ putStrLn (showSDoc (
1387 vcat (text "GHCi-specific dynamic flag settings:"
1388 :map (flagSetting dflags) ghciFlags)
1390 io $ putStrLn (showSDoc (
1391 vcat (text "other dynamic, non-language, flag settings:"
1392 :map (flagSetting dflags) nonLanguageDynFlags)
1394 where flagSetting dflags (str,f)
1395 | dopt f dflags = text " " <> text "-f" <> text str
1396 | otherwise = text " " <> text "-fno-" <> text str
1397 (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
1399 nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1401 flags = [Opt_PrintExplicitForalls
1402 ,Opt_PrintBindResult
1403 ,Opt_BreakOnException
1405 ,Opt_PrintEvldWithShow
1408 = case getCmd str of
1409 Right ("args", rest) ->
1411 Left err -> io (hPutStrLn stderr err)
1412 Right args -> setArgs args
1413 Right ("prog", rest) ->
1415 Right [prog] -> setProg prog
1416 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1417 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1418 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1419 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1420 _ -> case toArgs str of
1421 Left err -> io (hPutStrLn stderr err)
1422 Right wds -> setOptions wds
1424 setArgs, setOptions :: [String] -> GHCi ()
1425 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1429 setGHCiState st{ args = args }
1433 setGHCiState st{ progname = prog }
1437 setGHCiState st{ editor = cmd }
1439 setStop str@(c:_) | isDigit c
1440 = do let (nm_str,rest) = break (not.isDigit) str
1443 let old_breaks = breaks st
1444 if all ((/= nm) . fst) old_breaks
1445 then printForUser (text "Breakpoint" <+> ppr nm <+>
1446 text "does not exist")
1448 let new_breaks = map fn old_breaks
1449 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1450 | otherwise = (i,loc)
1451 setGHCiState st{ breaks = new_breaks }
1454 setGHCiState st{ stop = cmd }
1456 setPrompt value = do
1459 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1460 else setGHCiState st{ prompt = remQuotes value }
1462 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1466 do -- first, deal with the GHCi opts (+s, +t, etc.)
1467 let (plus_opts, minus_opts) = partitionWith isPlus wds
1468 mapM_ setOpt plus_opts
1469 -- then, dynamic flags
1470 newDynFlags minus_opts
1472 newDynFlags :: [String] -> GHCi ()
1473 newDynFlags minus_opts = do
1474 dflags <- getDynFlags
1475 let pkg_flags = packageFlags dflags
1476 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1478 if (not (null leftovers))
1479 then throwDyn (CmdLineError ("unrecognised flags: " ++
1483 new_pkgs <- setDynFlags dflags'
1485 -- if the package flags changed, we should reset the context
1486 -- and link the new packages.
1487 dflags <- getDynFlags
1488 when (packageFlags dflags /= pkg_flags) $ do
1489 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1490 session <- getSession
1491 io (GHC.setTargets session [])
1492 io (GHC.load session LoadAllTargets)
1493 io (linkPackages dflags new_pkgs)
1494 -- package flags changed, we can't re-use any of the old context
1495 setContextAfterLoad session ([],[]) []
1499 unsetOptions :: String -> GHCi ()
1501 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1502 let opts = words str
1503 (minus_opts, rest1) = partition isMinus opts
1504 (plus_opts, rest2) = partitionWith isPlus rest1
1506 if (not (null rest2))
1507 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1510 mapM_ unsetOpt plus_opts
1512 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1513 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1515 no_flags <- mapM no_flag minus_opts
1516 newDynFlags no_flags
1518 isMinus :: String -> Bool
1519 isMinus ('-':_) = True
1522 isPlus :: String -> Either String String
1523 isPlus ('+':opt) = Left opt
1524 isPlus other = Right other
1526 setOpt, unsetOpt :: String -> GHCi ()
1529 = case strToGHCiOpt str of
1530 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1531 Just o -> setOption o
1534 = case strToGHCiOpt str of
1535 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1536 Just o -> unsetOption o
1538 strToGHCiOpt :: String -> (Maybe GHCiOption)
1539 strToGHCiOpt "s" = Just ShowTiming
1540 strToGHCiOpt "t" = Just ShowType
1541 strToGHCiOpt "r" = Just RevertCAFs
1542 strToGHCiOpt _ = Nothing
1544 optToStr :: GHCiOption -> String
1545 optToStr ShowTiming = "s"
1546 optToStr ShowType = "t"
1547 optToStr RevertCAFs = "r"
1549 -- ---------------------------------------------------------------------------
1552 showCmd :: String -> GHCi ()
1556 ["args"] -> io $ putStrLn (show (args st))
1557 ["prog"] -> io $ putStrLn (show (progname st))
1558 ["prompt"] -> io $ putStrLn (show (prompt st))
1559 ["editor"] -> io $ putStrLn (show (editor st))
1560 ["stop"] -> io $ putStrLn (show (stop st))
1561 ["modules" ] -> showModules
1562 ["bindings"] -> showBindings
1563 ["linker"] -> io showLinkerState
1564 ["breaks"] -> showBkptTable
1565 ["context"] -> showContext
1566 ["packages"] -> showPackages
1567 ["languages"] -> showLanguages
1568 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1570 showModules :: GHCi ()
1572 session <- getSession
1573 loaded_mods <- getLoadedModules session
1574 -- we want *loaded* modules only, see #1734
1575 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1576 mapM_ show_one loaded_mods
1578 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1579 getLoadedModules session = do
1580 graph <- io (GHC.getModuleGraph session)
1581 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1583 showBindings :: GHCi ()
1586 bindings <- io (GHC.getBindings s)
1587 docs <- io$ pprTypeAndContents s
1588 [ id | AnId id <- sortBy compareTyThings bindings]
1589 printForUserPartWay docs
1591 compareTyThings :: TyThing -> TyThing -> Ordering
1592 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1594 printTyThing :: TyThing -> GHCi ()
1595 printTyThing tyth = do dflags <- getDynFlags
1596 let pefas = dopt Opt_PrintExplicitForalls dflags
1597 printForUser (pprTyThing pefas tyth)
1599 showBkptTable :: GHCi ()
1602 printForUser $ prettyLocations (breaks st)
1604 showContext :: GHCi ()
1606 session <- getSession
1607 resumes <- io $ GHC.getResumeContext session
1608 printForUser $ vcat (map pp_resume (reverse resumes))
1611 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1612 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1614 showPackages :: GHCi ()
1616 pkg_flags <- fmap packageFlags getDynFlags
1617 io $ putStrLn $ showSDoc $ vcat $
1618 text ("active package flags:"++if null pkg_flags then " none" else "")
1619 : map showFlag pkg_flags
1620 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1621 io $ putStrLn $ showSDoc $ vcat $
1622 text "packages currently loaded:"
1623 : map (nest 2 . text . packageIdString) pkg_ids
1624 where showFlag (ExposePackage p) = text $ " -package " ++ p
1625 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1626 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1628 showLanguages :: GHCi ()
1630 dflags <- getDynFlags
1631 io $ putStrLn $ showSDoc $ vcat $
1632 text "active language flags:" :
1633 [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1635 -- -----------------------------------------------------------------------------
1638 completeNone :: String -> IO [String]
1639 completeNone _w = return []
1641 completeMacro, completeIdentifier, completeModule,
1642 completeHomeModule, completeSetOptions, completeFilename,
1643 completeHomeModuleOrFile
1644 :: String -> IO [String]
1647 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1648 completeWord w start end = do
1649 line <- Readline.getLineBuffer
1650 let line_words = words (dropWhile isSpace line)
1652 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1654 | ((':':c) : _) <- line_words -> do
1655 completionVars <- lookupCompletionVars c
1656 case completionVars of
1657 (Nothing,complete) -> wrapCompleter complete w
1658 (Just breakChars,complete)
1659 -> let (n,w') = selectWord
1660 (words' (`elem` breakChars) 0 line)
1661 complete' w = do rets <- complete w
1662 return (map (drop n) rets)
1663 in wrapCompleter complete' w'
1664 | ("import" : _) <- line_words ->
1665 wrapCompleter completeModule w
1667 --printf "complete %s, start = %d, end = %d\n" w start end
1668 wrapCompleter completeIdentifier w
1669 where words' _ _ [] = []
1670 words' isBreak n str = let (w,r) = break isBreak str
1671 (s,r') = span isBreak r
1672 in (n,w):words' isBreak (n+length w+length s) r'
1673 -- In a Haskell expression we want to parse 'a-b' as three words
1674 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1675 -- only be a single word.
1676 selectWord [] = (0,w)
1677 selectWord ((offset,x):xs)
1678 | offset+length x >= start = (start-offset,take (end-offset) x)
1679 | otherwise = selectWord xs
1681 lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars,
1683 lookupCompletionVars c = do
1684 maybe_cmd <- lookupCommand' c
1686 Just (_,_,ws,f) -> return (ws,f)
1687 Nothing -> return (Just filenameWordBreakChars,
1691 completeCmd :: String -> IO [String]
1693 cmds <- readIORef macros_ref
1694 return (filter (w `isPrefixOf`) (map (':':)
1695 (map cmdName (builtin_commands ++ cmds))))
1697 completeMacro w = do
1698 cmds <- readIORef macros_ref
1699 return (filter (w `isPrefixOf`) (map cmdName cmds))
1701 completeIdentifier w = do
1703 rdrs <- GHC.getRdrNamesInScope s
1704 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1706 completeModule w = do
1708 dflags <- GHC.getSessionDynFlags s
1709 let pkg_mods = allExposedModules dflags
1710 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1712 completeHomeModule w = do
1714 g <- GHC.getModuleGraph s
1715 let home_mods = map GHC.ms_mod_name g
1716 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1718 completeSetOptions w = do
1719 return (filter (w `isPrefixOf`) options)
1720 where options = "args":"prog":allFlags
1722 completeFilename w = do
1723 ws <- Readline.filenameCompletionFunction w
1725 -- If we only found one result, and it's a directory,
1726 -- add a trailing slash.
1728 isDir <- expandPathIO file >>= doesDirectoryExist
1729 if isDir && last file /= '/'
1730 then return [file ++ "/"]
1735 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1737 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1738 unionComplete f1 f2 w = do
1743 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1744 wrapCompleter fun w = do
1747 [] -> Readline.setAttemptedCompletionOver True >> return Nothing
1748 [x] -> -- Add a trailing space, unless it already has an appended slash.
1749 let appended = if last x == '/' then x else x ++ " "
1750 in return (Just (appended,[]))
1751 xs -> case getCommonPrefix xs of
1752 "" -> return (Just ("",xs))
1753 pref -> return (Just (pref,xs))
1755 getCommonPrefix :: [String] -> String
1756 getCommonPrefix [] = ""
1757 getCommonPrefix (s:ss) = foldl common s ss
1758 where common _s "" = ""
1760 common (c:cs) (d:ds)
1761 | c == d = c : common cs ds
1764 allExposedModules :: DynFlags -> [ModuleName]
1765 allExposedModules dflags
1766 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1768 pkg_db = pkgIdMap (pkgState dflags)
1770 completeMacro = completeNone
1771 completeIdentifier = completeNone
1772 completeModule = completeNone
1773 completeHomeModule = completeNone
1774 completeSetOptions = completeNone
1775 completeFilename = completeNone
1776 completeHomeModuleOrFile=completeNone
1779 -- ---------------------------------------------------------------------------
1780 -- User code exception handling
1782 -- This is the exception handler for exceptions generated by the
1783 -- user's code and exceptions coming from children sessions;
1784 -- it normally just prints out the exception. The
1785 -- handler must be recursive, in case showing the exception causes
1786 -- more exceptions to be raised.
1788 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1789 -- raising another exception. We therefore don't put the recursive
1790 -- handler arond the flushing operation, so if stderr is closed
1791 -- GHCi will just die gracefully rather than going into an infinite loop.
1792 handler :: Exception -> GHCi Bool
1794 handler exception = do
1796 io installSignalHandlers
1797 ghciHandle handler (showException exception >> return False)
1799 showException :: Exception -> GHCi ()
1800 showException (DynException dyn) =
1801 case fromDynamic dyn of
1802 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1803 Just Interrupted -> io (putStrLn "Interrupted.")
1804 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1805 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1806 Just other_ghc_ex -> io (print other_ghc_ex)
1808 showException other_exception
1809 = io (putStrLn ("*** Exception: " ++ show other_exception))
1811 -----------------------------------------------------------------------------
1812 -- recursive exception handlers
1814 -- Don't forget to unblock async exceptions in the handler, or if we're
1815 -- in an exception loop (eg. let a = error a in a) the ^C exception
1816 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1818 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1819 ghciHandle h (GHCi m) = GHCi $ \s ->
1820 Exception.catch (m s)
1821 (\e -> unGHCi (ghciUnblock (h e)) s)
1823 ghciUnblock :: GHCi a -> GHCi a
1824 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1827 -- ----------------------------------------------------------------------------
1830 expandPath :: String -> GHCi String
1831 expandPath path = io (expandPathIO path)
1833 expandPathIO :: String -> IO String
1835 case dropWhile isSpace path of
1837 tilde <- getHomeDirectory -- will fail if HOME not defined
1838 return (tilde ++ '/':d)
1842 wantInterpretedModule :: String -> GHCi Module
1843 wantInterpretedModule str = do
1844 session <- getSession
1845 modl <- lookupModule str
1846 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1847 when (not is_interpreted) $
1848 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1851 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1852 -> (Name -> GHCi ())
1854 wantNameFromInterpretedModule noCanDo str and_then = do
1855 session <- getSession
1856 names <- io $ GHC.parseName session str
1860 let modl = GHC.nameModule n
1861 if not (GHC.isExternalName n)
1862 then noCanDo n $ ppr n <>
1863 text " is not defined in an interpreted module"
1865 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1866 if not is_interpreted
1867 then noCanDo n $ text "module " <> ppr modl <>
1868 text " is not interpreted"
1871 -- -----------------------------------------------------------------------------
1872 -- commands for debugger
1874 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1875 sprintCmd = pprintCommand False False
1876 printCmd = pprintCommand True False
1877 forceCmd = pprintCommand False True
1879 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1880 pprintCommand bind force str = do
1881 session <- getSession
1882 io $ pprintClosureCommand session bind force str
1884 stepCmd :: String -> GHCi ()
1885 stepCmd [] = doContinue (const True) GHC.SingleStep
1886 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1888 stepLocalCmd :: String -> GHCi ()
1889 stepLocalCmd [] = do
1890 mb_span <- getCurrentBreakSpan
1892 Nothing -> stepCmd []
1894 Just mod <- getCurrentBreakModule
1895 current_toplevel_decl <- enclosingTickSpan mod loc
1896 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1898 stepLocalCmd expression = stepCmd expression
1900 stepModuleCmd :: String -> GHCi ()
1901 stepModuleCmd [] = do
1902 mb_span <- getCurrentBreakSpan
1904 Nothing -> stepCmd []
1906 Just span <- getCurrentBreakSpan
1907 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1908 doContinue f GHC.SingleStep
1910 stepModuleCmd expression = stepCmd expression
1912 -- | Returns the span of the largest tick containing the srcspan given
1913 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1914 enclosingTickSpan mod src = do
1915 ticks <- getTickArray mod
1916 let line = srcSpanStartLine src
1917 ASSERT (inRange (bounds ticks) line) do
1918 let enclosing_spans = [ span | (_,span) <- ticks ! line
1919 , srcSpanEnd span >= srcSpanEnd src]
1920 return . head . sortBy leftmost_largest $ enclosing_spans
1922 traceCmd :: String -> GHCi ()
1923 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1924 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1926 continueCmd :: String -> GHCi ()
1927 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1929 -- doContinue :: SingleStep -> GHCi ()
1930 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1931 doContinue pred step = do
1932 session <- getSession
1933 runResult <- io $ GHC.resume session step
1934 afterRunStmt pred runResult
1937 abandonCmd :: String -> GHCi ()
1938 abandonCmd = noArgs $ do
1940 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1941 when (not b) $ io $ putStrLn "There is no computation running."
1944 deleteCmd :: String -> GHCi ()
1945 deleteCmd argLine = do
1946 deleteSwitch $ words argLine
1948 deleteSwitch :: [String] -> GHCi ()
1950 io $ putStrLn "The delete command requires at least one argument."
1951 -- delete all break points
1952 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1953 deleteSwitch idents = do
1954 mapM_ deleteOneBreak idents
1956 deleteOneBreak :: String -> GHCi ()
1958 | all isDigit str = deleteBreak (read str)
1959 | otherwise = return ()
1961 historyCmd :: String -> GHCi ()
1963 | null arg = history 20
1964 | all isDigit arg = history (read arg)
1965 | otherwise = io $ putStrLn "Syntax: :history [num]"
1969 resumes <- io $ GHC.getResumeContext s
1971 [] -> io $ putStrLn "Not stopped at a breakpoint"
1973 let hist = GHC.resumeHistory r
1974 (took,rest) = splitAt num hist
1976 [] -> io $ putStrLn $
1977 "Empty history. Perhaps you forgot to use :trace?"
1979 spans <- mapM (io . GHC.getHistorySpan s) took
1980 let nums = map (printf "-%-3d:") [(1::Int)..]
1981 names = map GHC.historyEnclosingDecl took
1982 printForUser (vcat(zipWith3
1983 (\x y z -> x <+> y <+> z)
1985 (map (bold . ppr) names)
1986 (map (parens . ppr) spans)))
1987 io $ putStrLn $ if null rest then "<end of history>" else "..."
1989 bold :: SDoc -> SDoc
1990 bold c | do_bold = text start_bold <> c <> text end_bold
1993 backCmd :: String -> GHCi ()
1994 backCmd = noArgs $ do
1996 (names, _, span) <- io $ GHC.back s
1997 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1998 printTypeOfNames s names
1999 -- run the command set with ":set stop <cmd>"
2001 enqueueCommands [stop st]
2003 forwardCmd :: String -> GHCi ()
2004 forwardCmd = noArgs $ do
2006 (names, ix, span) <- io $ GHC.forward s
2007 printForUser $ (if (ix == 0)
2008 then ptext SLIT("Stopped at")
2009 else ptext SLIT("Logged breakpoint at")) <+> ppr span
2010 printTypeOfNames s names
2011 -- run the command set with ":set stop <cmd>"
2013 enqueueCommands [stop st]
2015 -- handle the "break" command
2016 breakCmd :: String -> GHCi ()
2017 breakCmd argLine = do
2018 session <- getSession
2019 breakSwitch session $ words argLine
2021 breakSwitch :: Session -> [String] -> GHCi ()
2022 breakSwitch _session [] = do
2023 io $ putStrLn "The break command requires at least one argument."
2024 breakSwitch session (arg1:rest)
2025 | looksLikeModuleName arg1 = do
2026 mod <- wantInterpretedModule arg1
2027 breakByModule mod rest
2028 | all isDigit arg1 = do
2029 (toplevel, _) <- io $ GHC.getContext session
2031 (mod : _) -> breakByModuleLine mod (read arg1) rest
2033 io $ putStrLn "Cannot find default module for breakpoint."
2034 io $ putStrLn "Perhaps no modules are loaded for debugging?"
2035 | otherwise = do -- try parsing it as an identifier
2036 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2037 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2038 if GHC.isGoodSrcLoc loc
2039 then findBreakAndSet (GHC.nameModule name) $
2040 findBreakByCoord (Just (GHC.srcLocFile loc))
2041 (GHC.srcLocLine loc,
2043 else noCanDo name $ text "can't find its location: " <> ppr loc
2045 noCanDo n why = printForUser $
2046 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2048 breakByModule :: Module -> [String] -> GHCi ()
2049 breakByModule mod (arg1:rest)
2050 | all isDigit arg1 = do -- looks like a line number
2051 breakByModuleLine mod (read arg1) rest
2055 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2056 breakByModuleLine mod line args
2057 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2058 | [col] <- args, all isDigit col =
2059 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2060 | otherwise = breakSyntax
2063 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2065 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2066 findBreakAndSet mod lookupTickTree = do
2067 tickArray <- getTickArray mod
2068 (breakArray, _) <- getModBreak mod
2069 case lookupTickTree tickArray of
2070 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2071 Just (tick, span) -> do
2072 success <- io $ setBreakFlag True breakArray tick
2076 recordBreak $ BreakLocation
2083 text "Breakpoint " <> ppr nm <>
2085 then text " was already set at " <> ppr span
2086 else text " activated at " <> ppr span
2088 printForUser $ text "Breakpoint could not be activated at"
2091 -- When a line number is specified, the current policy for choosing
2092 -- the best breakpoint is this:
2093 -- - the leftmost complete subexpression on the specified line, or
2094 -- - the leftmost subexpression starting on the specified line, or
2095 -- - the rightmost subexpression enclosing the specified line
2097 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2098 findBreakByLine line arr
2099 | not (inRange (bounds arr) line) = Nothing
2101 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2102 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2103 listToMaybe (sortBy (rightmost `on` snd) ticks)
2107 starts_here = [ tick | tick@(_,span) <- ticks,
2108 GHC.srcSpanStartLine span == line ]
2110 (complete,incomplete) = partition ends_here starts_here
2111 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2113 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2114 -> Maybe (BreakIndex,SrcSpan)
2115 findBreakByCoord mb_file (line, col) arr
2116 | not (inRange (bounds arr) line) = Nothing
2118 listToMaybe (sortBy (rightmost `on` snd) contains ++
2119 sortBy (leftmost_smallest `on` snd) after_here)
2123 -- the ticks that span this coordinate
2124 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2125 is_correct_file span ]
2127 is_correct_file span
2128 | Just f <- mb_file = GHC.srcSpanFile span == f
2131 after_here = [ tick | tick@(_,span) <- ticks,
2132 GHC.srcSpanStartLine span == line,
2133 GHC.srcSpanStartCol span >= col ]
2135 -- For now, use ANSI bold on terminals that we know support it.
2136 -- Otherwise, we add a line of carets under the active expression instead.
2137 -- In particular, on Windows and when running the testsuite (which sets
2138 -- TERM to vt100 for other reasons) we get carets.
2139 -- We really ought to use a proper termcap/terminfo library.
2141 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2142 where mTerm = System.Environment.getEnv "TERM"
2143 `Exception.catch` \_ -> return "TERM not set"
2145 start_bold :: String
2146 start_bold = "\ESC[1m"
2148 end_bold = "\ESC[0m"
2150 listCmd :: String -> GHCi ()
2152 mb_span <- getCurrentBreakSpan
2155 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2157 | GHC.isGoodSrcSpan span -> io $ listAround span True
2160 resumes <- io $ GHC.getResumeContext s
2162 [] -> panic "No resumes"
2164 do let traceIt = case GHC.resumeHistory r of
2165 [] -> text "rerunning with :trace,"
2167 doWhat = traceIt <+> text ":back then :list"
2168 printForUser (text "Unable to list source for" <+>
2170 $$ text "Try" <+> doWhat)
2171 listCmd str = list2 (words str)
2173 list2 :: [String] -> GHCi ()
2174 list2 [arg] | all isDigit arg = do
2175 session <- getSession
2176 (toplevel, _) <- io $ GHC.getContext session
2178 [] -> io $ putStrLn "No module to list"
2179 (mod : _) -> listModuleLine mod (read arg)
2180 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2181 mod <- wantInterpretedModule arg1
2182 listModuleLine mod (read arg2)
2184 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2185 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2186 if GHC.isGoodSrcLoc loc
2188 tickArray <- getTickArray (GHC.nameModule name)
2189 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2190 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2193 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
2194 Just (_,span) -> io $ listAround span False
2196 noCanDo name $ text "can't find its location: " <>
2199 noCanDo n why = printForUser $
2200 text "cannot list source code for " <> ppr n <> text ": " <> why
2202 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2204 listModuleLine :: Module -> Int -> GHCi ()
2205 listModuleLine modl line = do
2206 session <- getSession
2207 graph <- io (GHC.getModuleGraph session)
2208 let this = filter ((== modl) . GHC.ms_mod) graph
2210 [] -> panic "listModuleLine"
2212 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2213 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2214 io $ listAround (GHC.srcLocSpan loc) False
2216 -- | list a section of a source file around a particular SrcSpan.
2217 -- If the highlight flag is True, also highlight the span using
2218 -- start_bold/end_bold.
2219 listAround :: SrcSpan -> Bool -> IO ()
2220 listAround span do_highlight = do
2221 contents <- BS.readFile (unpackFS file)
2223 lines = BS.split '\n' contents
2224 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2225 drop (line1 - 1 - pad_before) $ lines
2226 fst_line = max 1 (line1 - pad_before)
2227 line_nos = [ fst_line .. ]
2229 highlighted | do_highlight = zipWith highlight line_nos these_lines
2230 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2232 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2233 prefixed = zipWith ($) highlighted bs_line_nos
2235 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2237 file = GHC.srcSpanFile span
2238 line1 = GHC.srcSpanStartLine span
2239 col1 = GHC.srcSpanStartCol span
2240 line2 = GHC.srcSpanEndLine span
2241 col2 = GHC.srcSpanEndCol span
2243 pad_before | line1 == 1 = 0
2247 highlight | do_bold = highlight_bold
2248 | otherwise = highlight_carets
2250 highlight_bold no line prefix
2251 | no == line1 && no == line2
2252 = let (a,r) = BS.splitAt col1 line
2253 (b,c) = BS.splitAt (col2-col1) r
2255 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2257 = let (a,b) = BS.splitAt col1 line in
2258 BS.concat [prefix, a, BS.pack start_bold, b]
2260 = let (a,b) = BS.splitAt col2 line in
2261 BS.concat [prefix, a, BS.pack end_bold, b]
2262 | otherwise = BS.concat [prefix, line]
2264 highlight_carets no line prefix
2265 | no == line1 && no == line2
2266 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2267 BS.replicate (col2-col1) '^']
2269 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2272 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2274 | otherwise = BS.concat [prefix, line]
2276 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2277 nl = BS.singleton '\n'
2279 -- --------------------------------------------------------------------------
2282 getTickArray :: Module -> GHCi TickArray
2283 getTickArray modl = do
2285 let arrmap = tickarrays st
2286 case lookupModuleEnv arrmap modl of
2287 Just arr -> return arr
2289 (_breakArray, ticks) <- getModBreak modl
2290 let arr = mkTickArray (assocs ticks)
2291 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2294 discardTickArrays :: GHCi ()
2295 discardTickArrays = do
2297 setGHCiState st{tickarrays = emptyModuleEnv}
2299 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2301 = accumArray (flip (:)) [] (1, max_line)
2302 [ (line, (nm,span)) | (nm,span) <- ticks,
2303 line <- srcSpanLines span ]
2305 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2306 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2307 GHC.srcSpanEndLine span ]
2309 lookupModule :: String -> GHCi Module
2310 lookupModule modName
2311 = do session <- getSession
2312 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2314 -- don't reset the counter back to zero?
2315 discardActiveBreakPoints :: GHCi ()
2316 discardActiveBreakPoints = do
2318 mapM (turnOffBreak.snd) (breaks st)
2319 setGHCiState $ st { breaks = [] }
2321 deleteBreak :: Int -> GHCi ()
2322 deleteBreak identity = do
2324 let oldLocations = breaks st
2325 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2327 then printForUser (text "Breakpoint" <+> ppr identity <+>
2328 text "does not exist")
2330 mapM (turnOffBreak.snd) this
2331 setGHCiState $ st { breaks = rest }
2333 turnOffBreak :: BreakLocation -> GHCi Bool
2334 turnOffBreak loc = do
2335 (arr, _) <- getModBreak (breakModule loc)
2336 io $ setBreakFlag False arr (breakTick loc)
2338 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2339 getModBreak mod = do
2340 session <- getSession
2341 Just mod_info <- io $ GHC.getModuleInfo session mod
2342 let modBreaks = GHC.modInfoModBreaks mod_info
2343 let array = GHC.modBreaks_flags modBreaks
2344 let ticks = GHC.modBreaks_locs modBreaks
2345 return (array, ticks)
2347 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2348 setBreakFlag toggle array index
2349 | toggle = GHC.setBreakOn array index
2350 | otherwise = GHC.setBreakOff array index