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
555 return (isRunResultOk result)
558 afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
559 afterRunStmt run_result = do
560 mb_result <- switchOnRunResult run_result
561 -- possibly print the type and revert CAFs after evaluating an expression
562 show_types <- isOptionSet ShowType
563 session <- getSession
566 Just (is_break,names) ->
567 when (is_break || show_types) $
568 mapM_ (showTypeOfName session) names
571 io installSignalHandlers
572 b <- isOptionSet RevertCAFs
573 io (when b revertCAFs)
578 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
579 switchOnRunResult GHC.RunFailed = return Nothing
580 switchOnRunResult (GHC.RunException e) = throw e
581 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
582 switchOnRunResult (GHC.RunBreak threadId names info) = do
583 session <- getSession
584 Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
585 let modBreaks = GHC.modInfoModBreaks mod_info
586 let ticks = GHC.modBreaks_locs modBreaks
588 -- display information about the breakpoint
589 let location = ticks ! GHC.breakInfo_number info
590 printForUser $ ptext SLIT("Stopped at") <+> ppr location
592 -- run the command set with ":set stop <cmd>"
596 return (Just (True,names))
599 isRunResultOk :: GHC.RunResult -> Bool
600 isRunResultOk (GHC.RunOk _) = True
601 isRunResultOk _ = False
604 showTypeOfName :: Session -> Name -> GHCi ()
605 showTypeOfName session n
606 = do maybe_tything <- io (GHC.lookupName session n)
607 case maybe_tything of
609 Just thing -> showTyThing thing
611 specialCommand :: String -> GHCi Bool
612 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
613 specialCommand str = do
614 let (cmd,rest) = break isSpace str
615 maybe_cmd <- io (lookupCommand cmd)
617 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
618 ++ shortHelpText) >> return False)
619 Just (_,f,_,_) -> f (dropWhile isSpace rest)
621 lookupCommand :: String -> IO (Maybe Command)
622 lookupCommand str = do
623 cmds <- readIORef commands
624 -- look for exact match first, then the first prefix match
625 case [ c | c <- cmds, str == cmdName c ] of
626 c:_ -> return (Just c)
627 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
629 c:_ -> return (Just c)
632 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
633 getCurrentBreakSpan = do
634 session <- getSession
635 resumes <- io $ GHC.getResumeContext session
639 let ix = GHC.resumeHistoryIx r
641 then return (Just (GHC.resumeSpan r))
643 let hist = GHC.resumeHistory r !! (ix-1)
644 span <- io $ GHC.getHistorySpan session hist
647 -----------------------------------------------------------------------------
650 noArgs :: GHCi () -> String -> GHCi ()
652 noArgs m _ = io $ putStrLn "This command takes no arguments"
654 help :: String -> GHCi ()
655 help _ = io (putStr helpText)
657 info :: String -> GHCi ()
658 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
659 info s = do { let names = words s
660 ; session <- getSession
661 ; dflags <- getDynFlags
662 ; let exts = dopt Opt_GlasgowExts dflags
663 ; mapM_ (infoThing exts session) names }
665 infoThing exts session str = io $ do
666 names <- GHC.parseName session str
667 let filtered = filterOutChildren names
668 mb_stuffs <- mapM (GHC.getInfo session) filtered
669 unqual <- GHC.getPrintUnqual session
670 putStrLn (showSDocForUser unqual $
671 vcat (intersperse (text "") $
672 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
674 -- Filter out names whose parent is also there Good
675 -- example is '[]', which is both a type and data
676 -- constructor in the same type
677 filterOutChildren :: [Name] -> [Name]
678 filterOutChildren names = filter (not . parent_is_there) names
679 where parent_is_there n
680 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
684 pprInfo exts (thing, fixity, insts)
685 = pprTyThingInContextLoc exts thing
686 $$ show_fixity fixity
687 $$ vcat (map GHC.pprInstance insts)
690 | fix == GHC.defaultFixity = empty
691 | otherwise = ppr fix <+> ppr (GHC.getName thing)
693 runMain :: String -> GHCi ()
695 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
696 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
699 addModule :: [FilePath] -> GHCi ()
701 io (revertCAFs) -- always revert CAFs on load/add.
702 files <- mapM expandPath files
703 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
704 session <- getSession
705 io (mapM_ (GHC.addTarget session) targets)
706 ok <- io (GHC.load session LoadAllTargets)
709 changeDirectory :: String -> GHCi ()
710 changeDirectory dir = do
711 session <- getSession
712 graph <- io (GHC.getModuleGraph session)
713 when (not (null graph)) $
714 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
715 io (GHC.setTargets session [])
716 io (GHC.load session LoadAllTargets)
717 setContextAfterLoad session []
718 io (GHC.workingDirectoryChanged session)
719 dir <- expandPath dir
720 io (setCurrentDirectory dir)
722 editFile :: String -> GHCi ()
725 -- find the name of the "topmost" file loaded
726 session <- getSession
727 graph0 <- io (GHC.getModuleGraph session)
728 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
729 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
730 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
731 Just file -> do_edit file
732 Nothing -> throwDyn (CmdLineError "unknown file name")
733 | otherwise = do_edit str
739 throwDyn (CmdLineError "editor not set, use :set editor")
740 io $ system (cmd ++ ' ':file)
743 defineMacro :: String -> GHCi ()
745 let (macro_name, definition) = break isSpace s
746 cmds <- io (readIORef commands)
748 then throwDyn (CmdLineError "invalid macro name")
750 if (macro_name `elem` map cmdName cmds)
751 then throwDyn (CmdLineError
752 ("command '" ++ macro_name ++ "' is already defined"))
755 -- give the expression a type signature, so we can be sure we're getting
756 -- something of the right type.
757 let new_expr = '(' : definition ++ ") :: String -> IO String"
759 -- compile the expression
761 maybe_hv <- io (GHC.compileExpr cms new_expr)
764 Just hv -> io (writeIORef commands --
765 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
767 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
769 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
770 stringLoop (lines str)
772 undefineMacro :: String -> GHCi ()
773 undefineMacro macro_name = do
774 cmds <- io (readIORef commands)
775 if (macro_name `elem` map cmdName builtin_commands)
776 then throwDyn (CmdLineError
777 ("command '" ++ macro_name ++ "' cannot be undefined"))
779 if (macro_name `notElem` map cmdName cmds)
780 then throwDyn (CmdLineError
781 ("command '" ++ macro_name ++ "' not defined"))
783 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
786 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
787 loadModule fs = timeIt (loadModule' fs)
789 loadModule_ :: [FilePath] -> GHCi ()
790 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
792 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
793 loadModule' files = do
794 session <- getSession
797 discardActiveBreakPoints
798 io (GHC.setTargets session [])
799 io (GHC.load session LoadAllTargets)
802 let (filenames, phases) = unzip files
803 exp_filenames <- mapM expandPath filenames
804 let files' = zip exp_filenames phases
805 targets <- io (mapM (uncurry GHC.guessTarget) files')
807 -- NOTE: we used to do the dependency anal first, so that if it
808 -- fails we didn't throw away the current set of modules. This would
809 -- require some re-working of the GHC interface, so we'll leave it
810 -- as a ToDo for now.
812 io (GHC.setTargets session targets)
813 doLoad session LoadAllTargets
815 checkModule :: String -> GHCi ()
817 let modl = GHC.mkModuleName m
818 session <- getSession
819 result <- io (GHC.checkModule session modl)
821 Nothing -> io $ putStrLn "Nothing"
822 Just r -> io $ putStrLn (showSDoc (
823 case GHC.checkedModuleInfo r of
824 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
826 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
828 (text "global names: " <+> ppr global) $$
829 (text "local names: " <+> ppr local)
831 afterLoad (successIf (isJust result)) session
833 reloadModule :: String -> GHCi ()
835 io (revertCAFs) -- always revert CAFs on reload.
836 discardActiveBreakPoints
837 session <- getSession
838 doLoad session LoadAllTargets
841 io (revertCAFs) -- always revert CAFs on reload.
842 discardActiveBreakPoints
843 session <- getSession
844 doLoad session (LoadUpTo (GHC.mkModuleName m))
847 doLoad session howmuch = do
848 -- turn off breakpoints before we load: we can't turn them off later, because
849 -- the ModBreaks will have gone away.
850 discardActiveBreakPoints
851 ok <- io (GHC.load session howmuch)
855 afterLoad ok session = do
856 io (revertCAFs) -- always revert CAFs on load.
858 graph <- io (GHC.getModuleGraph session)
859 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
860 setContextAfterLoad session graph'
861 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
863 setContextAfterLoad session [] = do
864 prel_mod <- getPrelude
865 io (GHC.setContext session [] [prel_mod])
866 setContextAfterLoad session ms = do
867 -- load a target if one is available, otherwise load the topmost module.
868 targets <- io (GHC.getTargets session)
869 case [ m | Just m <- map (findTarget ms) targets ] of
871 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
872 load_this (last graph')
877 = case filter (`matches` t) ms of
881 summary `matches` Target (TargetModule m) _
882 = GHC.ms_mod_name summary == m
883 summary `matches` Target (TargetFile f _) _
884 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
885 summary `matches` target
888 load_this summary | m <- GHC.ms_mod summary = do
889 b <- io (GHC.moduleIsInterpreted session m)
890 if b then io (GHC.setContext session [m] [])
892 prel_mod <- getPrelude
893 io (GHC.setContext session [] [prel_mod,m])
896 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
897 modulesLoadedMsg ok mods = do
898 dflags <- getDynFlags
899 when (verbosity dflags > 0) $ do
901 | null mods = text "none."
903 punctuate comma (map ppr mods)) <> text "."
906 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
908 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
911 typeOfExpr :: String -> GHCi ()
913 = do cms <- getSession
914 maybe_ty <- io (GHC.exprType cms str)
917 Just ty -> do ty' <- cleanType ty
918 printForUser $ text str <> text " :: " <> ppr ty'
920 kindOfType :: String -> GHCi ()
922 = do cms <- getSession
923 maybe_ty <- io (GHC.typeKind cms str)
926 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
928 quit :: String -> GHCi Bool
931 shellEscape :: String -> GHCi Bool
932 shellEscape str = io (system str >> return False)
934 -----------------------------------------------------------------------------
935 -- Browsing a module's contents
937 browseCmd :: String -> GHCi ()
940 ['*':m] | looksLikeModuleName m -> browseModule m False
941 [m] | looksLikeModuleName m -> browseModule m True
942 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
944 browseModule m exports_only = do
946 modl <- if exports_only then lookupModule m
947 else wantInterpretedModule m
949 -- Temporarily set the context to the module we're interested in,
950 -- just so we can get an appropriate PrintUnqualified
951 (as,bs) <- io (GHC.getContext s)
952 prel_mod <- getPrelude
953 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
954 else GHC.setContext s [modl] [])
955 unqual <- io (GHC.getPrintUnqual s)
956 io (GHC.setContext s as bs)
958 mb_mod_info <- io $ GHC.getModuleInfo s modl
960 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
963 | exports_only = GHC.modInfoExports mod_info
964 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
966 filtered = filterOutChildren names
968 things <- io $ mapM (GHC.lookupName s) filtered
970 dflags <- getDynFlags
971 let exts = dopt Opt_GlasgowExts dflags
972 io (putStrLn (showSDocForUser unqual (
973 vcat (map (pprTyThingInContext exts) (catMaybes things))
975 -- ToDo: modInfoInstances currently throws an exception for
976 -- package modules. When it works, we can do this:
977 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
979 -----------------------------------------------------------------------------
980 -- Setting the module context
983 | all sensible mods = fn mods
984 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
986 (fn, mods) = case str of
987 '+':stuff -> (addToContext, words stuff)
988 '-':stuff -> (removeFromContext, words stuff)
989 stuff -> (newContext, words stuff)
991 sensible ('*':m) = looksLikeModuleName m
992 sensible m = looksLikeModuleName m
994 separate :: Session -> [String] -> [Module] -> [Module]
995 -> GHCi ([Module],[Module])
996 separate session [] as bs = return (as,bs)
997 separate session (('*':str):ms) as bs = do
998 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
999 b <- io $ GHC.moduleIsInterpreted session m
1000 if b then separate session ms (m:as) bs
1001 else throwDyn (CmdLineError ("module '"
1002 ++ GHC.moduleNameString (GHC.moduleName m)
1003 ++ "' is not interpreted"))
1004 separate session (str:ms) as bs = do
1005 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1006 separate session ms as (m:bs)
1008 newContext :: [String] -> GHCi ()
1009 newContext strs = do
1011 (as,bs) <- separate s strs [] []
1012 prel_mod <- getPrelude
1013 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1014 io $ GHC.setContext s as bs'
1017 addToContext :: [String] -> GHCi ()
1018 addToContext strs = do
1020 (as,bs) <- io $ GHC.getContext s
1022 (new_as,new_bs) <- separate s strs [] []
1024 let as_to_add = new_as \\ (as ++ bs)
1025 bs_to_add = new_bs \\ (as ++ bs)
1027 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1030 removeFromContext :: [String] -> GHCi ()
1031 removeFromContext strs = do
1033 (as,bs) <- io $ GHC.getContext s
1035 (as_to_remove,bs_to_remove) <- separate s strs [] []
1037 let as' = as \\ (as_to_remove ++ bs_to_remove)
1038 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1040 io $ GHC.setContext s as' bs'
1042 ----------------------------------------------------------------------------
1045 -- set options in the interpreter. Syntax is exactly the same as the
1046 -- ghc command line, except that certain options aren't available (-C,
1049 -- This is pretty fragile: most options won't work as expected. ToDo:
1050 -- figure out which ones & disallow them.
1052 setCmd :: String -> GHCi ()
1054 = do st <- getGHCiState
1055 let opts = options st
1056 io $ putStrLn (showSDoc (
1057 text "options currently set: " <>
1060 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1063 = case toArgs str of
1064 ("args":args) -> setArgs args
1065 ("prog":prog) -> setProg prog
1066 ("prompt":prompt) -> setPrompt (after 6)
1067 ("editor":cmd) -> setEditor (after 6)
1068 ("stop":cmd) -> setStop (after 4)
1069 wds -> setOptions wds
1070 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1074 setGHCiState st{ args = args }
1078 setGHCiState st{ progname = prog }
1080 io (hPutStrLn stderr "syntax: :set prog <progname>")
1084 setGHCiState st{ editor = cmd }
1088 setGHCiState st{ stop = cmd }
1090 setPrompt value = do
1093 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1094 else setGHCiState st{ prompt = remQuotes value }
1096 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1100 do -- first, deal with the GHCi opts (+s, +t, etc.)
1101 let (plus_opts, minus_opts) = partition isPlus wds
1102 mapM_ setOpt plus_opts
1103 -- then, dynamic flags
1104 newDynFlags minus_opts
1106 newDynFlags minus_opts = do
1107 dflags <- getDynFlags
1108 let pkg_flags = packageFlags dflags
1109 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1111 if (not (null leftovers))
1112 then throwDyn (CmdLineError ("unrecognised flags: " ++
1116 new_pkgs <- setDynFlags dflags'
1118 -- if the package flags changed, we should reset the context
1119 -- and link the new packages.
1120 dflags <- getDynFlags
1121 when (packageFlags dflags /= pkg_flags) $ do
1122 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1123 session <- getSession
1124 io (GHC.setTargets session [])
1125 io (GHC.load session LoadAllTargets)
1126 io (linkPackages dflags new_pkgs)
1127 setContextAfterLoad session []
1131 unsetOptions :: String -> GHCi ()
1133 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1134 let opts = words str
1135 (minus_opts, rest1) = partition isMinus opts
1136 (plus_opts, rest2) = partition isPlus rest1
1138 if (not (null rest2))
1139 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1142 mapM_ unsetOpt plus_opts
1144 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1145 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1147 no_flags <- mapM no_flag minus_opts
1148 newDynFlags no_flags
1150 isMinus ('-':s) = True
1153 isPlus ('+':s) = True
1157 = case strToGHCiOpt str of
1158 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1159 Just o -> setOption o
1162 = case strToGHCiOpt str of
1163 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1164 Just o -> unsetOption o
1166 strToGHCiOpt :: String -> (Maybe GHCiOption)
1167 strToGHCiOpt "s" = Just ShowTiming
1168 strToGHCiOpt "t" = Just ShowType
1169 strToGHCiOpt "r" = Just RevertCAFs
1170 strToGHCiOpt _ = Nothing
1172 optToStr :: GHCiOption -> String
1173 optToStr ShowTiming = "s"
1174 optToStr ShowType = "t"
1175 optToStr RevertCAFs = "r"
1177 -- ---------------------------------------------------------------------------
1183 ["args"] -> io $ putStrLn (show (args st))
1184 ["prog"] -> io $ putStrLn (show (progname st))
1185 ["prompt"] -> io $ putStrLn (show (prompt st))
1186 ["editor"] -> io $ putStrLn (show (editor st))
1187 ["stop"] -> io $ putStrLn (show (stop st))
1188 ["modules" ] -> showModules
1189 ["bindings"] -> showBindings
1190 ["linker"] -> io showLinkerState
1191 ["breaks"] -> showBkptTable
1192 ["context"] -> showContext
1193 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1196 session <- getSession
1197 let show_one ms = do m <- io (GHC.showModule session ms)
1199 graph <- io (GHC.getModuleGraph session)
1200 mapM_ show_one graph
1204 unqual <- io (GHC.getPrintUnqual s)
1205 bindings <- io (GHC.getBindings s)
1206 mapM_ showTyThing bindings
1209 showTyThing (AnId id) = do
1210 ty' <- cleanType (GHC.idType id)
1211 printForUser $ ppr id <> text " :: " <> ppr ty'
1212 showTyThing _ = return ()
1214 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1215 cleanType :: Type -> GHCi Type
1217 dflags <- getDynFlags
1218 if dopt Opt_GlasgowExts dflags
1220 else return $! GHC.dropForAlls ty
1222 showBkptTable :: GHCi ()
1225 printForUser $ prettyLocations (breaks st)
1227 showContext :: GHCi ()
1229 session <- getSession
1230 resumes <- io $ GHC.getResumeContext session
1231 printForUser $ vcat (map pp_resume (reverse resumes))
1234 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1235 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1238 -- -----------------------------------------------------------------------------
1241 completeNone :: String -> IO [String]
1242 completeNone w = return []
1245 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1246 completeWord w start end = do
1247 line <- Readline.getLineBuffer
1249 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1251 | Just c <- is_cmd line -> do
1252 maybe_cmd <- lookupCommand c
1253 let (n,w') = selectWord (words' 0 line)
1255 Nothing -> return Nothing
1256 Just (_,_,False,complete) -> wrapCompleter complete w
1257 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1258 return (map (drop n) rets)
1259 in wrapCompleter complete' w'
1261 --printf "complete %s, start = %d, end = %d\n" w start end
1262 wrapCompleter completeIdentifier w
1263 where words' _ [] = []
1264 words' n str = let (w,r) = break isSpace str
1265 (s,r') = span isSpace r
1266 in (n,w):words' (n+length w+length s) r'
1267 -- In a Haskell expression we want to parse 'a-b' as three words
1268 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1269 -- only be a single word.
1270 selectWord [] = (0,w)
1271 selectWord ((offset,x):xs)
1272 | offset+length x >= start = (start-offset,take (end-offset) x)
1273 | otherwise = selectWord xs
1276 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1277 | otherwise = Nothing
1280 cmds <- readIORef commands
1281 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1283 completeMacro w = do
1284 cmds <- readIORef commands
1285 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1286 return (filter (w `isPrefixOf`) cmds')
1288 completeIdentifier w = do
1290 rdrs <- GHC.getRdrNamesInScope s
1291 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1293 completeModule w = do
1295 dflags <- GHC.getSessionDynFlags s
1296 let pkg_mods = allExposedModules dflags
1297 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1299 completeHomeModule w = do
1301 g <- GHC.getModuleGraph s
1302 let home_mods = map GHC.ms_mod_name g
1303 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1305 completeSetOptions w = do
1306 return (filter (w `isPrefixOf`) options)
1307 where options = "args":"prog":allFlags
1309 completeFilename = Readline.filenameCompletionFunction
1311 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1313 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1314 unionComplete f1 f2 w = do
1319 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1320 wrapCompleter fun w = do
1323 [] -> return Nothing
1324 [x] -> return (Just (x,[]))
1325 xs -> case getCommonPrefix xs of
1326 "" -> return (Just ("",xs))
1327 pref -> return (Just (pref,xs))
1329 getCommonPrefix :: [String] -> String
1330 getCommonPrefix [] = ""
1331 getCommonPrefix (s:ss) = foldl common s ss
1332 where common s "" = ""
1334 common (c:cs) (d:ds)
1335 | c == d = c : common cs ds
1338 allExposedModules :: DynFlags -> [ModuleName]
1339 allExposedModules dflags
1340 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1342 pkg_db = pkgIdMap (pkgState dflags)
1344 completeCmd = completeNone
1345 completeMacro = completeNone
1346 completeIdentifier = completeNone
1347 completeModule = completeNone
1348 completeHomeModule = completeNone
1349 completeSetOptions = completeNone
1350 completeFilename = completeNone
1351 completeHomeModuleOrFile=completeNone
1352 completeBkpt = completeNone
1355 -- ---------------------------------------------------------------------------
1356 -- User code exception handling
1358 -- This is the exception handler for exceptions generated by the
1359 -- user's code and exceptions coming from children sessions;
1360 -- it normally just prints out the exception. The
1361 -- handler must be recursive, in case showing the exception causes
1362 -- more exceptions to be raised.
1364 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1365 -- raising another exception. We therefore don't put the recursive
1366 -- handler arond the flushing operation, so if stderr is closed
1367 -- GHCi will just die gracefully rather than going into an infinite loop.
1368 handler :: Exception -> GHCi Bool
1370 handler exception = do
1372 io installSignalHandlers
1373 ghciHandle handler (showException exception >> return False)
1375 showException (DynException dyn) =
1376 case fromDynamic dyn of
1377 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1378 Just Interrupted -> io (putStrLn "Interrupted.")
1379 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1380 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1381 Just other_ghc_ex -> io (print other_ghc_ex)
1383 showException other_exception
1384 = io (putStrLn ("*** Exception: " ++ show other_exception))
1386 -----------------------------------------------------------------------------
1387 -- recursive exception handlers
1389 -- Don't forget to unblock async exceptions in the handler, or if we're
1390 -- in an exception loop (eg. let a = error a in a) the ^C exception
1391 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1393 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1394 ghciHandle h (GHCi m) = GHCi $ \s ->
1395 Exception.catch (m s)
1396 (\e -> unGHCi (ghciUnblock (h e)) s)
1398 ghciUnblock :: GHCi a -> GHCi a
1399 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1402 -- ----------------------------------------------------------------------------
1405 expandPath :: String -> GHCi String
1407 case dropWhile isSpace path of
1409 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1410 return (tilde ++ '/':d)
1414 wantInterpretedModule :: String -> GHCi Module
1415 wantInterpretedModule str = do
1416 session <- getSession
1417 modl <- lookupModule str
1418 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1419 when (not is_interpreted) $
1420 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1423 wantNameFromInterpretedModule noCanDo str and_then = do
1424 session <- getSession
1425 names <- io $ GHC.parseName session str
1429 let modl = GHC.nameModule n
1430 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1431 if not is_interpreted
1432 then noCanDo n $ text "module " <> ppr modl <>
1433 text " is not interpreted"
1436 -- ----------------------------------------------------------------------------
1437 -- Windows console setup
1439 setUpConsole :: IO ()
1441 #ifdef mingw32_HOST_OS
1442 -- On Windows we need to set a known code page, otherwise the characters
1443 -- we read from the console will be be in some strange encoding, and
1444 -- similarly for characters we write to the console.
1446 -- At the moment, GHCi pretends all input is Latin-1. In the
1447 -- future we should support UTF-8, but for now we set the code pages
1450 -- It seems you have to set the font in the console window to
1451 -- a Unicode font in order for output to work properly,
1452 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1453 -- (see MSDN for SetConsoleOutputCP()).
1455 setConsoleCP 28591 -- ISO Latin-1
1456 setConsoleOutputCP 28591 -- ISO Latin-1
1460 -- -----------------------------------------------------------------------------
1461 -- commands for debugger
1463 sprintCmd = pprintCommand False False
1464 printCmd = pprintCommand True False
1465 forceCmd = pprintCommand False True
1467 pprintCommand bind force str = do
1468 session <- getSession
1469 io $ pprintClosureCommand session bind force str
1471 stepCmd :: String -> GHCi ()
1472 stepCmd [] = doContinue GHC.SingleStep
1473 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1475 traceCmd :: String -> GHCi ()
1476 traceCmd [] = doContinue GHC.RunAndLogSteps
1477 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1479 continueCmd :: String -> GHCi ()
1480 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1482 doContinue :: SingleStep -> GHCi ()
1483 doContinue step = do
1484 session <- getSession
1485 runResult <- io $ GHC.resume session step
1486 afterRunStmt runResult
1489 abandonCmd :: String -> GHCi ()
1490 abandonCmd = noArgs $ do
1492 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1493 when (not b) $ io $ putStrLn "There is no computation running."
1496 deleteCmd :: String -> GHCi ()
1497 deleteCmd argLine = do
1498 deleteSwitch $ words argLine
1500 deleteSwitch :: [String] -> GHCi ()
1502 io $ putStrLn "The delete command requires at least one argument."
1503 -- delete all break points
1504 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1505 deleteSwitch idents = do
1506 mapM_ deleteOneBreak idents
1508 deleteOneBreak :: String -> GHCi ()
1510 | all isDigit str = deleteBreak (read str)
1511 | otherwise = return ()
1513 historyCmd :: String -> GHCi ()
1515 | null arg = history 20
1516 | all isDigit arg = history (read arg)
1517 | otherwise = io $ putStrLn "Syntax: :history [num]"
1521 resumes <- io $ GHC.getResumeContext s
1523 [] -> io $ putStrLn "Not stopped at a breakpoint"
1525 let hist = GHC.resumeHistory r
1526 (took,rest) = splitAt num hist
1527 spans <- mapM (io . GHC.getHistorySpan s) took
1528 let nums = map (printf "-%-3d:") [(1::Int)..]
1529 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1530 io $ putStrLn $ if null rest then "<end of history>" else "..."
1532 backCmd :: String -> GHCi ()
1533 backCmd = noArgs $ do
1535 (names, ix, span) <- io $ GHC.back s
1536 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1537 mapM_ (showTypeOfName s) names
1538 -- run the command set with ":set stop <cmd>"
1540 runCommand (stop st)
1543 forwardCmd :: String -> GHCi ()
1544 forwardCmd = noArgs $ do
1546 (names, ix, span) <- io $ GHC.forward s
1547 printForUser $ (if (ix == 0)
1548 then ptext SLIT("Stopped at")
1549 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1550 mapM_ (showTypeOfName s) names
1551 -- run the command set with ":set stop <cmd>"
1553 runCommand (stop st)
1556 -- handle the "break" command
1557 breakCmd :: String -> GHCi ()
1558 breakCmd argLine = do
1559 session <- getSession
1560 breakSwitch session $ words argLine
1562 breakSwitch :: Session -> [String] -> GHCi ()
1563 breakSwitch _session [] = do
1564 io $ putStrLn "The break command requires at least one argument."
1565 breakSwitch session args@(arg1:rest)
1566 | looksLikeModuleName arg1 = do
1567 mod <- wantInterpretedModule arg1
1568 breakByModule session mod rest
1569 | all isDigit arg1 = do
1570 (toplevel, _) <- io $ GHC.getContext session
1572 (mod : _) -> breakByModuleLine mod (read arg1) rest
1574 io $ putStrLn "Cannot find default module for breakpoint."
1575 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1576 | otherwise = do -- try parsing it as an identifier
1577 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1578 let loc = GHC.nameSrcLoc name
1579 if GHC.isGoodSrcLoc loc
1580 then findBreakAndSet (GHC.nameModule name) $
1581 findBreakByCoord (Just (GHC.srcLocFile loc))
1582 (GHC.srcLocLine loc,
1584 else noCanDo name $ text "can't find its location: " <> ppr loc
1586 noCanDo n why = printForUser $
1587 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1589 breakByModule :: Session -> Module -> [String] -> GHCi ()
1590 breakByModule session mod args@(arg1:rest)
1591 | all isDigit arg1 = do -- looks like a line number
1592 breakByModuleLine mod (read arg1) rest
1593 | otherwise = io $ putStrLn "Invalid arguments to :break"
1595 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1596 breakByModuleLine mod line args
1597 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1598 | [col] <- args, all isDigit col =
1599 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1600 | otherwise = io $ putStrLn "Invalid arguments to :break"
1602 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1603 findBreakAndSet mod lookupTickTree = do
1604 tickArray <- getTickArray mod
1605 (breakArray, _) <- getModBreak mod
1606 case lookupTickTree tickArray of
1607 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1608 Just (tick, span) -> do
1609 success <- io $ setBreakFlag True breakArray tick
1610 session <- getSession
1614 recordBreak $ BreakLocation
1620 text "Breakpoint " <> ppr nm <>
1622 then text " was already set at " <> ppr span
1623 else text " activated at " <> ppr span
1625 printForUser $ text "Breakpoint could not be activated at"
1628 -- When a line number is specified, the current policy for choosing
1629 -- the best breakpoint is this:
1630 -- - the leftmost complete subexpression on the specified line, or
1631 -- - the leftmost subexpression starting on the specified line, or
1632 -- - the rightmost subexpression enclosing the specified line
1634 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1635 findBreakByLine line arr
1636 | not (inRange (bounds arr) line) = Nothing
1638 listToMaybe (sortBy leftmost_largest complete) `mplus`
1639 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1640 listToMaybe (sortBy rightmost ticks)
1644 starts_here = [ tick | tick@(nm,span) <- ticks,
1645 GHC.srcSpanStartLine span == line ]
1647 (complete,incomplete) = partition ends_here starts_here
1648 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1650 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1651 -> Maybe (BreakIndex,SrcSpan)
1652 findBreakByCoord mb_file (line, col) arr
1653 | not (inRange (bounds arr) line) = Nothing
1655 listToMaybe (sortBy rightmost contains)
1659 -- the ticks that span this coordinate
1660 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1661 is_correct_file span ]
1663 is_correct_file span
1664 | Just f <- mb_file = GHC.srcSpanFile span == f
1668 leftmost_smallest (_,a) (_,b) = a `compare` b
1669 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1671 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1672 rightmost (_,a) (_,b) = b `compare` a
1674 spans :: SrcSpan -> (Int,Int) -> Bool
1675 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1676 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1678 start_bold = BS.pack "\ESC[1m"
1679 end_bold = BS.pack "\ESC[0m"
1681 listCmd :: String -> GHCi ()
1683 mb_span <- getCurrentBreakSpan
1685 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1686 Just span -> io $ listAround span True
1687 listCmd str = list2 (words str)
1689 list2 [arg] | all isDigit arg = do
1690 session <- getSession
1691 (toplevel, _) <- io $ GHC.getContext session
1693 [] -> io $ putStrLn "No module to list"
1694 (mod : _) -> listModuleLine mod (read arg)
1695 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1696 mod <- wantInterpretedModule arg1
1697 listModuleLine mod (read arg2)
1699 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1700 let loc = GHC.nameSrcLoc name
1701 if GHC.isGoodSrcLoc loc
1703 tickArray <- getTickArray (GHC.nameModule name)
1704 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1705 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1708 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1709 Just (_,span) -> io $ listAround span False
1711 noCanDo name $ text "can't find its location: " <>
1714 noCanDo n why = printForUser $
1715 text "cannot list source code for " <> ppr n <> text ": " <> why
1717 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1719 listModuleLine :: Module -> Int -> GHCi ()
1720 listModuleLine modl line = do
1721 session <- getSession
1722 graph <- io (GHC.getModuleGraph session)
1723 let this = filter ((== modl) . GHC.ms_mod) graph
1725 [] -> panic "listModuleLine"
1727 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1728 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1729 io $ listAround (GHC.srcLocSpan loc) False
1731 -- | list a section of a source file around a particular SrcSpan.
1732 -- If the highlight flag is True, also highlight the span using
1733 -- start_bold/end_bold.
1734 listAround span do_highlight = do
1735 contents <- BS.readFile (unpackFS file)
1737 lines = BS.split '\n' contents
1738 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1739 drop (line1 - 1 - pad_before) $ lines
1740 fst_line = max 1 (line1 - pad_before)
1741 line_nos = [ fst_line .. ]
1743 highlighted | do_highlight = zipWith highlight line_nos these_lines
1744 | otherwise = these_lines
1746 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1747 prefixed = zipWith BS.append bs_line_nos highlighted
1749 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1751 file = GHC.srcSpanFile span
1752 line1 = GHC.srcSpanStartLine span
1753 col1 = GHC.srcSpanStartCol span
1754 line2 = GHC.srcSpanEndLine span
1755 col2 = GHC.srcSpanEndCol span
1757 pad_before | line1 == 1 = 0
1762 | no == line1 && no == line2
1763 = let (a,r) = BS.splitAt col1 line
1764 (b,c) = BS.splitAt (col2-col1) r
1766 BS.concat [a,start_bold,b,end_bold,c]
1768 = let (a,b) = BS.splitAt col1 line in
1769 BS.concat [a, start_bold, b]
1771 = let (a,b) = BS.splitAt col2 line in
1772 BS.concat [a, end_bold, b]
1775 -- --------------------------------------------------------------------------
1778 getTickArray :: Module -> GHCi TickArray
1779 getTickArray modl = do
1781 let arrmap = tickarrays st
1782 case lookupModuleEnv arrmap modl of
1783 Just arr -> return arr
1785 (breakArray, ticks) <- getModBreak modl
1786 let arr = mkTickArray (assocs ticks)
1787 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1790 discardTickArrays :: GHCi ()
1791 discardTickArrays = do
1793 setGHCiState st{tickarrays = emptyModuleEnv}
1795 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1797 = accumArray (flip (:)) [] (1, max_line)
1798 [ (line, (nm,span)) | (nm,span) <- ticks,
1799 line <- srcSpanLines span ]
1801 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1802 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1803 GHC.srcSpanEndLine span ]
1805 lookupModule :: String -> GHCi Module
1806 lookupModule modName
1807 = do session <- getSession
1808 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1810 -- don't reset the counter back to zero?
1811 discardActiveBreakPoints :: GHCi ()
1812 discardActiveBreakPoints = do
1814 mapM (turnOffBreak.snd) (breaks st)
1815 setGHCiState $ st { breaks = [] }
1817 deleteBreak :: Int -> GHCi ()
1818 deleteBreak identity = do
1820 let oldLocations = breaks st
1821 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1823 then printForUser (text "Breakpoint" <+> ppr identity <+>
1824 text "does not exist")
1826 mapM (turnOffBreak.snd) this
1827 setGHCiState $ st { breaks = rest }
1829 turnOffBreak loc = do
1830 (arr, _) <- getModBreak (breakModule loc)
1831 io $ setBreakFlag False arr (breakTick loc)
1833 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1834 getModBreak mod = do
1835 session <- getSession
1836 Just mod_info <- io $ GHC.getModuleInfo session mod
1837 let modBreaks = GHC.modInfoModBreaks mod_info
1838 let array = GHC.modBreaks_flags modBreaks
1839 let ticks = GHC.modBreaks_locs modBreaks
1840 return (array, ticks)
1842 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1843 setBreakFlag toggle array index
1844 | toggle = GHC.setBreakOn array index
1845 | otherwise = GHC.setBreakOff array index