1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
22 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
23 Type, Module, ModuleName, TyThing(..), Phase,
24 BreakIndex, Name, SrcSpan, Resume, SingleStep )
30 import Outputable hiding (printForUser)
31 import Module -- for ModuleEnv
33 -- Other random utilities
35 import BasicTypes hiding (isTopLevel)
36 import Panic hiding (showException)
43 #ifndef mingw32_HOST_OS
45 #if __GLASGOW_HASKELL__ > 504
49 import GHC.ConsoleHandler ( flushConsole )
50 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
51 import qualified System.Win32
55 import Control.Concurrent ( yield ) -- Used in readline loop
56 import System.Console.Readline as Readline
61 import Control.Exception as Exception
62 -- import Control.Concurrent
64 import qualified Data.ByteString.Char8 as BS
68 import System.Environment
69 import System.Exit ( exitWith, ExitCode(..) )
70 import System.Directory
72 import System.IO.Error as IO
76 import Control.Monad as Monad
79 import Foreign.StablePtr ( newStablePtr )
80 import GHC.Exts ( unsafeCoerce# )
81 import GHC.IOBase ( IOErrorType(InvalidArgument) )
83 import Data.IORef ( IORef, readIORef, writeIORef )
85 import System.Posix.Internals ( setNonBlockingFD )
87 -----------------------------------------------------------------------------
91 " / _ \\ /\\ /\\/ __(_)\n"++
92 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
93 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
94 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
96 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
99 GLOBAL_VAR(commands, builtin_commands, [Command])
101 builtin_commands :: [Command]
103 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
104 ("?", keepGoing help, False, completeNone),
105 ("add", keepGoingPaths addModule, False, completeFilename),
106 ("abandon", keepGoing abandonCmd, False, completeNone),
107 ("break", keepGoing breakCmd, False, completeIdentifier),
108 ("back", keepGoing backCmd, False, completeNone),
109 ("browse", keepGoing browseCmd, False, completeModule),
110 ("cd", keepGoing changeDirectory, False, completeFilename),
111 ("check", keepGoing checkModule, False, completeHomeModule),
112 ("continue", keepGoing continueCmd, False, completeNone),
113 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
114 ("def", keepGoing defineMacro, False, completeIdentifier),
115 ("delete", keepGoing deleteCmd, False, completeNone),
116 ("e", keepGoing editFile, False, completeFilename),
117 ("edit", keepGoing editFile, False, completeFilename),
118 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
119 ("force", keepGoing forceCmd, False, completeIdentifier),
120 ("forward", keepGoing forwardCmd, False, completeNone),
121 ("help", keepGoing help, False, completeNone),
122 ("history", keepGoing historyCmd, False, completeNone),
123 ("info", keepGoing info, False, completeIdentifier),
124 ("kind", keepGoing kindOfType, False, completeIdentifier),
125 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
126 ("list", keepGoing listCmd, False, completeNone),
127 ("module", keepGoing setContext, False, completeModule),
128 ("main", keepGoing runMain, False, completeIdentifier),
129 ("print", keepGoing printCmd, False, completeIdentifier),
130 ("quit", quit, False, completeNone),
131 ("reload", keepGoing reloadModule, False, completeNone),
132 ("set", keepGoing setCmd, True, completeSetOptions),
133 ("show", keepGoing showCmd, False, completeNone),
134 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
135 ("step", keepGoing stepCmd, False, completeIdentifier),
136 ("type", keepGoing typeOfExpr, False, completeIdentifier),
137 ("trace", keepGoing traceCmd, False, completeIdentifier),
138 ("undef", keepGoing undefineMacro, False, completeMacro),
139 ("unset", keepGoing unsetOptions, True, completeSetOptions)
142 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
143 keepGoing a str = a str >> return False
145 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
146 keepGoingPaths a str = a (toArgs str) >> return False
148 shortHelpText = "use :? for help.\n"
151 " Commands available from the prompt:\n" ++
153 " <statement> evaluate/run <statement>\n" ++
154 " :add <filename> ... add module(s) to the current target set\n" ++
155 " :browse [*]<module> display the names defined by <module>\n" ++
156 " :cd <dir> change directory to <dir>\n" ++
157 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
158 " :def <cmd> <expr> define a command :<cmd>\n" ++
159 " :edit <file> edit file\n" ++
160 " :edit edit last module\n" ++
161 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
162 " :help, :? display this list of commands\n" ++
163 " :info [<name> ...] display information about the given names\n" ++
164 " :kind <type> show the kind of <type>\n" ++
165 " :load <filename> ... load module(s) and their dependents\n" ++
166 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
167 " :main [<arguments> ...] run the main function with the given arguments\n" ++
168 " :quit exit GHCi\n" ++
169 " :reload reload the current module set\n" ++
170 " :type <expr> show the type of <expr>\n" ++
171 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
172 " :!<command> run the shell command <command>\n" ++
174 " -- Commands for debugging:\n" ++
176 " :abandon at a breakpoint, abandon current computation\n" ++
177 " :back go back in the history (after :trace)\n" ++
178 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
179 " :break <name> set a breakpoint on the specified function\n" ++
180 " :continue resume after a breakpoint\n" ++
181 " :delete <number> delete the specified breakpoint\n" ++
182 " :delete * delete all breakpoints\n" ++
183 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
184 " :forward go forward in the history (after :back)\n" ++
185 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
186 " :print [<name> ...] prints a value without forcing its computation\n" ++
187 " :step single-step after stopping at a breakpoint\n"++
188 " :step <expr> single-step into <expr>\n"++
189 " :trace trace after stopping at a breakpoint\n"++
190 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
191 " :sprint [<name> ...] simplifed version of :print\n" ++
194 " -- Commands for changing settings:\n" ++
196 " :set <option> ... set options\n" ++
197 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
198 " :set prog <progname> set the value returned by System.getProgName\n" ++
199 " :set prompt <prompt> set the prompt used in GHCi\n" ++
200 " :set editor <cmd> set the command used for :edit\n" ++
201 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
202 " :unset <option> ... unset options\n" ++
204 " Options for ':set' and ':unset':\n" ++
206 " +r revert top-level expressions after each evaluation\n" ++
207 " +s print timing/memory stats after each evaluation\n" ++
208 " +t print type after evaluation\n" ++
209 " -<flags> most GHC command line flags can also be set here\n" ++
210 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
212 " -- Commands for displaying information:\n" ++
214 " :show bindings show the current bindings made at the prompt\n" ++
215 " :show breaks show the active breakpoints\n" ++
216 " :show context show the breakpoint context\n" ++
217 " :show modules show the currently loaded modules\n" ++
218 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
225 win <- System.Win32.getWindowsDirectory
226 return (win `joinFileName` "notepad.exe")
231 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
232 interactiveUI session srcs maybe_expr = do
233 -- HACK! If we happen to get into an infinite loop (eg the user
234 -- types 'let x=x in x' at the prompt), then the thread will block
235 -- on a blackhole, and become unreachable during GC. The GC will
236 -- detect that it is unreachable and send it the NonTermination
237 -- exception. However, since the thread is unreachable, everything
238 -- it refers to might be finalized, including the standard Handles.
239 -- This sounds like a bug, but we don't have a good solution right
245 -- Initialise buffering for the *interpreted* I/O system
246 initInterpBuffering session
248 when (isNothing maybe_expr) $ do
249 -- Only for GHCi (not runghc and ghc -e):
250 -- Turn buffering off for the compiled program's stdout/stderr
252 -- Turn buffering off for GHCi's stdout
254 hSetBuffering stdout NoBuffering
255 -- We don't want the cmd line to buffer any input that might be
256 -- intended for the program, so unbuffer stdin.
257 hSetBuffering stdin NoBuffering
259 -- initial context is just the Prelude
260 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
261 GHC.setContext session [] [prel_mod]
265 Readline.setAttemptedCompletionFunction (Just completeWord)
266 --Readline.parseAndBind "set show-all-if-ambiguous 1"
268 let symbols = "!#$%&*+/<=>?@\\^|-~"
269 specials = "(),;[]`{}"
271 word_break_chars = spaces ++ specials ++ symbols
273 Readline.setBasicWordBreakCharacters word_break_chars
274 Readline.setCompleterWordBreakCharacters word_break_chars
277 default_editor <- findEditor
279 startGHCi (runGHCi srcs maybe_expr)
280 GHCiState{ progname = "<interactive>",
284 editor = default_editor,
290 tickarrays = emptyModuleEnv
294 Readline.resetTerminal Nothing
299 prel_name = GHC.mkModuleName "Prelude"
301 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
302 runGHCi paths maybe_expr = do
303 let read_dot_files = not opt_IgnoreDotGhci
305 when (read_dot_files) $ do
308 exists <- io (doesFileExist file)
310 dir_ok <- io (checkPerms ".")
311 file_ok <- io (checkPerms file)
312 when (dir_ok && file_ok) $ do
313 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
316 Right hdl -> fileLoop hdl False
318 when (read_dot_files) $ do
319 -- Read in $HOME/.ghci
320 either_dir <- io (IO.try (getEnv "HOME"))
324 cwd <- io (getCurrentDirectory)
325 when (dir /= cwd) $ do
326 let file = dir ++ "/.ghci"
327 ok <- io (checkPerms file)
329 either_hdl <- io (IO.try (openFile file ReadMode))
332 Right hdl -> fileLoop hdl False
334 -- Perform a :load for files given on the GHCi command line
335 -- When in -e mode, if the load fails then we want to stop
336 -- immediately rather than going on to evaluate the expression.
337 when (not (null paths)) $ do
338 ok <- ghciHandle (\e -> do showException e; return Failed) $
340 when (isJust maybe_expr && failed ok) $
341 io (exitWith (ExitFailure 1))
343 -- if verbosity is greater than 0, or we are connected to a
344 -- terminal, display the prompt in the interactive loop.
345 is_tty <- io (hIsTerminalDevice stdin)
346 dflags <- getDynFlags
347 let show_prompt = verbosity dflags > 0 || is_tty
352 #if defined(mingw32_HOST_OS)
353 -- The win32 Console API mutates the first character of
354 -- type-ahead when reading from it in a non-buffered manner. Work
355 -- around this by flushing the input buffer of type-ahead characters,
356 -- but only if stdin is available.
357 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
359 Left err | isDoesNotExistError err -> return ()
360 | otherwise -> io (ioError err)
361 Right () -> return ()
363 -- initialise the console if necessary
366 -- enter the interactive loop
367 interactiveLoop is_tty show_prompt
369 -- just evaluate the expression we were given
374 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
377 interactiveLoop is_tty show_prompt =
378 -- Ignore ^C exceptions caught here
379 ghciHandleDyn (\e -> case e of
381 #if defined(mingw32_HOST_OS)
384 interactiveLoop is_tty show_prompt
385 _other -> return ()) $
387 ghciUnblock $ do -- unblock necessary if we recursed from the
388 -- exception handler above.
390 -- read commands from stdin
394 else fileLoop stdin show_prompt
396 fileLoop stdin show_prompt
400 -- NOTE: We only read .ghci files if they are owned by the current user,
401 -- and aren't world writable. Otherwise, we could be accidentally
402 -- running code planted by a malicious third party.
404 -- Furthermore, We only read ./.ghci if . is owned by the current user
405 -- and isn't writable by anyone else. I think this is sufficient: we
406 -- don't need to check .. and ../.. etc. because "." always refers to
407 -- the same directory while a process is running.
409 checkPerms :: String -> IO Bool
411 #ifdef mingw32_HOST_OS
414 Util.handle (\_ -> return False) $ do
415 st <- getFileStatus name
417 if fileOwner st /= me then do
418 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
421 let mode = fileMode st
422 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
423 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
425 putStrLn $ "*** WARNING: " ++ name ++
426 " is writable by someone else, IGNORING!"
431 fileLoop :: Handle -> Bool -> GHCi ()
432 fileLoop hdl show_prompt = do
433 when show_prompt $ do
436 l <- io (IO.try (hGetLine hdl))
438 Left e | isEOFError e -> return ()
439 | InvalidArgument <- etype -> return ()
440 | otherwise -> io (ioError e)
441 where etype = ioeGetErrorType e
442 -- treat InvalidArgument in the same way as EOF:
443 -- this can happen if the user closed stdin, or
444 -- perhaps did getContents which closes stdin at
447 case removeSpaces l of
448 "" -> fileLoop hdl show_prompt
449 l -> do quit <- runCommand l
450 if quit then return () else fileLoop hdl show_prompt
452 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
453 stringLoop [] = return False
454 stringLoop (s:ss) = do
455 case removeSpaces s of
457 l -> do quit <- runCommand l
458 if quit then return True else stringLoop ss
461 session <- getSession
462 (toplevs,exports) <- io (GHC.getContext session)
463 resumes <- io $ GHC.getResumeContext session
469 let ix = GHC.resumeHistoryIx r
471 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
473 let hist = GHC.resumeHistory r !! (ix-1)
474 span <- io $ GHC.getHistorySpan session hist
475 return (brackets (ppr (negate ix) <> char ':'
476 <+> ppr span) <> space)
478 dots | r:rs <- resumes, not (null rs) = text "... "
482 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
483 hsep (map (ppr . GHC.moduleName) exports)
485 deflt_prompt = dots <> context_bit <> modules_bit
487 f ('%':'s':xs) = deflt_prompt <> f xs
488 f ('%':'%':xs) = char '%' <> f xs
489 f (x:xs) = char x <> f xs
493 return (showSDoc (f (prompt st)))
497 readlineLoop :: GHCi ()
499 session <- getSession
500 (mod,imports) <- io (GHC.getContext session)
502 saveSession -- for use by completion
504 mb_span <- getCurrentBreakSpan
506 l <- io (readline prompt `finally` setNonBlockingFD 0)
507 -- readline sometimes puts stdin into blocking mode,
508 -- so we need to put it back for the IO library
513 case removeSpaces l of
518 if quit then return () else readlineLoop
521 runCommand :: String -> GHCi Bool
522 runCommand c = ghciHandle handler (doCommand c)
524 doCommand (':' : command) = specialCommand command
526 = do timeIt $ runStmt stmt GHC.RunToCompletion
529 -- This version is for the GHC command-line option -e. The only difference
530 -- from runCommand is that it catches the ExitException exception and
531 -- exits, rather than printing out the exception.
532 runCommandEval c = ghciHandle handleEval (doCommand c)
534 handleEval (ExitException code) = io (exitWith code)
535 handleEval e = do handler e
536 io (exitWith (ExitFailure 1))
538 doCommand (':' : command) = specialCommand command
540 = do r <- runStmt stmt GHC.RunToCompletion
542 False -> io (exitWith (ExitFailure 1))
543 -- failure to run the command causes exit(1) for ghc -e.
546 runStmt :: String -> SingleStep -> GHCi Bool
548 | null (filter (not.isSpace) stmt) = return False
550 = do st <- getGHCiState
551 session <- getSession
552 result <- io $ withProgName (progname st) $ withArgs (args st) $
553 GHC.runStmt session stmt step
557 afterRunStmt :: GHC.RunResult -> GHCi Bool
558 -- False <=> the statement failed to compile
559 afterRunStmt (GHC.RunException e) = throw e
560 afterRunStmt run_result = do
561 session <- getSession
563 GHC.RunOk names -> do
564 show_types <- isOptionSet ShowType
565 when show_types $ mapM_ (showTypeOfName session) names
566 GHC.RunBreak _ names _ -> do
567 resumes <- io $ GHC.getResumeContext session
568 printForUser $ ptext SLIT("Stopped at") <+>
569 ppr (GHC.resumeSpan (head resumes))
570 mapM_ (showTypeOfName session) names
571 -- run the command set with ":set stop <cmd>"
578 io installSignalHandlers
579 b <- isOptionSet RevertCAFs
580 io (when b revertCAFs)
582 return (case run_result of GHC.RunOk _ -> True; _ -> False)
585 showTypeOfName :: Session -> Name -> GHCi ()
586 showTypeOfName session n
587 = do maybe_tything <- io (GHC.lookupName session n)
588 case maybe_tything of
590 Just thing -> showTyThing thing
592 specialCommand :: String -> GHCi Bool
593 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
594 specialCommand str = do
595 let (cmd,rest) = break isSpace str
596 maybe_cmd <- io (lookupCommand cmd)
598 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
599 ++ shortHelpText) >> return False)
600 Just (_,f,_,_) -> f (dropWhile isSpace rest)
602 lookupCommand :: String -> IO (Maybe Command)
603 lookupCommand str = do
604 cmds <- readIORef commands
605 -- look for exact match first, then the first prefix match
606 case [ c | c <- cmds, str == cmdName c ] of
607 c:_ -> return (Just c)
608 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
610 c:_ -> return (Just c)
613 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
614 getCurrentBreakSpan = do
615 session <- getSession
616 resumes <- io $ GHC.getResumeContext session
620 let ix = GHC.resumeHistoryIx r
622 then return (Just (GHC.resumeSpan r))
624 let hist = GHC.resumeHistory r !! (ix-1)
625 span <- io $ GHC.getHistorySpan session hist
628 -----------------------------------------------------------------------------
631 noArgs :: GHCi () -> String -> GHCi ()
633 noArgs m _ = io $ putStrLn "This command takes no arguments"
635 help :: String -> GHCi ()
636 help _ = io (putStr helpText)
638 info :: String -> GHCi ()
639 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
640 info s = do { let names = words s
641 ; session <- getSession
642 ; dflags <- getDynFlags
643 ; let exts = dopt Opt_GlasgowExts dflags
644 ; mapM_ (infoThing exts session) names }
646 infoThing exts session str = io $ do
647 names <- GHC.parseName session str
648 let filtered = filterOutChildren names
649 mb_stuffs <- mapM (GHC.getInfo session) filtered
650 unqual <- GHC.getPrintUnqual session
651 putStrLn (showSDocForUser unqual $
652 vcat (intersperse (text "") $
653 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
655 -- Filter out names whose parent is also there Good
656 -- example is '[]', which is both a type and data
657 -- constructor in the same type
658 filterOutChildren :: [Name] -> [Name]
659 filterOutChildren names = filter (not . parent_is_there) names
660 where parent_is_there n
661 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
665 pprInfo exts (thing, fixity, insts)
666 = pprTyThingInContextLoc exts thing
667 $$ show_fixity fixity
668 $$ vcat (map GHC.pprInstance insts)
671 | fix == GHC.defaultFixity = empty
672 | otherwise = ppr fix <+> ppr (GHC.getName thing)
674 runMain :: String -> GHCi ()
676 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
677 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
680 addModule :: [FilePath] -> GHCi ()
682 io (revertCAFs) -- always revert CAFs on load/add.
683 files <- mapM expandPath files
684 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
685 session <- getSession
686 io (mapM_ (GHC.addTarget session) targets)
687 ok <- io (GHC.load session LoadAllTargets)
690 changeDirectory :: String -> GHCi ()
691 changeDirectory dir = do
692 session <- getSession
693 graph <- io (GHC.getModuleGraph session)
694 when (not (null graph)) $
695 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
696 io (GHC.setTargets session [])
697 io (GHC.load session LoadAllTargets)
698 setContextAfterLoad session []
699 io (GHC.workingDirectoryChanged session)
700 dir <- expandPath dir
701 io (setCurrentDirectory dir)
703 editFile :: String -> GHCi ()
706 -- find the name of the "topmost" file loaded
707 session <- getSession
708 graph0 <- io (GHC.getModuleGraph session)
709 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
710 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
711 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
712 Just file -> do_edit file
713 Nothing -> throwDyn (CmdLineError "unknown file name")
714 | otherwise = do_edit str
720 throwDyn (CmdLineError "editor not set, use :set editor")
721 io $ system (cmd ++ ' ':file)
724 defineMacro :: String -> GHCi ()
726 let (macro_name, definition) = break isSpace s
727 cmds <- io (readIORef commands)
729 then throwDyn (CmdLineError "invalid macro name")
731 if (macro_name `elem` map cmdName cmds)
732 then throwDyn (CmdLineError
733 ("command '" ++ macro_name ++ "' is already defined"))
736 -- give the expression a type signature, so we can be sure we're getting
737 -- something of the right type.
738 let new_expr = '(' : definition ++ ") :: String -> IO String"
740 -- compile the expression
742 maybe_hv <- io (GHC.compileExpr cms new_expr)
745 Just hv -> io (writeIORef commands --
746 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
748 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
750 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
751 stringLoop (lines str)
753 undefineMacro :: String -> GHCi ()
754 undefineMacro macro_name = do
755 cmds <- io (readIORef commands)
756 if (macro_name `elem` map cmdName builtin_commands)
757 then throwDyn (CmdLineError
758 ("command '" ++ macro_name ++ "' cannot be undefined"))
760 if (macro_name `notElem` map cmdName cmds)
761 then throwDyn (CmdLineError
762 ("command '" ++ macro_name ++ "' not defined"))
764 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
767 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
768 loadModule fs = timeIt (loadModule' fs)
770 loadModule_ :: [FilePath] -> GHCi ()
771 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
773 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
774 loadModule' files = do
775 session <- getSession
778 discardActiveBreakPoints
779 io (GHC.setTargets session [])
780 io (GHC.load session LoadAllTargets)
783 let (filenames, phases) = unzip files
784 exp_filenames <- mapM expandPath filenames
785 let files' = zip exp_filenames phases
786 targets <- io (mapM (uncurry GHC.guessTarget) files')
788 -- NOTE: we used to do the dependency anal first, so that if it
789 -- fails we didn't throw away the current set of modules. This would
790 -- require some re-working of the GHC interface, so we'll leave it
791 -- as a ToDo for now.
793 io (GHC.setTargets session targets)
794 doLoad session LoadAllTargets
796 checkModule :: String -> GHCi ()
798 let modl = GHC.mkModuleName m
799 session <- getSession
800 result <- io (GHC.checkModule session modl)
802 Nothing -> io $ putStrLn "Nothing"
803 Just r -> io $ putStrLn (showSDoc (
804 case GHC.checkedModuleInfo r of
805 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
807 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
809 (text "global names: " <+> ppr global) $$
810 (text "local names: " <+> ppr local)
812 afterLoad (successIf (isJust result)) session
814 reloadModule :: String -> GHCi ()
816 io (revertCAFs) -- always revert CAFs on reload.
817 discardActiveBreakPoints
818 session <- getSession
819 doLoad session LoadAllTargets
822 io (revertCAFs) -- always revert CAFs on reload.
823 discardActiveBreakPoints
824 session <- getSession
825 doLoad session (LoadUpTo (GHC.mkModuleName m))
828 doLoad session howmuch = do
829 -- turn off breakpoints before we load: we can't turn them off later, because
830 -- the ModBreaks will have gone away.
831 discardActiveBreakPoints
832 ok <- io (GHC.load session howmuch)
836 afterLoad ok session = do
837 io (revertCAFs) -- always revert CAFs on load.
839 graph <- io (GHC.getModuleGraph session)
840 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
841 setContextAfterLoad session graph'
842 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
844 setContextAfterLoad session [] = do
845 prel_mod <- getPrelude
846 io (GHC.setContext session [] [prel_mod])
847 setContextAfterLoad session ms = do
848 -- load a target if one is available, otherwise load the topmost module.
849 targets <- io (GHC.getTargets session)
850 case [ m | Just m <- map (findTarget ms) targets ] of
852 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
853 load_this (last graph')
858 = case filter (`matches` t) ms of
862 summary `matches` Target (TargetModule m) _
863 = GHC.ms_mod_name summary == m
864 summary `matches` Target (TargetFile f _) _
865 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
866 summary `matches` target
869 load_this summary | m <- GHC.ms_mod summary = do
870 b <- io (GHC.moduleIsInterpreted session m)
871 if b then io (GHC.setContext session [m] [])
873 prel_mod <- getPrelude
874 io (GHC.setContext session [] [prel_mod,m])
877 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
878 modulesLoadedMsg ok mods = do
879 dflags <- getDynFlags
880 when (verbosity dflags > 0) $ do
882 | null mods = text "none."
884 punctuate comma (map ppr mods)) <> text "."
887 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
889 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
892 typeOfExpr :: String -> GHCi ()
894 = do cms <- getSession
895 maybe_ty <- io (GHC.exprType cms str)
898 Just ty -> do ty' <- cleanType ty
899 printForUser $ text str <> text " :: " <> ppr ty'
901 kindOfType :: String -> GHCi ()
903 = do cms <- getSession
904 maybe_ty <- io (GHC.typeKind cms str)
907 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
909 quit :: String -> GHCi Bool
912 shellEscape :: String -> GHCi Bool
913 shellEscape str = io (system str >> return False)
915 -----------------------------------------------------------------------------
916 -- Browsing a module's contents
918 browseCmd :: String -> GHCi ()
921 ['*':m] | looksLikeModuleName m -> browseModule m False
922 [m] | looksLikeModuleName m -> browseModule m True
923 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
925 browseModule m exports_only = do
927 modl <- if exports_only then lookupModule m
928 else wantInterpretedModule m
930 -- Temporarily set the context to the module we're interested in,
931 -- just so we can get an appropriate PrintUnqualified
932 (as,bs) <- io (GHC.getContext s)
933 prel_mod <- getPrelude
934 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
935 else GHC.setContext s [modl] [])
936 unqual <- io (GHC.getPrintUnqual s)
937 io (GHC.setContext s as bs)
939 mb_mod_info <- io $ GHC.getModuleInfo s modl
941 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
944 | exports_only = GHC.modInfoExports mod_info
945 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
947 filtered = filterOutChildren names
949 things <- io $ mapM (GHC.lookupName s) filtered
951 dflags <- getDynFlags
952 let exts = dopt Opt_GlasgowExts dflags
953 io (putStrLn (showSDocForUser unqual (
954 vcat (map (pprTyThingInContext exts) (catMaybes things))
956 -- ToDo: modInfoInstances currently throws an exception for
957 -- package modules. When it works, we can do this:
958 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
960 -----------------------------------------------------------------------------
961 -- Setting the module context
964 | all sensible mods = fn mods
965 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
967 (fn, mods) = case str of
968 '+':stuff -> (addToContext, words stuff)
969 '-':stuff -> (removeFromContext, words stuff)
970 stuff -> (newContext, words stuff)
972 sensible ('*':m) = looksLikeModuleName m
973 sensible m = looksLikeModuleName m
975 separate :: Session -> [String] -> [Module] -> [Module]
976 -> GHCi ([Module],[Module])
977 separate session [] as bs = return (as,bs)
978 separate session (('*':str):ms) as bs = do
979 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
980 b <- io $ GHC.moduleIsInterpreted session m
981 if b then separate session ms (m:as) bs
982 else throwDyn (CmdLineError ("module '"
983 ++ GHC.moduleNameString (GHC.moduleName m)
984 ++ "' is not interpreted"))
985 separate session (str:ms) as bs = do
986 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
987 separate session ms as (m:bs)
989 newContext :: [String] -> GHCi ()
992 (as,bs) <- separate s strs [] []
993 prel_mod <- getPrelude
994 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
995 io $ GHC.setContext s as bs'
998 addToContext :: [String] -> GHCi ()
999 addToContext strs = do
1001 (as,bs) <- io $ GHC.getContext s
1003 (new_as,new_bs) <- separate s strs [] []
1005 let as_to_add = new_as \\ (as ++ bs)
1006 bs_to_add = new_bs \\ (as ++ bs)
1008 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1011 removeFromContext :: [String] -> GHCi ()
1012 removeFromContext strs = do
1014 (as,bs) <- io $ GHC.getContext s
1016 (as_to_remove,bs_to_remove) <- separate s strs [] []
1018 let as' = as \\ (as_to_remove ++ bs_to_remove)
1019 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1021 io $ GHC.setContext s as' bs'
1023 ----------------------------------------------------------------------------
1026 -- set options in the interpreter. Syntax is exactly the same as the
1027 -- ghc command line, except that certain options aren't available (-C,
1030 -- This is pretty fragile: most options won't work as expected. ToDo:
1031 -- figure out which ones & disallow them.
1033 setCmd :: String -> GHCi ()
1035 = do st <- getGHCiState
1036 let opts = options st
1037 io $ putStrLn (showSDoc (
1038 text "options currently set: " <>
1041 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1044 = case toArgs str of
1045 ("args":args) -> setArgs args
1046 ("prog":prog) -> setProg prog
1047 ("prompt":prompt) -> setPrompt (after 6)
1048 ("editor":cmd) -> setEditor (after 6)
1049 ("stop":cmd) -> setStop (after 4)
1050 wds -> setOptions wds
1051 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1055 setGHCiState st{ args = args }
1059 setGHCiState st{ progname = prog }
1061 io (hPutStrLn stderr "syntax: :set prog <progname>")
1065 setGHCiState st{ editor = cmd }
1069 setGHCiState st{ stop = cmd }
1071 setPrompt value = do
1074 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1075 else setGHCiState st{ prompt = remQuotes value }
1077 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1081 do -- first, deal with the GHCi opts (+s, +t, etc.)
1082 let (plus_opts, minus_opts) = partition isPlus wds
1083 mapM_ setOpt plus_opts
1084 -- then, dynamic flags
1085 newDynFlags minus_opts
1087 newDynFlags minus_opts = do
1088 dflags <- getDynFlags
1089 let pkg_flags = packageFlags dflags
1090 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1092 if (not (null leftovers))
1093 then throwDyn (CmdLineError ("unrecognised flags: " ++
1097 new_pkgs <- setDynFlags dflags'
1099 -- if the package flags changed, we should reset the context
1100 -- and link the new packages.
1101 dflags <- getDynFlags
1102 when (packageFlags dflags /= pkg_flags) $ do
1103 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1104 session <- getSession
1105 io (GHC.setTargets session [])
1106 io (GHC.load session LoadAllTargets)
1107 io (linkPackages dflags new_pkgs)
1108 setContextAfterLoad session []
1112 unsetOptions :: String -> GHCi ()
1114 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1115 let opts = words str
1116 (minus_opts, rest1) = partition isMinus opts
1117 (plus_opts, rest2) = partition isPlus rest1
1119 if (not (null rest2))
1120 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1123 mapM_ unsetOpt plus_opts
1125 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1126 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1128 no_flags <- mapM no_flag minus_opts
1129 newDynFlags no_flags
1131 isMinus ('-':s) = True
1134 isPlus ('+':s) = True
1138 = case strToGHCiOpt str of
1139 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1140 Just o -> setOption o
1143 = case strToGHCiOpt str of
1144 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1145 Just o -> unsetOption o
1147 strToGHCiOpt :: String -> (Maybe GHCiOption)
1148 strToGHCiOpt "s" = Just ShowTiming
1149 strToGHCiOpt "t" = Just ShowType
1150 strToGHCiOpt "r" = Just RevertCAFs
1151 strToGHCiOpt _ = Nothing
1153 optToStr :: GHCiOption -> String
1154 optToStr ShowTiming = "s"
1155 optToStr ShowType = "t"
1156 optToStr RevertCAFs = "r"
1158 -- ---------------------------------------------------------------------------
1164 ["args"] -> io $ putStrLn (show (args st))
1165 ["prog"] -> io $ putStrLn (show (progname st))
1166 ["prompt"] -> io $ putStrLn (show (prompt st))
1167 ["editor"] -> io $ putStrLn (show (editor st))
1168 ["stop"] -> io $ putStrLn (show (stop st))
1169 ["modules" ] -> showModules
1170 ["bindings"] -> showBindings
1171 ["linker"] -> io showLinkerState
1172 ["breaks"] -> showBkptTable
1173 ["context"] -> showContext
1174 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1177 session <- getSession
1178 let show_one ms = do m <- io (GHC.showModule session ms)
1180 graph <- io (GHC.getModuleGraph session)
1181 mapM_ show_one graph
1185 unqual <- io (GHC.getPrintUnqual s)
1186 bindings <- io (GHC.getBindings s)
1187 mapM_ showTyThing bindings
1190 showTyThing (AnId id) = do
1191 ty' <- cleanType (GHC.idType id)
1192 printForUser $ ppr id <> text " :: " <> ppr ty'
1193 showTyThing _ = return ()
1195 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1196 cleanType :: Type -> GHCi Type
1198 dflags <- getDynFlags
1199 if dopt Opt_GlasgowExts dflags
1201 else return $! GHC.dropForAlls ty
1203 showBkptTable :: GHCi ()
1206 printForUser $ prettyLocations (breaks st)
1208 showContext :: GHCi ()
1210 session <- getSession
1211 resumes <- io $ GHC.getResumeContext session
1212 printForUser $ vcat (map pp_resume (reverse resumes))
1215 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1216 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1219 -- -----------------------------------------------------------------------------
1222 completeNone :: String -> IO [String]
1223 completeNone w = return []
1226 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1227 completeWord w start end = do
1228 line <- Readline.getLineBuffer
1230 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1232 | Just c <- is_cmd line -> do
1233 maybe_cmd <- lookupCommand c
1234 let (n,w') = selectWord (words' 0 line)
1236 Nothing -> return Nothing
1237 Just (_,_,False,complete) -> wrapCompleter complete w
1238 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1239 return (map (drop n) rets)
1240 in wrapCompleter complete' w'
1242 --printf "complete %s, start = %d, end = %d\n" w start end
1243 wrapCompleter completeIdentifier w
1244 where words' _ [] = []
1245 words' n str = let (w,r) = break isSpace str
1246 (s,r') = span isSpace r
1247 in (n,w):words' (n+length w+length s) r'
1248 -- In a Haskell expression we want to parse 'a-b' as three words
1249 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1250 -- only be a single word.
1251 selectWord [] = (0,w)
1252 selectWord ((offset,x):xs)
1253 | offset+length x >= start = (start-offset,take (end-offset) x)
1254 | otherwise = selectWord xs
1257 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1258 | otherwise = Nothing
1261 cmds <- readIORef commands
1262 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1264 completeMacro w = do
1265 cmds <- readIORef commands
1266 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1267 return (filter (w `isPrefixOf`) cmds')
1269 completeIdentifier w = do
1271 rdrs <- GHC.getRdrNamesInScope s
1272 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1274 completeModule w = do
1276 dflags <- GHC.getSessionDynFlags s
1277 let pkg_mods = allExposedModules dflags
1278 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1280 completeHomeModule w = do
1282 g <- GHC.getModuleGraph s
1283 let home_mods = map GHC.ms_mod_name g
1284 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1286 completeSetOptions w = do
1287 return (filter (w `isPrefixOf`) options)
1288 where options = "args":"prog":allFlags
1290 completeFilename = Readline.filenameCompletionFunction
1292 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1294 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1295 unionComplete f1 f2 w = do
1300 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1301 wrapCompleter fun w = do
1304 [] -> return Nothing
1305 [x] -> return (Just (x,[]))
1306 xs -> case getCommonPrefix xs of
1307 "" -> return (Just ("",xs))
1308 pref -> return (Just (pref,xs))
1310 getCommonPrefix :: [String] -> String
1311 getCommonPrefix [] = ""
1312 getCommonPrefix (s:ss) = foldl common s ss
1313 where common s "" = ""
1315 common (c:cs) (d:ds)
1316 | c == d = c : common cs ds
1319 allExposedModules :: DynFlags -> [ModuleName]
1320 allExposedModules dflags
1321 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1323 pkg_db = pkgIdMap (pkgState dflags)
1325 completeCmd = completeNone
1326 completeMacro = completeNone
1327 completeIdentifier = completeNone
1328 completeModule = completeNone
1329 completeHomeModule = completeNone
1330 completeSetOptions = completeNone
1331 completeFilename = completeNone
1332 completeHomeModuleOrFile=completeNone
1333 completeBkpt = completeNone
1336 -- ---------------------------------------------------------------------------
1337 -- User code exception handling
1339 -- This is the exception handler for exceptions generated by the
1340 -- user's code and exceptions coming from children sessions;
1341 -- it normally just prints out the exception. The
1342 -- handler must be recursive, in case showing the exception causes
1343 -- more exceptions to be raised.
1345 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1346 -- raising another exception. We therefore don't put the recursive
1347 -- handler arond the flushing operation, so if stderr is closed
1348 -- GHCi will just die gracefully rather than going into an infinite loop.
1349 handler :: Exception -> GHCi Bool
1351 handler exception = do
1353 io installSignalHandlers
1354 ghciHandle handler (showException exception >> return False)
1356 showException (DynException dyn) =
1357 case fromDynamic dyn of
1358 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1359 Just Interrupted -> io (putStrLn "Interrupted.")
1360 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1361 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1362 Just other_ghc_ex -> io (print other_ghc_ex)
1364 showException other_exception
1365 = io (putStrLn ("*** Exception: " ++ show other_exception))
1367 -----------------------------------------------------------------------------
1368 -- recursive exception handlers
1370 -- Don't forget to unblock async exceptions in the handler, or if we're
1371 -- in an exception loop (eg. let a = error a in a) the ^C exception
1372 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1374 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1375 ghciHandle h (GHCi m) = GHCi $ \s ->
1376 Exception.catch (m s)
1377 (\e -> unGHCi (ghciUnblock (h e)) s)
1379 ghciUnblock :: GHCi a -> GHCi a
1380 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1383 -- ----------------------------------------------------------------------------
1386 expandPath :: String -> GHCi String
1388 case dropWhile isSpace path of
1390 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1391 return (tilde ++ '/':d)
1395 wantInterpretedModule :: String -> GHCi Module
1396 wantInterpretedModule str = do
1397 session <- getSession
1398 modl <- lookupModule str
1399 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1400 when (not is_interpreted) $
1401 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1404 wantNameFromInterpretedModule noCanDo str and_then = do
1405 session <- getSession
1406 names <- io $ GHC.parseName session str
1410 let modl = GHC.nameModule n
1411 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1412 if not is_interpreted
1413 then noCanDo n $ text "module " <> ppr modl <>
1414 text " is not interpreted"
1417 -- ----------------------------------------------------------------------------
1418 -- Windows console setup
1420 setUpConsole :: IO ()
1422 #ifdef mingw32_HOST_OS
1423 -- On Windows we need to set a known code page, otherwise the characters
1424 -- we read from the console will be be in some strange encoding, and
1425 -- similarly for characters we write to the console.
1427 -- At the moment, GHCi pretends all input is Latin-1. In the
1428 -- future we should support UTF-8, but for now we set the code pages
1431 -- It seems you have to set the font in the console window to
1432 -- a Unicode font in order for output to work properly,
1433 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1434 -- (see MSDN for SetConsoleOutputCP()).
1436 setConsoleCP 28591 -- ISO Latin-1
1437 setConsoleOutputCP 28591 -- ISO Latin-1
1441 -- -----------------------------------------------------------------------------
1442 -- commands for debugger
1444 sprintCmd = pprintCommand False False
1445 printCmd = pprintCommand True False
1446 forceCmd = pprintCommand False True
1448 pprintCommand bind force str = do
1449 session <- getSession
1450 io $ pprintClosureCommand session bind force str
1452 stepCmd :: String -> GHCi ()
1453 stepCmd [] = doContinue GHC.SingleStep
1454 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1456 traceCmd :: String -> GHCi ()
1457 traceCmd [] = doContinue GHC.RunAndLogSteps
1458 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1460 continueCmd :: String -> GHCi ()
1461 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1463 doContinue :: SingleStep -> GHCi ()
1464 doContinue step = do
1465 session <- getSession
1466 runResult <- io $ GHC.resume session step
1467 afterRunStmt runResult
1470 abandonCmd :: String -> GHCi ()
1471 abandonCmd = noArgs $ do
1473 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1474 when (not b) $ io $ putStrLn "There is no computation running."
1477 deleteCmd :: String -> GHCi ()
1478 deleteCmd argLine = do
1479 deleteSwitch $ words argLine
1481 deleteSwitch :: [String] -> GHCi ()
1483 io $ putStrLn "The delete command requires at least one argument."
1484 -- delete all break points
1485 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1486 deleteSwitch idents = do
1487 mapM_ deleteOneBreak idents
1489 deleteOneBreak :: String -> GHCi ()
1491 | all isDigit str = deleteBreak (read str)
1492 | otherwise = return ()
1494 historyCmd :: String -> GHCi ()
1496 | null arg = history 20
1497 | all isDigit arg = history (read arg)
1498 | otherwise = io $ putStrLn "Syntax: :history [num]"
1502 resumes <- io $ GHC.getResumeContext s
1504 [] -> io $ putStrLn "Not stopped at a breakpoint"
1506 let hist = GHC.resumeHistory r
1507 (took,rest) = splitAt num hist
1508 spans <- mapM (io . GHC.getHistorySpan s) took
1509 let nums = map (printf "-%-3d:") [(1::Int)..]
1510 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1511 io $ putStrLn $ if null rest then "<end of history>" else "..."
1513 backCmd :: String -> GHCi ()
1514 backCmd = noArgs $ do
1516 (names, ix, span) <- io $ GHC.back s
1517 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1518 mapM_ (showTypeOfName s) names
1519 -- run the command set with ":set stop <cmd>"
1521 runCommand (stop st)
1524 forwardCmd :: String -> GHCi ()
1525 forwardCmd = noArgs $ do
1527 (names, ix, span) <- io $ GHC.forward s
1528 printForUser $ (if (ix == 0)
1529 then ptext SLIT("Stopped at")
1530 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1531 mapM_ (showTypeOfName s) names
1532 -- run the command set with ":set stop <cmd>"
1534 runCommand (stop st)
1537 -- handle the "break" command
1538 breakCmd :: String -> GHCi ()
1539 breakCmd argLine = do
1540 session <- getSession
1541 breakSwitch session $ words argLine
1543 breakSwitch :: Session -> [String] -> GHCi ()
1544 breakSwitch _session [] = do
1545 io $ putStrLn "The break command requires at least one argument."
1546 breakSwitch session args@(arg1:rest)
1547 | looksLikeModuleName arg1 = do
1548 mod <- wantInterpretedModule arg1
1549 breakByModule session mod rest
1550 | all isDigit arg1 = do
1551 (toplevel, _) <- io $ GHC.getContext session
1553 (mod : _) -> breakByModuleLine mod (read arg1) rest
1555 io $ putStrLn "Cannot find default module for breakpoint."
1556 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1557 | otherwise = do -- try parsing it as an identifier
1558 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1559 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1560 if GHC.isGoodSrcLoc loc
1561 then findBreakAndSet (GHC.nameModule name) $
1562 findBreakByCoord (Just (GHC.srcLocFile loc))
1563 (GHC.srcLocLine loc,
1565 else noCanDo name $ text "can't find its location: " <> ppr loc
1567 noCanDo n why = printForUser $
1568 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1570 breakByModule :: Session -> Module -> [String] -> GHCi ()
1571 breakByModule session mod args@(arg1:rest)
1572 | all isDigit arg1 = do -- looks like a line number
1573 breakByModuleLine mod (read arg1) rest
1574 | otherwise = io $ putStrLn "Invalid arguments to :break"
1576 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1577 breakByModuleLine mod line args
1578 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1579 | [col] <- args, all isDigit col =
1580 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1581 | otherwise = io $ putStrLn "Invalid arguments to :break"
1583 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1584 findBreakAndSet mod lookupTickTree = do
1585 tickArray <- getTickArray mod
1586 (breakArray, _) <- getModBreak mod
1587 case lookupTickTree tickArray of
1588 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1589 Just (tick, span) -> do
1590 success <- io $ setBreakFlag True breakArray tick
1591 session <- getSession
1595 recordBreak $ BreakLocation
1601 text "Breakpoint " <> ppr nm <>
1603 then text " was already set at " <> ppr span
1604 else text " activated at " <> ppr span
1606 printForUser $ text "Breakpoint could not be activated at"
1609 -- When a line number is specified, the current policy for choosing
1610 -- the best breakpoint is this:
1611 -- - the leftmost complete subexpression on the specified line, or
1612 -- - the leftmost subexpression starting on the specified line, or
1613 -- - the rightmost subexpression enclosing the specified line
1615 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1616 findBreakByLine line arr
1617 | not (inRange (bounds arr) line) = Nothing
1619 listToMaybe (sortBy leftmost_largest complete) `mplus`
1620 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1621 listToMaybe (sortBy rightmost ticks)
1625 starts_here = [ tick | tick@(nm,span) <- ticks,
1626 GHC.srcSpanStartLine span == line ]
1628 (complete,incomplete) = partition ends_here starts_here
1629 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1631 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1632 -> Maybe (BreakIndex,SrcSpan)
1633 findBreakByCoord mb_file (line, col) arr
1634 | not (inRange (bounds arr) line) = Nothing
1636 listToMaybe (sortBy rightmost contains)
1640 -- the ticks that span this coordinate
1641 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1642 is_correct_file span ]
1644 is_correct_file span
1645 | Just f <- mb_file = GHC.srcSpanFile span == f
1649 leftmost_smallest (_,a) (_,b) = a `compare` b
1650 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1652 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1653 rightmost (_,a) (_,b) = b `compare` a
1655 spans :: SrcSpan -> (Int,Int) -> Bool
1656 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1657 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1659 start_bold = BS.pack "\ESC[1m"
1660 end_bold = BS.pack "\ESC[0m"
1662 listCmd :: String -> GHCi ()
1664 mb_span <- getCurrentBreakSpan
1666 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1667 Just span -> io $ listAround span True
1668 listCmd str = list2 (words str)
1670 list2 [arg] | all isDigit arg = do
1671 session <- getSession
1672 (toplevel, _) <- io $ GHC.getContext session
1674 [] -> io $ putStrLn "No module to list"
1675 (mod : _) -> listModuleLine mod (read arg)
1676 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1677 mod <- wantInterpretedModule arg1
1678 listModuleLine mod (read arg2)
1680 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1681 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1682 if GHC.isGoodSrcLoc loc
1684 tickArray <- getTickArray (GHC.nameModule name)
1685 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1686 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1689 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1690 Just (_,span) -> io $ listAround span False
1692 noCanDo name $ text "can't find its location: " <>
1695 noCanDo n why = printForUser $
1696 text "cannot list source code for " <> ppr n <> text ": " <> why
1698 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1700 listModuleLine :: Module -> Int -> GHCi ()
1701 listModuleLine modl line = do
1702 session <- getSession
1703 graph <- io (GHC.getModuleGraph session)
1704 let this = filter ((== modl) . GHC.ms_mod) graph
1706 [] -> panic "listModuleLine"
1708 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1709 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1710 io $ listAround (GHC.srcLocSpan loc) False
1712 -- | list a section of a source file around a particular SrcSpan.
1713 -- If the highlight flag is True, also highlight the span using
1714 -- start_bold/end_bold.
1715 listAround span do_highlight = do
1716 contents <- BS.readFile (unpackFS file)
1718 lines = BS.split '\n' contents
1719 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1720 drop (line1 - 1 - pad_before) $ lines
1721 fst_line = max 1 (line1 - pad_before)
1722 line_nos = [ fst_line .. ]
1724 highlighted | do_highlight = zipWith highlight line_nos these_lines
1725 | otherwise = these_lines
1727 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1728 prefixed = zipWith BS.append bs_line_nos highlighted
1730 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1732 file = GHC.srcSpanFile span
1733 line1 = GHC.srcSpanStartLine span
1734 col1 = GHC.srcSpanStartCol span
1735 line2 = GHC.srcSpanEndLine span
1736 col2 = GHC.srcSpanEndCol span
1738 pad_before | line1 == 1 = 0
1743 | no == line1 && no == line2
1744 = let (a,r) = BS.splitAt col1 line
1745 (b,c) = BS.splitAt (col2-col1) r
1747 BS.concat [a,start_bold,b,end_bold,c]
1749 = let (a,b) = BS.splitAt col1 line in
1750 BS.concat [a, start_bold, b]
1752 = let (a,b) = BS.splitAt col2 line in
1753 BS.concat [a, end_bold, b]
1756 -- --------------------------------------------------------------------------
1759 getTickArray :: Module -> GHCi TickArray
1760 getTickArray modl = do
1762 let arrmap = tickarrays st
1763 case lookupModuleEnv arrmap modl of
1764 Just arr -> return arr
1766 (breakArray, ticks) <- getModBreak modl
1767 let arr = mkTickArray (assocs ticks)
1768 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1771 discardTickArrays :: GHCi ()
1772 discardTickArrays = do
1774 setGHCiState st{tickarrays = emptyModuleEnv}
1776 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1778 = accumArray (flip (:)) [] (1, max_line)
1779 [ (line, (nm,span)) | (nm,span) <- ticks,
1780 line <- srcSpanLines span ]
1782 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1783 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1784 GHC.srcSpanEndLine span ]
1786 lookupModule :: String -> GHCi Module
1787 lookupModule modName
1788 = do session <- getSession
1789 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1791 -- don't reset the counter back to zero?
1792 discardActiveBreakPoints :: GHCi ()
1793 discardActiveBreakPoints = do
1795 mapM (turnOffBreak.snd) (breaks st)
1796 setGHCiState $ st { breaks = [] }
1798 deleteBreak :: Int -> GHCi ()
1799 deleteBreak identity = do
1801 let oldLocations = breaks st
1802 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1804 then printForUser (text "Breakpoint" <+> ppr identity <+>
1805 text "does not exist")
1807 mapM (turnOffBreak.snd) this
1808 setGHCiState $ st { breaks = rest }
1810 turnOffBreak loc = do
1811 (arr, _) <- getModBreak (breakModule loc)
1812 io $ setBreakFlag False arr (breakTick loc)
1814 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1815 getModBreak mod = do
1816 session <- getSession
1817 Just mod_info <- io $ GHC.getModuleInfo session mod
1818 let modBreaks = GHC.modInfoModBreaks mod_info
1819 let array = GHC.modBreaks_flags modBreaks
1820 let ticks = GHC.modBreaks_locs modBreaks
1821 return (array, ticks)
1823 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1824 setBreakFlag toggle array index
1825 | toggle = GHC.setBreakOn array index
1826 | otherwise = GHC.setBreakOff array index