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),
140 ("where", keepGoing whereCmd, True, completeNone)
143 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
144 keepGoing a str = a str >> return False
146 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
147 keepGoingPaths a str = a (toArgs str) >> return False
149 shortHelpText = "use :? for help.\n"
152 " Commands available from the prompt:\n" ++
154 " <statement> evaluate/run <statement>\n" ++
155 " :add <filename> ... add module(s) to the current target set\n" ++
156 " :browse [*]<module> display the names defined by <module>\n" ++
157 " :cd <dir> change directory to <dir>\n" ++
158 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
159 " :def <cmd> <expr> define a command :<cmd>\n" ++
160 " :edit <file> edit file\n" ++
161 " :edit edit last module\n" ++
162 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
163 " :help, :? display this list of commands\n" ++
164 " :info [<name> ...] display information about the given names\n" ++
165 " :kind <type> show the kind of <type>\n" ++
166 " :load <filename> ... load module(s) and their dependents\n" ++
167 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
168 " :main [<arguments> ...] run the main function with the given arguments\n" ++
169 " :quit exit GHCi\n" ++
170 " :reload reload the current module set\n" ++
171 " :type <expr> show the type of <expr>\n" ++
172 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
173 " :!<command> run the shell command <command>\n" ++
175 " -- Commands for debugging:\n" ++
177 " :abandon at a breakpoint, abandon current computation\n" ++
178 " :back go back in the history (after :trace)\n" ++
179 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
180 " :break <name> set a breakpoint on the specified function\n" ++
181 " :continue resume after a breakpoint\n" ++
182 " :delete <number> delete the specified breakpoint\n" ++
183 " :delete * delete all breakpoints\n" ++
184 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
185 " :forward go forward in the history (after :back)\n" ++
186 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
187 " :print [<name> ...] prints a value without forcing its computation\n" ++
188 " :step single-step after stopping at a breakpoint\n"++
189 " :step <expr> single-step into <expr>\n"++
190 " :trace trace after stopping at a breakpoint\n"++
191 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
192 " :sprint [<name> ...] simplifed version of :print\n" ++
195 " -- Commands for changing settings:\n" ++
197 " :set <option> ... set options\n" ++
198 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
199 " :set prog <progname> set the value returned by System.getProgName\n" ++
200 " :set prompt <prompt> set the prompt used in GHCi\n" ++
201 " :set editor <cmd> set the command used for :edit\n" ++
202 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
203 " :unset <option> ... unset options\n" ++
205 " Options for ':set' and ':unset':\n" ++
207 " +r revert top-level expressions after each evaluation\n" ++
208 " +s print timing/memory stats after each evaluation\n" ++
209 " +t print type after evaluation\n" ++
210 " -<flags> most GHC command line flags can also be set here\n" ++
211 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
213 " -- Commands for displaying information:\n" ++
215 " :show bindings show the current bindings made at the prompt\n" ++
216 " :show breaks show the active breakpoints\n" ++
217 " :show context show the breakpoint context\n" ++
218 " :show modules show the currently loaded modules\n" ++
219 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
226 win <- System.Win32.getWindowsDirectory
227 return (win `joinFileName` "notepad.exe")
232 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
233 interactiveUI session srcs maybe_expr = do
234 -- HACK! If we happen to get into an infinite loop (eg the user
235 -- types 'let x=x in x' at the prompt), then the thread will block
236 -- on a blackhole, and become unreachable during GC. The GC will
237 -- detect that it is unreachable and send it the NonTermination
238 -- exception. However, since the thread is unreachable, everything
239 -- it refers to might be finalized, including the standard Handles.
240 -- This sounds like a bug, but we don't have a good solution right
246 -- Initialise buffering for the *interpreted* I/O system
247 initInterpBuffering session
249 when (isNothing maybe_expr) $ do
250 -- Only for GHCi (not runghc and ghc -e):
251 -- Turn buffering off for the compiled program's stdout/stderr
253 -- Turn buffering off for GHCi's stdout
255 hSetBuffering stdout NoBuffering
256 -- We don't want the cmd line to buffer any input that might be
257 -- intended for the program, so unbuffer stdin.
258 hSetBuffering stdin NoBuffering
260 -- initial context is just the Prelude
261 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
262 GHC.setContext session [] [prel_mod]
266 Readline.setAttemptedCompletionFunction (Just completeWord)
267 --Readline.parseAndBind "set show-all-if-ambiguous 1"
269 let symbols = "!#$%&*+/<=>?@\\^|-~"
270 specials = "(),;[]`{}"
272 word_break_chars = spaces ++ specials ++ symbols
274 Readline.setBasicWordBreakCharacters word_break_chars
275 Readline.setCompleterWordBreakCharacters word_break_chars
278 default_editor <- findEditor
280 startGHCi (runGHCi srcs maybe_expr)
281 GHCiState{ progname = "<interactive>",
285 editor = default_editor,
291 tickarrays = emptyModuleEnv
295 Readline.resetTerminal Nothing
300 prel_name = GHC.mkModuleName "Prelude"
302 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
303 runGHCi paths maybe_expr = do
304 let read_dot_files = not opt_IgnoreDotGhci
306 when (read_dot_files) $ do
309 exists <- io (doesFileExist file)
311 dir_ok <- io (checkPerms ".")
312 file_ok <- io (checkPerms file)
313 when (dir_ok && file_ok) $ do
314 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
317 Right hdl -> fileLoop hdl False
319 when (read_dot_files) $ do
320 -- Read in $HOME/.ghci
321 either_dir <- io (IO.try (getEnv "HOME"))
325 cwd <- io (getCurrentDirectory)
326 when (dir /= cwd) $ do
327 let file = dir ++ "/.ghci"
328 ok <- io (checkPerms file)
330 either_hdl <- io (IO.try (openFile file ReadMode))
333 Right hdl -> fileLoop hdl False
335 -- Perform a :load for files given on the GHCi command line
336 -- When in -e mode, if the load fails then we want to stop
337 -- immediately rather than going on to evaluate the expression.
338 when (not (null paths)) $ do
339 ok <- ghciHandle (\e -> do showException e; return Failed) $
341 when (isJust maybe_expr && failed ok) $
342 io (exitWith (ExitFailure 1))
344 -- if verbosity is greater than 0, or we are connected to a
345 -- terminal, display the prompt in the interactive loop.
346 is_tty <- io (hIsTerminalDevice stdin)
347 dflags <- getDynFlags
348 let show_prompt = verbosity dflags > 0 || is_tty
353 #if defined(mingw32_HOST_OS)
354 -- The win32 Console API mutates the first character of
355 -- type-ahead when reading from it in a non-buffered manner. Work
356 -- around this by flushing the input buffer of type-ahead characters,
357 -- but only if stdin is available.
358 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
360 Left err | isDoesNotExistError err -> return ()
361 | otherwise -> io (ioError err)
362 Right () -> return ()
364 -- initialise the console if necessary
367 -- enter the interactive loop
368 interactiveLoop is_tty show_prompt
370 -- just evaluate the expression we were given
375 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
378 interactiveLoop is_tty show_prompt =
379 -- Ignore ^C exceptions caught here
380 ghciHandleDyn (\e -> case e of
382 #if defined(mingw32_HOST_OS)
385 interactiveLoop is_tty show_prompt
386 _other -> return ()) $
388 ghciUnblock $ do -- unblock necessary if we recursed from the
389 -- exception handler above.
391 -- read commands from stdin
395 else fileLoop stdin show_prompt
397 fileLoop stdin show_prompt
401 -- NOTE: We only read .ghci files if they are owned by the current user,
402 -- and aren't world writable. Otherwise, we could be accidentally
403 -- running code planted by a malicious third party.
405 -- Furthermore, We only read ./.ghci if . is owned by the current user
406 -- and isn't writable by anyone else. I think this is sufficient: we
407 -- don't need to check .. and ../.. etc. because "." always refers to
408 -- the same directory while a process is running.
410 checkPerms :: String -> IO Bool
412 #ifdef mingw32_HOST_OS
415 Util.handle (\_ -> return False) $ do
416 st <- getFileStatus name
418 if fileOwner st /= me then do
419 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
422 let mode = fileMode st
423 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
424 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
426 putStrLn $ "*** WARNING: " ++ name ++
427 " is writable by someone else, IGNORING!"
432 fileLoop :: Handle -> Bool -> GHCi ()
433 fileLoop hdl show_prompt = do
434 when show_prompt $ do
437 l <- io (IO.try (hGetLine hdl))
439 Left e | isEOFError e -> return ()
440 | InvalidArgument <- etype -> return ()
441 | otherwise -> io (ioError e)
442 where etype = ioeGetErrorType e
443 -- treat InvalidArgument in the same way as EOF:
444 -- this can happen if the user closed stdin, or
445 -- perhaps did getContents which closes stdin at
448 case removeSpaces l of
449 "" -> fileLoop hdl show_prompt
450 l -> do quit <- runCommand l
451 if quit then return () else fileLoop hdl show_prompt
453 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
454 stringLoop [] = return False
455 stringLoop (s:ss) = do
456 case removeSpaces s of
458 l -> do quit <- runCommand l
459 if quit then return True else stringLoop ss
462 session <- getSession
463 (toplevs,exports) <- io (GHC.getContext session)
464 resumes <- io $ GHC.getResumeContext session
470 let ix = GHC.resumeHistoryIx r
472 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
474 let hist = GHC.resumeHistory r !! (ix-1)
475 span <- io $ GHC.getHistorySpan session hist
476 return (brackets (ppr (negate ix) <> char ':'
477 <+> ppr span) <> space)
479 dots | r:rs <- resumes, not (null rs) = text "... "
483 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
484 hsep (map (ppr . GHC.moduleName) exports)
486 deflt_prompt = dots <> context_bit <> modules_bit
488 f ('%':'s':xs) = deflt_prompt <> f xs
489 f ('%':'%':xs) = char '%' <> f xs
490 f (x:xs) = char x <> f xs
494 return (showSDoc (f (prompt st)))
498 readlineLoop :: GHCi ()
500 session <- getSession
501 (mod,imports) <- io (GHC.getContext session)
503 saveSession -- for use by completion
505 mb_span <- getCurrentBreakSpan
507 l <- io (readline prompt `finally` setNonBlockingFD 0)
508 -- readline sometimes puts stdin into blocking mode,
509 -- so we need to put it back for the IO library
514 case removeSpaces l of
519 if quit then return () else readlineLoop
522 runCommand :: String -> GHCi Bool
523 runCommand c = ghciHandle handler (doCommand c)
525 doCommand (':' : command) = specialCommand command
527 = do timeIt $ runStmt stmt GHC.RunToCompletion
530 -- This version is for the GHC command-line option -e. The only difference
531 -- from runCommand is that it catches the ExitException exception and
532 -- exits, rather than printing out the exception.
533 runCommandEval c = ghciHandle handleEval (doCommand c)
535 handleEval (ExitException code) = io (exitWith code)
536 handleEval e = do handler e
537 io (exitWith (ExitFailure 1))
539 doCommand (':' : command) = specialCommand command
541 = do r <- runStmt stmt GHC.RunToCompletion
543 False -> io (exitWith (ExitFailure 1))
544 -- failure to run the command causes exit(1) for ghc -e.
547 runStmt :: String -> SingleStep -> GHCi Bool
549 | null (filter (not.isSpace) stmt) = return False
551 = do st <- getGHCiState
552 session <- getSession
553 result <- io $ withProgName (progname st) $ withArgs (args st) $
554 GHC.runStmt session stmt step
556 return (isRunResultOk result)
559 afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
560 afterRunStmt run_result = do
561 mb_result <- switchOnRunResult run_result
562 -- possibly print the type and revert CAFs after evaluating an expression
563 show_types <- isOptionSet ShowType
564 session <- getSession
567 Just (is_break,names) ->
568 when (is_break || show_types) $
569 mapM_ (showTypeOfName session) names
572 io installSignalHandlers
573 b <- isOptionSet RevertCAFs
574 io (when b revertCAFs)
579 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
580 switchOnRunResult GHC.RunFailed = return Nothing
581 switchOnRunResult (GHC.RunException e) = throw e
582 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
583 switchOnRunResult (GHC.RunBreak threadId names info) = do
584 session <- getSession
585 Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
586 let modBreaks = GHC.modInfoModBreaks mod_info
587 let ticks = GHC.modBreaks_locs modBreaks
589 -- display information about the breakpoint
590 let location = ticks ! GHC.breakInfo_number info
591 printForUser $ ptext SLIT("Stopped at") <+> ppr location
593 -- run the command set with ":set stop <cmd>"
597 return (Just (True,names))
600 isRunResultOk :: GHC.RunResult -> Bool
601 isRunResultOk (GHC.RunOk _) = True
602 isRunResultOk _ = False
605 showTypeOfName :: Session -> Name -> GHCi ()
606 showTypeOfName session n
607 = do maybe_tything <- io (GHC.lookupName session n)
608 case maybe_tything of
610 Just thing -> showTyThing thing
612 specialCommand :: String -> GHCi Bool
613 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
614 specialCommand str = do
615 let (cmd,rest) = break isSpace str
616 maybe_cmd <- io (lookupCommand cmd)
618 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
619 ++ shortHelpText) >> return False)
620 Just (_,f,_,_) -> f (dropWhile isSpace rest)
622 lookupCommand :: String -> IO (Maybe Command)
623 lookupCommand str = do
624 cmds <- readIORef commands
625 -- look for exact match first, then the first prefix match
626 case [ c | c <- cmds, str == cmdName c ] of
627 c:_ -> return (Just c)
628 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
630 c:_ -> return (Just c)
633 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
634 getCurrentBreakSpan = do
635 session <- getSession
636 resumes <- io $ GHC.getResumeContext session
640 let ix = GHC.resumeHistoryIx r
642 then return (Just (GHC.resumeSpan r))
644 let hist = GHC.resumeHistory r !! (ix-1)
645 span <- io $ GHC.getHistorySpan session hist
648 -----------------------------------------------------------------------------
651 noArgs :: GHCi () -> String -> GHCi ()
653 noArgs m _ = io $ putStrLn "This command takes no arguments"
655 help :: String -> GHCi ()
656 help _ = io (putStr helpText)
658 info :: String -> GHCi ()
659 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
660 info s = do { let names = words s
661 ; session <- getSession
662 ; dflags <- getDynFlags
663 ; let exts = dopt Opt_GlasgowExts dflags
664 ; mapM_ (infoThing exts session) names }
666 infoThing exts session str = io $ do
667 names <- GHC.parseName session str
668 let filtered = filterOutChildren names
669 mb_stuffs <- mapM (GHC.getInfo session) filtered
670 unqual <- GHC.getPrintUnqual session
671 putStrLn (showSDocForUser unqual $
672 vcat (intersperse (text "") $
673 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
675 -- Filter out names whose parent is also there Good
676 -- example is '[]', which is both a type and data
677 -- constructor in the same type
678 filterOutChildren :: [Name] -> [Name]
679 filterOutChildren names = filter (not . parent_is_there) names
680 where parent_is_there n
681 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
685 pprInfo exts (thing, fixity, insts)
686 = pprTyThingInContextLoc exts thing
687 $$ show_fixity fixity
688 $$ vcat (map GHC.pprInstance insts)
691 | fix == GHC.defaultFixity = empty
692 | otherwise = ppr fix <+> ppr (GHC.getName thing)
694 runMain :: String -> GHCi ()
696 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
697 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
700 addModule :: [FilePath] -> GHCi ()
702 io (revertCAFs) -- always revert CAFs on load/add.
703 files <- mapM expandPath files
704 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
705 session <- getSession
706 io (mapM_ (GHC.addTarget session) targets)
707 ok <- io (GHC.load session LoadAllTargets)
710 changeDirectory :: String -> GHCi ()
711 changeDirectory dir = do
712 session <- getSession
713 graph <- io (GHC.getModuleGraph session)
714 when (not (null graph)) $
715 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
716 io (GHC.setTargets session [])
717 io (GHC.load session LoadAllTargets)
718 setContextAfterLoad session []
719 io (GHC.workingDirectoryChanged session)
720 dir <- expandPath dir
721 io (setCurrentDirectory dir)
723 editFile :: String -> GHCi ()
726 -- find the name of the "topmost" file loaded
727 session <- getSession
728 graph0 <- io (GHC.getModuleGraph session)
729 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
730 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
731 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
732 Just file -> do_edit file
733 Nothing -> throwDyn (CmdLineError "unknown file name")
734 | otherwise = do_edit str
740 throwDyn (CmdLineError "editor not set, use :set editor")
741 io $ system (cmd ++ ' ':file)
744 defineMacro :: String -> GHCi ()
746 let (macro_name, definition) = break isSpace s
747 cmds <- io (readIORef commands)
749 then throwDyn (CmdLineError "invalid macro name")
751 if (macro_name `elem` map cmdName cmds)
752 then throwDyn (CmdLineError
753 ("command '" ++ macro_name ++ "' is already defined"))
756 -- give the expression a type signature, so we can be sure we're getting
757 -- something of the right type.
758 let new_expr = '(' : definition ++ ") :: String -> IO String"
760 -- compile the expression
762 maybe_hv <- io (GHC.compileExpr cms new_expr)
765 Just hv -> io (writeIORef commands --
766 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
768 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
770 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
771 stringLoop (lines str)
773 undefineMacro :: String -> GHCi ()
774 undefineMacro macro_name = do
775 cmds <- io (readIORef commands)
776 if (macro_name `elem` map cmdName builtin_commands)
777 then throwDyn (CmdLineError
778 ("command '" ++ macro_name ++ "' cannot be undefined"))
780 if (macro_name `notElem` map cmdName cmds)
781 then throwDyn (CmdLineError
782 ("command '" ++ macro_name ++ "' not defined"))
784 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
787 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
788 loadModule fs = timeIt (loadModule' fs)
790 loadModule_ :: [FilePath] -> GHCi ()
791 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
793 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
794 loadModule' files = do
795 session <- getSession
798 discardActiveBreakPoints
799 io (GHC.setTargets session [])
800 io (GHC.load session LoadAllTargets)
803 let (filenames, phases) = unzip files
804 exp_filenames <- mapM expandPath filenames
805 let files' = zip exp_filenames phases
806 targets <- io (mapM (uncurry GHC.guessTarget) files')
808 -- NOTE: we used to do the dependency anal first, so that if it
809 -- fails we didn't throw away the current set of modules. This would
810 -- require some re-working of the GHC interface, so we'll leave it
811 -- as a ToDo for now.
813 io (GHC.setTargets session targets)
814 doLoad session LoadAllTargets
816 checkModule :: String -> GHCi ()
818 let modl = GHC.mkModuleName m
819 session <- getSession
820 result <- io (GHC.checkModule session modl)
822 Nothing -> io $ putStrLn "Nothing"
823 Just r -> io $ putStrLn (showSDoc (
824 case GHC.checkedModuleInfo r of
825 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
827 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
829 (text "global names: " <+> ppr global) $$
830 (text "local names: " <+> ppr local)
832 afterLoad (successIf (isJust result)) session
834 reloadModule :: String -> GHCi ()
836 io (revertCAFs) -- always revert CAFs on reload.
837 discardActiveBreakPoints
838 session <- getSession
839 doLoad session LoadAllTargets
842 io (revertCAFs) -- always revert CAFs on reload.
843 discardActiveBreakPoints
844 session <- getSession
845 doLoad session (LoadUpTo (GHC.mkModuleName m))
848 doLoad session howmuch = do
849 -- turn off breakpoints before we load: we can't turn them off later, because
850 -- the ModBreaks will have gone away.
851 discardActiveBreakPoints
852 ok <- io (GHC.load session howmuch)
856 afterLoad ok session = do
857 io (revertCAFs) -- always revert CAFs on load.
859 graph <- io (GHC.getModuleGraph session)
860 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
861 setContextAfterLoad session graph'
862 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
864 setContextAfterLoad session [] = do
865 prel_mod <- getPrelude
866 io (GHC.setContext session [] [prel_mod])
867 setContextAfterLoad session ms = do
868 -- load a target if one is available, otherwise load the topmost module.
869 targets <- io (GHC.getTargets session)
870 case [ m | Just m <- map (findTarget ms) targets ] of
872 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
873 load_this (last graph')
878 = case filter (`matches` t) ms of
882 summary `matches` Target (TargetModule m) _
883 = GHC.ms_mod_name summary == m
884 summary `matches` Target (TargetFile f _) _
885 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
886 summary `matches` target
889 load_this summary | m <- GHC.ms_mod summary = do
890 b <- io (GHC.moduleIsInterpreted session m)
891 if b then io (GHC.setContext session [m] [])
893 prel_mod <- getPrelude
894 io (GHC.setContext session [] [prel_mod,m])
897 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
898 modulesLoadedMsg ok mods = do
899 dflags <- getDynFlags
900 when (verbosity dflags > 0) $ do
902 | null mods = text "none."
904 punctuate comma (map ppr mods)) <> text "."
907 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
909 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
912 typeOfExpr :: String -> GHCi ()
914 = do cms <- getSession
915 maybe_ty <- io (GHC.exprType cms str)
918 Just ty -> do ty' <- cleanType ty
919 printForUser $ text str <> text " :: " <> ppr ty'
921 kindOfType :: String -> GHCi ()
923 = do cms <- getSession
924 maybe_ty <- io (GHC.typeKind cms str)
927 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
929 quit :: String -> GHCi Bool
932 shellEscape :: String -> GHCi Bool
933 shellEscape str = io (system str >> return False)
935 -----------------------------------------------------------------------------
936 -- Browsing a module's contents
938 browseCmd :: String -> GHCi ()
941 ['*':m] | looksLikeModuleName m -> browseModule m False
942 [m] | looksLikeModuleName m -> browseModule m True
943 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
945 browseModule m exports_only = do
947 modl <- if exports_only then lookupModule m
948 else wantInterpretedModule m
950 -- Temporarily set the context to the module we're interested in,
951 -- just so we can get an appropriate PrintUnqualified
952 (as,bs) <- io (GHC.getContext s)
953 prel_mod <- getPrelude
954 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
955 else GHC.setContext s [modl] [])
956 unqual <- io (GHC.getPrintUnqual s)
957 io (GHC.setContext s as bs)
959 mb_mod_info <- io $ GHC.getModuleInfo s modl
961 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
964 | exports_only = GHC.modInfoExports mod_info
965 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
967 filtered = filterOutChildren names
969 things <- io $ mapM (GHC.lookupName s) filtered
971 dflags <- getDynFlags
972 let exts = dopt Opt_GlasgowExts dflags
973 io (putStrLn (showSDocForUser unqual (
974 vcat (map (pprTyThingInContext exts) (catMaybes things))
976 -- ToDo: modInfoInstances currently throws an exception for
977 -- package modules. When it works, we can do this:
978 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
980 -----------------------------------------------------------------------------
981 -- Setting the module context
984 | all sensible mods = fn mods
985 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
987 (fn, mods) = case str of
988 '+':stuff -> (addToContext, words stuff)
989 '-':stuff -> (removeFromContext, words stuff)
990 stuff -> (newContext, words stuff)
992 sensible ('*':m) = looksLikeModuleName m
993 sensible m = looksLikeModuleName m
995 separate :: Session -> [String] -> [Module] -> [Module]
996 -> GHCi ([Module],[Module])
997 separate session [] as bs = return (as,bs)
998 separate session (('*':str):ms) as bs = do
999 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1000 b <- io $ GHC.moduleIsInterpreted session m
1001 if b then separate session ms (m:as) bs
1002 else throwDyn (CmdLineError ("module '"
1003 ++ GHC.moduleNameString (GHC.moduleName m)
1004 ++ "' is not interpreted"))
1005 separate session (str:ms) as bs = do
1006 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1007 separate session ms as (m:bs)
1009 newContext :: [String] -> GHCi ()
1010 newContext strs = do
1012 (as,bs) <- separate s strs [] []
1013 prel_mod <- getPrelude
1014 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1015 io $ GHC.setContext s as bs'
1018 addToContext :: [String] -> GHCi ()
1019 addToContext strs = do
1021 (as,bs) <- io $ GHC.getContext s
1023 (new_as,new_bs) <- separate s strs [] []
1025 let as_to_add = new_as \\ (as ++ bs)
1026 bs_to_add = new_bs \\ (as ++ bs)
1028 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1031 removeFromContext :: [String] -> GHCi ()
1032 removeFromContext strs = do
1034 (as,bs) <- io $ GHC.getContext s
1036 (as_to_remove,bs_to_remove) <- separate s strs [] []
1038 let as' = as \\ (as_to_remove ++ bs_to_remove)
1039 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1041 io $ GHC.setContext s as' bs'
1043 ----------------------------------------------------------------------------
1046 -- set options in the interpreter. Syntax is exactly the same as the
1047 -- ghc command line, except that certain options aren't available (-C,
1050 -- This is pretty fragile: most options won't work as expected. ToDo:
1051 -- figure out which ones & disallow them.
1053 setCmd :: String -> GHCi ()
1055 = do st <- getGHCiState
1056 let opts = options st
1057 io $ putStrLn (showSDoc (
1058 text "options currently set: " <>
1061 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1064 = case toArgs str of
1065 ("args":args) -> setArgs args
1066 ("prog":prog) -> setProg prog
1067 ("prompt":prompt) -> setPrompt (after 6)
1068 ("editor":cmd) -> setEditor (after 6)
1069 ("stop":cmd) -> setStop (after 4)
1070 wds -> setOptions wds
1071 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1075 setGHCiState st{ args = args }
1079 setGHCiState st{ progname = prog }
1081 io (hPutStrLn stderr "syntax: :set prog <progname>")
1085 setGHCiState st{ editor = cmd }
1089 setGHCiState st{ stop = cmd }
1091 setPrompt value = do
1094 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1095 else setGHCiState st{ prompt = remQuotes value }
1097 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1101 do -- first, deal with the GHCi opts (+s, +t, etc.)
1102 let (plus_opts, minus_opts) = partition isPlus wds
1103 mapM_ setOpt plus_opts
1104 -- then, dynamic flags
1105 newDynFlags minus_opts
1107 newDynFlags minus_opts = do
1108 dflags <- getDynFlags
1109 let pkg_flags = packageFlags dflags
1110 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1112 if (not (null leftovers))
1113 then throwDyn (CmdLineError ("unrecognised flags: " ++
1117 new_pkgs <- setDynFlags dflags'
1119 -- if the package flags changed, we should reset the context
1120 -- and link the new packages.
1121 dflags <- getDynFlags
1122 when (packageFlags dflags /= pkg_flags) $ do
1123 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1124 session <- getSession
1125 io (GHC.setTargets session [])
1126 io (GHC.load session LoadAllTargets)
1127 io (linkPackages dflags new_pkgs)
1128 setContextAfterLoad session []
1132 unsetOptions :: String -> GHCi ()
1134 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1135 let opts = words str
1136 (minus_opts, rest1) = partition isMinus opts
1137 (plus_opts, rest2) = partition isPlus rest1
1139 if (not (null rest2))
1140 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1143 mapM_ unsetOpt plus_opts
1145 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1146 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1148 no_flags <- mapM no_flag minus_opts
1149 newDynFlags no_flags
1151 isMinus ('-':s) = True
1154 isPlus ('+':s) = True
1158 = case strToGHCiOpt str of
1159 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1160 Just o -> setOption o
1163 = case strToGHCiOpt str of
1164 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1165 Just o -> unsetOption o
1167 strToGHCiOpt :: String -> (Maybe GHCiOption)
1168 strToGHCiOpt "s" = Just ShowTiming
1169 strToGHCiOpt "t" = Just ShowType
1170 strToGHCiOpt "r" = Just RevertCAFs
1171 strToGHCiOpt _ = Nothing
1173 optToStr :: GHCiOption -> String
1174 optToStr ShowTiming = "s"
1175 optToStr ShowType = "t"
1176 optToStr RevertCAFs = "r"
1178 -- ---------------------------------------------------------------------------
1184 ["args"] -> io $ putStrLn (show (args st))
1185 ["prog"] -> io $ putStrLn (show (progname st))
1186 ["prompt"] -> io $ putStrLn (show (prompt st))
1187 ["editor"] -> io $ putStrLn (show (editor st))
1188 ["stop"] -> io $ putStrLn (show (stop st))
1189 ["modules" ] -> showModules
1190 ["bindings"] -> showBindings
1191 ["linker"] -> io showLinkerState
1192 ["breaks"] -> showBkptTable
1193 ["context"] -> showContext
1194 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1197 session <- getSession
1198 let show_one ms = do m <- io (GHC.showModule session ms)
1200 graph <- io (GHC.getModuleGraph session)
1201 mapM_ show_one graph
1205 unqual <- io (GHC.getPrintUnqual s)
1206 bindings <- io (GHC.getBindings s)
1207 mapM_ showTyThing bindings
1210 showTyThing (AnId id) = do
1211 ty' <- cleanType (GHC.idType id)
1212 printForUser $ ppr id <> text " :: " <> ppr ty'
1213 showTyThing _ = return ()
1215 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1216 cleanType :: Type -> GHCi Type
1218 dflags <- getDynFlags
1219 if dopt Opt_GlasgowExts dflags
1221 else return $! GHC.dropForAlls ty
1223 showBkptTable :: GHCi ()
1226 printForUser $ prettyLocations (breaks st)
1228 showContext :: GHCi ()
1230 session <- getSession
1231 resumes <- io $ GHC.getResumeContext session
1232 printForUser $ vcat (map pp_resume (reverse resumes))
1235 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1236 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1239 -- -----------------------------------------------------------------------------
1242 completeNone :: String -> IO [String]
1243 completeNone w = return []
1246 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1247 completeWord w start end = do
1248 line <- Readline.getLineBuffer
1250 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1252 | Just c <- is_cmd line -> do
1253 maybe_cmd <- lookupCommand c
1254 let (n,w') = selectWord (words' 0 line)
1256 Nothing -> return Nothing
1257 Just (_,_,False,complete) -> wrapCompleter complete w
1258 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1259 return (map (drop n) rets)
1260 in wrapCompleter complete' w'
1262 --printf "complete %s, start = %d, end = %d\n" w start end
1263 wrapCompleter completeIdentifier w
1264 where words' _ [] = []
1265 words' n str = let (w,r) = break isSpace str
1266 (s,r') = span isSpace r
1267 in (n,w):words' (n+length w+length s) r'
1268 -- In a Haskell expression we want to parse 'a-b' as three words
1269 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1270 -- only be a single word.
1271 selectWord [] = (0,w)
1272 selectWord ((offset,x):xs)
1273 | offset+length x >= start = (start-offset,take (end-offset) x)
1274 | otherwise = selectWord xs
1277 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1278 | otherwise = Nothing
1281 cmds <- readIORef commands
1282 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1284 completeMacro w = do
1285 cmds <- readIORef commands
1286 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1287 return (filter (w `isPrefixOf`) cmds')
1289 completeIdentifier w = do
1291 rdrs <- GHC.getRdrNamesInScope s
1292 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1294 completeModule w = do
1296 dflags <- GHC.getSessionDynFlags s
1297 let pkg_mods = allExposedModules dflags
1298 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1300 completeHomeModule w = do
1302 g <- GHC.getModuleGraph s
1303 let home_mods = map GHC.ms_mod_name g
1304 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1306 completeSetOptions w = do
1307 return (filter (w `isPrefixOf`) options)
1308 where options = "args":"prog":allFlags
1310 completeFilename = Readline.filenameCompletionFunction
1312 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1314 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1315 unionComplete f1 f2 w = do
1320 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1321 wrapCompleter fun w = do
1324 [] -> return Nothing
1325 [x] -> return (Just (x,[]))
1326 xs -> case getCommonPrefix xs of
1327 "" -> return (Just ("",xs))
1328 pref -> return (Just (pref,xs))
1330 getCommonPrefix :: [String] -> String
1331 getCommonPrefix [] = ""
1332 getCommonPrefix (s:ss) = foldl common s ss
1333 where common s "" = ""
1335 common (c:cs) (d:ds)
1336 | c == d = c : common cs ds
1339 allExposedModules :: DynFlags -> [ModuleName]
1340 allExposedModules dflags
1341 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1343 pkg_db = pkgIdMap (pkgState dflags)
1345 completeCmd = completeNone
1346 completeMacro = completeNone
1347 completeIdentifier = completeNone
1348 completeModule = completeNone
1349 completeHomeModule = completeNone
1350 completeSetOptions = completeNone
1351 completeFilename = completeNone
1352 completeHomeModuleOrFile=completeNone
1353 completeBkpt = completeNone
1356 -- ---------------------------------------------------------------------------
1357 -- User code exception handling
1359 -- This is the exception handler for exceptions generated by the
1360 -- user's code and exceptions coming from children sessions;
1361 -- it normally just prints out the exception. The
1362 -- handler must be recursive, in case showing the exception causes
1363 -- more exceptions to be raised.
1365 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1366 -- raising another exception. We therefore don't put the recursive
1367 -- handler arond the flushing operation, so if stderr is closed
1368 -- GHCi will just die gracefully rather than going into an infinite loop.
1369 handler :: Exception -> GHCi Bool
1371 handler exception = do
1373 io installSignalHandlers
1374 ghciHandle handler (showException exception >> return False)
1376 showException (DynException dyn) =
1377 case fromDynamic dyn of
1378 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1379 Just Interrupted -> io (putStrLn "Interrupted.")
1380 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1381 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1382 Just other_ghc_ex -> io (print other_ghc_ex)
1384 showException other_exception
1385 = io (putStrLn ("*** Exception: " ++ show other_exception))
1387 -----------------------------------------------------------------------------
1388 -- recursive exception handlers
1390 -- Don't forget to unblock async exceptions in the handler, or if we're
1391 -- in an exception loop (eg. let a = error a in a) the ^C exception
1392 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1394 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1395 ghciHandle h (GHCi m) = GHCi $ \s ->
1396 Exception.catch (m s)
1397 (\e -> unGHCi (ghciUnblock (h e)) s)
1399 ghciUnblock :: GHCi a -> GHCi a
1400 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1403 -- ----------------------------------------------------------------------------
1406 expandPath :: String -> GHCi String
1408 case dropWhile isSpace path of
1410 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1411 return (tilde ++ '/':d)
1415 wantInterpretedModule :: String -> GHCi Module
1416 wantInterpretedModule str = do
1417 session <- getSession
1418 modl <- lookupModule str
1419 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1420 when (not is_interpreted) $
1421 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1424 wantNameFromInterpretedModule noCanDo str and_then = do
1425 session <- getSession
1426 names <- io $ GHC.parseName session str
1430 let modl = GHC.nameModule n
1431 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1432 if not is_interpreted
1433 then noCanDo n $ text "module " <> ppr modl <>
1434 text " is not interpreted"
1437 -- ----------------------------------------------------------------------------
1438 -- Windows console setup
1440 setUpConsole :: IO ()
1442 #ifdef mingw32_HOST_OS
1443 -- On Windows we need to set a known code page, otherwise the characters
1444 -- we read from the console will be be in some strange encoding, and
1445 -- similarly for characters we write to the console.
1447 -- At the moment, GHCi pretends all input is Latin-1. In the
1448 -- future we should support UTF-8, but for now we set the code pages
1451 -- It seems you have to set the font in the console window to
1452 -- a Unicode font in order for output to work properly,
1453 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1454 -- (see MSDN for SetConsoleOutputCP()).
1456 setConsoleCP 28591 -- ISO Latin-1
1457 setConsoleOutputCP 28591 -- ISO Latin-1
1461 -- -----------------------------------------------------------------------------
1462 -- commands for debugger
1464 sprintCmd = pprintCommand False False
1465 printCmd = pprintCommand True False
1466 forceCmd = pprintCommand False True
1468 pprintCommand bind force str = do
1469 session <- getSession
1470 io $ pprintClosureCommand session bind force str
1472 stepCmd :: String -> GHCi ()
1473 stepCmd [] = doContinue GHC.SingleStep
1474 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1476 traceCmd :: String -> GHCi ()
1477 traceCmd [] = doContinue GHC.RunAndLogSteps
1478 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1480 continueCmd :: String -> GHCi ()
1481 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1483 doContinue :: SingleStep -> GHCi ()
1484 doContinue step = do
1485 session <- getSession
1486 runResult <- io $ GHC.resume session step
1487 afterRunStmt runResult
1490 abandonCmd :: String -> GHCi ()
1491 abandonCmd = noArgs $ do
1493 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1494 when (not b) $ io $ putStrLn "There is no computation running."
1497 deleteCmd :: String -> GHCi ()
1498 deleteCmd argLine = do
1499 deleteSwitch $ words argLine
1501 deleteSwitch :: [String] -> GHCi ()
1503 io $ putStrLn "The delete command requires at least one argument."
1504 -- delete all break points
1505 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1506 deleteSwitch idents = do
1507 mapM_ deleteOneBreak idents
1509 deleteOneBreak :: String -> GHCi ()
1511 | all isDigit str = deleteBreak (read str)
1512 | otherwise = return ()
1514 historyCmd :: String -> GHCi ()
1516 | null arg = history 20
1517 | all isDigit arg = history (read arg)
1518 | otherwise = io $ putStrLn "Syntax: :history [num]"
1522 resumes <- io $ GHC.getResumeContext s
1524 [] -> io $ putStrLn "Not stopped at a breakpoint"
1526 let hist = GHC.resumeHistory r
1527 (took,rest) = splitAt num hist
1528 spans <- mapM (io . GHC.getHistorySpan s) took
1529 let nums = map (printf "-%-3d:") [(1::Int)..]
1530 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1531 io $ putStrLn $ if null rest then "<end of history>" else "..."
1533 backCmd :: String -> GHCi ()
1534 backCmd = noArgs $ do
1536 (names, ix, span) <- io $ GHC.back s
1537 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1538 mapM_ (showTypeOfName s) names
1539 -- run the command set with ":set stop <cmd>"
1541 runCommand (stop st)
1544 forwardCmd :: String -> GHCi ()
1545 forwardCmd = noArgs $ do
1547 (names, ix, span) <- io $ GHC.forward s
1548 printForUser $ (if (ix == 0)
1549 then ptext SLIT("Stopped at")
1550 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1551 mapM_ (showTypeOfName s) names
1552 -- run the command set with ":set stop <cmd>"
1554 runCommand (stop st)
1557 -- handle the "break" command
1558 breakCmd :: String -> GHCi ()
1559 breakCmd argLine = do
1560 session <- getSession
1561 breakSwitch session $ words argLine
1563 breakSwitch :: Session -> [String] -> GHCi ()
1564 breakSwitch _session [] = do
1565 io $ putStrLn "The break command requires at least one argument."
1566 breakSwitch session args@(arg1:rest)
1567 | looksLikeModuleName arg1 = do
1568 mod <- wantInterpretedModule arg1
1569 breakByModule session mod rest
1570 | all isDigit arg1 = do
1571 (toplevel, _) <- io $ GHC.getContext session
1573 (mod : _) -> breakByModuleLine mod (read arg1) rest
1575 io $ putStrLn "Cannot find default module for breakpoint."
1576 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1577 | otherwise = do -- try parsing it as an identifier
1578 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1579 let loc = GHC.nameSrcLoc name
1580 if GHC.isGoodSrcLoc loc
1581 then findBreakAndSet (GHC.nameModule name) $
1582 findBreakByCoord (Just (GHC.srcLocFile loc))
1583 (GHC.srcLocLine loc,
1585 else noCanDo name $ text "can't find its location: " <> ppr loc
1587 noCanDo n why = printForUser $
1588 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1590 breakByModule :: Session -> Module -> [String] -> GHCi ()
1591 breakByModule session mod args@(arg1:rest)
1592 | all isDigit arg1 = do -- looks like a line number
1593 breakByModuleLine mod (read arg1) rest
1594 | otherwise = io $ putStrLn "Invalid arguments to :break"
1596 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1597 breakByModuleLine mod line args
1598 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1599 | [col] <- args, all isDigit col =
1600 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1601 | otherwise = io $ putStrLn "Invalid arguments to :break"
1603 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1604 findBreakAndSet mod lookupTickTree = do
1605 tickArray <- getTickArray mod
1606 (breakArray, _) <- getModBreak mod
1607 case lookupTickTree tickArray of
1608 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1609 Just (tick, span) -> do
1610 success <- io $ setBreakFlag True breakArray tick
1611 session <- getSession
1615 recordBreak $ BreakLocation
1621 text "Breakpoint " <> ppr nm <>
1623 then text " was already set at " <> ppr span
1624 else text " activated at " <> ppr span
1626 printForUser $ text "Breakpoint could not be activated at"
1629 -- When a line number is specified, the current policy for choosing
1630 -- the best breakpoint is this:
1631 -- - the leftmost complete subexpression on the specified line, or
1632 -- - the leftmost subexpression starting on the specified line, or
1633 -- - the rightmost subexpression enclosing the specified line
1635 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1636 findBreakByLine line arr
1637 | not (inRange (bounds arr) line) = Nothing
1639 listToMaybe (sortBy leftmost_largest complete) `mplus`
1640 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1641 listToMaybe (sortBy rightmost ticks)
1645 starts_here = [ tick | tick@(nm,span) <- ticks,
1646 GHC.srcSpanStartLine span == line ]
1648 (complete,incomplete) = partition ends_here starts_here
1649 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1651 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1652 -> Maybe (BreakIndex,SrcSpan)
1653 findBreakByCoord mb_file (line, col) arr
1654 | not (inRange (bounds arr) line) = Nothing
1656 listToMaybe (sortBy rightmost contains)
1660 -- the ticks that span this coordinate
1661 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1662 is_correct_file span ]
1664 is_correct_file span
1665 | Just f <- mb_file = GHC.srcSpanFile span == f
1669 leftmost_smallest (_,a) (_,b) = a `compare` b
1670 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1672 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1673 rightmost (_,a) (_,b) = b `compare` a
1675 spans :: SrcSpan -> (Int,Int) -> Bool
1676 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1677 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1679 start_bold = BS.pack "\ESC[1m"
1680 end_bold = BS.pack "\ESC[0m"
1682 listCmd :: String -> GHCi ()
1684 mb_span <- getCurrentBreakSpan
1686 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1687 Just span -> io $ listAround span True
1688 listCmd str = list2 (words str)
1690 list2 [arg] | all isDigit arg = do
1691 session <- getSession
1692 (toplevel, _) <- io $ GHC.getContext session
1694 [] -> io $ putStrLn "No module to list"
1695 (mod : _) -> listModuleLine mod (read arg)
1696 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1697 mod <- wantInterpretedModule arg1
1698 listModuleLine mod (read arg2)
1700 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1701 let loc = GHC.nameSrcLoc name
1702 if GHC.isGoodSrcLoc loc
1704 tickArray <- getTickArray (GHC.nameModule name)
1705 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1706 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1709 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1710 Just (_,span) -> io $ listAround span False
1712 noCanDo name $ text "can't find its location: " <>
1715 noCanDo n why = printForUser $
1716 text "cannot list source code for " <> ppr n <> text ": " <> why
1718 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1720 listModuleLine :: Module -> Int -> GHCi ()
1721 listModuleLine modl line = do
1722 session <- getSession
1723 graph <- io (GHC.getModuleGraph session)
1724 let this = filter ((== modl) . GHC.ms_mod) graph
1726 [] -> panic "listModuleLine"
1728 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1729 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1730 io $ listAround (GHC.srcLocSpan loc) False
1732 -- | list a section of a source file around a particular SrcSpan.
1733 -- If the highlight flag is True, also highlight the span using
1734 -- start_bold/end_bold.
1735 listAround span do_highlight = do
1736 contents <- BS.readFile (unpackFS file)
1738 lines = BS.split '\n' contents
1739 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1740 drop (line1 - 1 - pad_before) $ lines
1741 fst_line = max 1 (line1 - pad_before)
1742 line_nos = [ fst_line .. ]
1744 highlighted | do_highlight = zipWith highlight line_nos these_lines
1745 | otherwise = these_lines
1747 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1748 prefixed = zipWith BS.append bs_line_nos highlighted
1750 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1752 file = GHC.srcSpanFile span
1753 line1 = GHC.srcSpanStartLine span
1754 col1 = GHC.srcSpanStartCol span
1755 line2 = GHC.srcSpanEndLine span
1756 col2 = GHC.srcSpanEndCol span
1758 pad_before | line1 == 1 = 0
1763 | no == line1 && no == line2
1764 = let (a,r) = BS.splitAt col1 line
1765 (b,c) = BS.splitAt (col2-col1) r
1767 BS.concat [a,start_bold,b,end_bold,c]
1769 = let (a,b) = BS.splitAt col1 line in
1770 BS.concat [a, start_bold, b]
1772 = let (a,b) = BS.splitAt col2 line in
1773 BS.concat [a, end_bold, b]
1776 -- --------------------------------------------------------------------------
1779 getTickArray :: Module -> GHCi TickArray
1780 getTickArray modl = do
1782 let arrmap = tickarrays st
1783 case lookupModuleEnv arrmap modl of
1784 Just arr -> return arr
1786 (breakArray, ticks) <- getModBreak modl
1787 let arr = mkTickArray (assocs ticks)
1788 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1791 discardTickArrays :: GHCi ()
1792 discardTickArrays = do
1794 setGHCiState st{tickarrays = emptyModuleEnv}
1796 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1798 = accumArray (flip (:)) [] (1, max_line)
1799 [ (line, (nm,span)) | (nm,span) <- ticks,
1800 line <- srcSpanLines span ]
1802 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1803 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1804 GHC.srcSpanEndLine span ]
1806 lookupModule :: String -> GHCi Module
1807 lookupModule modName
1808 = do session <- getSession
1809 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1811 -- don't reset the counter back to zero?
1812 discardActiveBreakPoints :: GHCi ()
1813 discardActiveBreakPoints = do
1815 mapM (turnOffBreak.snd) (breaks st)
1816 setGHCiState $ st { breaks = [] }
1818 deleteBreak :: Int -> GHCi ()
1819 deleteBreak identity = do
1821 let oldLocations = breaks st
1822 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1824 then printForUser (text "Breakpoint" <+> ppr identity <+>
1825 text "does not exist")
1827 mapM (turnOffBreak.snd) this
1828 setGHCiState $ st { breaks = rest }
1830 turnOffBreak loc = do
1831 (arr, _) <- getModBreak (breakModule loc)
1832 io $ setBreakFlag False arr (breakTick loc)
1834 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1835 getModBreak mod = do
1836 session <- getSession
1837 Just mod_info <- io $ GHC.getModuleInfo session mod
1838 let modBreaks = GHC.modInfoModBreaks mod_info
1839 let array = GHC.modBreaks_flags modBreaks
1840 let ticks = GHC.modBreaks_locs modBreaks
1841 return (array, ticks)
1843 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1844 setBreakFlag toggle array index
1845 | toggle = GHC.setBreakOn array index
1846 | otherwise = GHC.setBreakOff array index