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,
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 <- runCommands l
451 if quit then return () else fileLoop hdl show_prompt
454 session <- getSession
455 (toplevs,exports) <- io (GHC.getContext session)
456 resumes <- io $ GHC.getResumeContext session
462 let ix = GHC.resumeHistoryIx r
464 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
466 let hist = GHC.resumeHistory r !! (ix-1)
467 span <- io $ GHC.getHistorySpan session hist
468 return (brackets (ppr (negate ix) <> char ':'
469 <+> ppr span) <> space)
471 dots | r:rs <- resumes, not (null rs) = text "... "
475 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
476 hsep (map (ppr . GHC.moduleName) exports)
478 deflt_prompt = dots <> context_bit <> modules_bit
480 f ('%':'s':xs) = deflt_prompt <> f xs
481 f ('%':'%':xs) = char '%' <> f xs
482 f (x:xs) = char x <> f xs
486 return (showSDoc (f (prompt st)))
490 readlineLoop :: GHCi ()
492 session <- getSession
493 (mod,imports) <- io (GHC.getContext session)
495 saveSession -- for use by completion
497 mb_span <- getCurrentBreakSpan
499 l <- io (readline prompt `finally` setNonBlockingFD 0)
500 -- readline sometimes puts stdin into blocking mode,
501 -- so we need to put it back for the IO library
506 case removeSpaces l of
510 quit <- runCommands l
511 if quit then return () else readlineLoop
514 runCommands :: String -> GHCi Bool
516 q <- ghciHandle handler (doCommand cmd)
517 if q then return True else runNext
523 c:cs -> do setGHCiState st{ cmdqueue = cs }
526 doCommand (':' : cmd) = specialCommand cmd
527 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
530 enqueueCommands :: [String] -> GHCi ()
531 enqueueCommands cmds = do
533 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
536 -- This version is for the GHC command-line option -e. The only difference
537 -- from runCommand is that it catches the ExitException exception and
538 -- exits, rather than printing out the exception.
539 runCommandEval c = ghciHandle handleEval (doCommand c)
541 handleEval (ExitException code) = io (exitWith code)
542 handleEval e = do handler e
543 io (exitWith (ExitFailure 1))
545 doCommand (':' : command) = specialCommand command
547 = do r <- runStmt stmt GHC.RunToCompletion
549 False -> io (exitWith (ExitFailure 1))
550 -- failure to run the command causes exit(1) for ghc -e.
553 runStmt :: String -> SingleStep -> GHCi Bool
555 | null (filter (not.isSpace) stmt) = return False
557 = do st <- getGHCiState
558 session <- getSession
559 result <- io $ withProgName (progname st) $ withArgs (args st) $
560 GHC.runStmt session stmt step
564 afterRunStmt :: GHC.RunResult -> GHCi Bool
565 -- False <=> the statement failed to compile
566 afterRunStmt (GHC.RunException e) = throw e
567 afterRunStmt run_result = do
568 session <- getSession
570 GHC.RunOk names -> do
571 show_types <- isOptionSet ShowType
572 when show_types $ mapM_ (showTypeOfName session) names
573 GHC.RunBreak _ names mb_info -> do
574 resumes <- io $ GHC.getResumeContext session
575 printForUser $ ptext SLIT("Stopped at") <+>
576 ppr (GHC.resumeSpan (head resumes))
577 mapM_ (showTypeOfName session) names
578 maybe (return ()) runBreakCmd mb_info
579 -- run the command set with ":set stop <cmd>"
581 enqueueCommands [stop st]
586 io installSignalHandlers
587 b <- isOptionSet RevertCAFs
588 io (when b revertCAFs)
590 return (case run_result of GHC.RunOk _ -> True; _ -> False)
592 runBreakCmd :: GHC.BreakInfo -> GHCi ()
593 runBreakCmd info = do
594 let mod = GHC.breakInfo_module info
595 nm = GHC.breakInfo_number info
597 case [ loc | (i,loc) <- breaks st,
598 breakModule loc == mod, breakTick loc == nm ] of
600 loc:_ | null cmd -> return ()
601 | otherwise -> do enqueueCommands [cmd]; return ()
602 where cmd = onBreakCmd loc
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 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
698 addModule :: [FilePath] -> GHCi ()
700 io (revertCAFs) -- always revert CAFs on load/add.
701 files <- mapM expandPath files
702 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
703 session <- getSession
704 io (mapM_ (GHC.addTarget session) targets)
705 ok <- io (GHC.load session LoadAllTargets)
708 changeDirectory :: String -> GHCi ()
709 changeDirectory dir = do
710 session <- getSession
711 graph <- io (GHC.getModuleGraph session)
712 when (not (null graph)) $
713 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
714 io (GHC.setTargets session [])
715 io (GHC.load session LoadAllTargets)
716 setContextAfterLoad session []
717 io (GHC.workingDirectoryChanged session)
718 dir <- expandPath dir
719 io (setCurrentDirectory dir)
721 editFile :: String -> GHCi ()
724 -- find the name of the "topmost" file loaded
725 session <- getSession
726 graph0 <- io (GHC.getModuleGraph session)
727 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
728 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
729 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
730 Just file -> do_edit file
731 Nothing -> throwDyn (CmdLineError "unknown file name")
732 | otherwise = do_edit str
738 throwDyn (CmdLineError "editor not set, use :set editor")
739 io $ system (cmd ++ ' ':file)
742 defineMacro :: String -> GHCi ()
744 let (macro_name, definition) = break isSpace s
745 cmds <- io (readIORef commands)
747 then throwDyn (CmdLineError "invalid macro name")
749 if (macro_name `elem` map cmdName cmds)
750 then throwDyn (CmdLineError
751 ("command '" ++ macro_name ++ "' is already defined"))
754 -- give the expression a type signature, so we can be sure we're getting
755 -- something of the right type.
756 let new_expr = '(' : definition ++ ") :: String -> IO String"
758 -- compile the expression
760 maybe_hv <- io (GHC.compileExpr cms new_expr)
763 Just hv -> io (writeIORef commands --
764 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
766 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
768 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
769 enqueueCommands (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 }
1086 setStop str@(c:_) | isDigit c
1087 = do let (nm_str,rest) = break (not.isDigit) str
1090 let old_breaks = breaks st
1091 if all ((/= nm) . fst) old_breaks
1092 then printForUser (text "Breakpoint" <+> ppr nm <+>
1093 text "does not exist")
1095 let new_breaks = map fn old_breaks
1096 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1097 | otherwise = (i,loc)
1098 setGHCiState st{ breaks = new_breaks }
1101 setGHCiState st{ stop = cmd }
1103 setPrompt value = do
1106 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1107 else setGHCiState st{ prompt = remQuotes value }
1109 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1113 do -- first, deal with the GHCi opts (+s, +t, etc.)
1114 let (plus_opts, minus_opts) = partition isPlus wds
1115 mapM_ setOpt plus_opts
1116 -- then, dynamic flags
1117 newDynFlags minus_opts
1119 newDynFlags minus_opts = do
1120 dflags <- getDynFlags
1121 let pkg_flags = packageFlags dflags
1122 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1124 if (not (null leftovers))
1125 then throwDyn (CmdLineError ("unrecognised flags: " ++
1129 new_pkgs <- setDynFlags dflags'
1131 -- if the package flags changed, we should reset the context
1132 -- and link the new packages.
1133 dflags <- getDynFlags
1134 when (packageFlags dflags /= pkg_flags) $ do
1135 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1136 session <- getSession
1137 io (GHC.setTargets session [])
1138 io (GHC.load session LoadAllTargets)
1139 io (linkPackages dflags new_pkgs)
1140 setContextAfterLoad session []
1144 unsetOptions :: String -> GHCi ()
1146 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1147 let opts = words str
1148 (minus_opts, rest1) = partition isMinus opts
1149 (plus_opts, rest2) = partition isPlus rest1
1151 if (not (null rest2))
1152 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1155 mapM_ unsetOpt plus_opts
1157 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1158 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1160 no_flags <- mapM no_flag minus_opts
1161 newDynFlags no_flags
1163 isMinus ('-':s) = True
1166 isPlus ('+':s) = True
1170 = case strToGHCiOpt str of
1171 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1172 Just o -> setOption o
1175 = case strToGHCiOpt str of
1176 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1177 Just o -> unsetOption o
1179 strToGHCiOpt :: String -> (Maybe GHCiOption)
1180 strToGHCiOpt "s" = Just ShowTiming
1181 strToGHCiOpt "t" = Just ShowType
1182 strToGHCiOpt "r" = Just RevertCAFs
1183 strToGHCiOpt _ = Nothing
1185 optToStr :: GHCiOption -> String
1186 optToStr ShowTiming = "s"
1187 optToStr ShowType = "t"
1188 optToStr RevertCAFs = "r"
1190 -- ---------------------------------------------------------------------------
1196 ["args"] -> io $ putStrLn (show (args st))
1197 ["prog"] -> io $ putStrLn (show (progname st))
1198 ["prompt"] -> io $ putStrLn (show (prompt st))
1199 ["editor"] -> io $ putStrLn (show (editor st))
1200 ["stop"] -> io $ putStrLn (show (stop st))
1201 ["modules" ] -> showModules
1202 ["bindings"] -> showBindings
1203 ["linker"] -> io showLinkerState
1204 ["breaks"] -> showBkptTable
1205 ["context"] -> showContext
1206 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1209 session <- getSession
1210 let show_one ms = do m <- io (GHC.showModule session ms)
1212 graph <- io (GHC.getModuleGraph session)
1213 mapM_ show_one graph
1217 unqual <- io (GHC.getPrintUnqual s)
1218 bindings <- io (GHC.getBindings s)
1219 mapM_ showTyThing bindings
1222 showTyThing (AnId id) = do
1223 ty' <- cleanType (GHC.idType id)
1224 printForUser $ ppr id <> text " :: " <> ppr ty'
1225 showTyThing _ = return ()
1227 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1228 cleanType :: Type -> GHCi Type
1230 dflags <- getDynFlags
1231 if dopt Opt_GlasgowExts dflags
1233 else return $! GHC.dropForAlls ty
1235 showBkptTable :: GHCi ()
1238 printForUser $ prettyLocations (breaks st)
1240 showContext :: GHCi ()
1242 session <- getSession
1243 resumes <- io $ GHC.getResumeContext session
1244 printForUser $ vcat (map pp_resume (reverse resumes))
1247 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1248 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1251 -- -----------------------------------------------------------------------------
1254 completeNone :: String -> IO [String]
1255 completeNone w = return []
1258 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1259 completeWord w start end = do
1260 line <- Readline.getLineBuffer
1262 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1264 | Just c <- is_cmd line -> do
1265 maybe_cmd <- lookupCommand c
1266 let (n,w') = selectWord (words' 0 line)
1268 Nothing -> return Nothing
1269 Just (_,_,False,complete) -> wrapCompleter complete w
1270 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1271 return (map (drop n) rets)
1272 in wrapCompleter complete' w'
1274 --printf "complete %s, start = %d, end = %d\n" w start end
1275 wrapCompleter completeIdentifier w
1276 where words' _ [] = []
1277 words' n str = let (w,r) = break isSpace str
1278 (s,r') = span isSpace r
1279 in (n,w):words' (n+length w+length s) r'
1280 -- In a Haskell expression we want to parse 'a-b' as three words
1281 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1282 -- only be a single word.
1283 selectWord [] = (0,w)
1284 selectWord ((offset,x):xs)
1285 | offset+length x >= start = (start-offset,take (end-offset) x)
1286 | otherwise = selectWord xs
1289 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1290 | otherwise = Nothing
1293 cmds <- readIORef commands
1294 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1296 completeMacro w = do
1297 cmds <- readIORef commands
1298 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1299 return (filter (w `isPrefixOf`) cmds')
1301 completeIdentifier w = do
1303 rdrs <- GHC.getRdrNamesInScope s
1304 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1306 completeModule w = do
1308 dflags <- GHC.getSessionDynFlags s
1309 let pkg_mods = allExposedModules dflags
1310 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1312 completeHomeModule w = do
1314 g <- GHC.getModuleGraph s
1315 let home_mods = map GHC.ms_mod_name g
1316 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1318 completeSetOptions w = do
1319 return (filter (w `isPrefixOf`) options)
1320 where options = "args":"prog":allFlags
1322 completeFilename = Readline.filenameCompletionFunction
1324 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1326 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1327 unionComplete f1 f2 w = do
1332 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1333 wrapCompleter fun w = do
1336 [] -> return Nothing
1337 [x] -> return (Just (x,[]))
1338 xs -> case getCommonPrefix xs of
1339 "" -> return (Just ("",xs))
1340 pref -> return (Just (pref,xs))
1342 getCommonPrefix :: [String] -> String
1343 getCommonPrefix [] = ""
1344 getCommonPrefix (s:ss) = foldl common s ss
1345 where common s "" = ""
1347 common (c:cs) (d:ds)
1348 | c == d = c : common cs ds
1351 allExposedModules :: DynFlags -> [ModuleName]
1352 allExposedModules dflags
1353 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1355 pkg_db = pkgIdMap (pkgState dflags)
1357 completeCmd = completeNone
1358 completeMacro = completeNone
1359 completeIdentifier = completeNone
1360 completeModule = completeNone
1361 completeHomeModule = completeNone
1362 completeSetOptions = completeNone
1363 completeFilename = completeNone
1364 completeHomeModuleOrFile=completeNone
1365 completeBkpt = completeNone
1368 -- ---------------------------------------------------------------------------
1369 -- User code exception handling
1371 -- This is the exception handler for exceptions generated by the
1372 -- user's code and exceptions coming from children sessions;
1373 -- it normally just prints out the exception. The
1374 -- handler must be recursive, in case showing the exception causes
1375 -- more exceptions to be raised.
1377 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1378 -- raising another exception. We therefore don't put the recursive
1379 -- handler arond the flushing operation, so if stderr is closed
1380 -- GHCi will just die gracefully rather than going into an infinite loop.
1381 handler :: Exception -> GHCi Bool
1383 handler exception = do
1385 io installSignalHandlers
1386 ghciHandle handler (showException exception >> return False)
1388 showException (DynException dyn) =
1389 case fromDynamic dyn of
1390 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1391 Just Interrupted -> io (putStrLn "Interrupted.")
1392 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1393 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1394 Just other_ghc_ex -> io (print other_ghc_ex)
1396 showException other_exception
1397 = io (putStrLn ("*** Exception: " ++ show other_exception))
1399 -----------------------------------------------------------------------------
1400 -- recursive exception handlers
1402 -- Don't forget to unblock async exceptions in the handler, or if we're
1403 -- in an exception loop (eg. let a = error a in a) the ^C exception
1404 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1406 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1407 ghciHandle h (GHCi m) = GHCi $ \s ->
1408 Exception.catch (m s)
1409 (\e -> unGHCi (ghciUnblock (h e)) s)
1411 ghciUnblock :: GHCi a -> GHCi a
1412 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1415 -- ----------------------------------------------------------------------------
1418 expandPath :: String -> GHCi String
1420 case dropWhile isSpace path of
1422 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1423 return (tilde ++ '/':d)
1427 wantInterpretedModule :: String -> GHCi Module
1428 wantInterpretedModule str = do
1429 session <- getSession
1430 modl <- lookupModule str
1431 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1432 when (not is_interpreted) $
1433 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1436 wantNameFromInterpretedModule noCanDo str and_then = do
1437 session <- getSession
1438 names <- io $ GHC.parseName session str
1442 let modl = GHC.nameModule n
1443 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1444 if not is_interpreted
1445 then noCanDo n $ text "module " <> ppr modl <>
1446 text " is not interpreted"
1449 -- ----------------------------------------------------------------------------
1450 -- Windows console setup
1452 setUpConsole :: IO ()
1454 #ifdef mingw32_HOST_OS
1455 -- On Windows we need to set a known code page, otherwise the characters
1456 -- we read from the console will be be in some strange encoding, and
1457 -- similarly for characters we write to the console.
1459 -- At the moment, GHCi pretends all input is Latin-1. In the
1460 -- future we should support UTF-8, but for now we set the code pages
1463 -- It seems you have to set the font in the console window to
1464 -- a Unicode font in order for output to work properly,
1465 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1466 -- (see MSDN for SetConsoleOutputCP()).
1468 setConsoleCP 28591 -- ISO Latin-1
1469 setConsoleOutputCP 28591 -- ISO Latin-1
1473 -- -----------------------------------------------------------------------------
1474 -- commands for debugger
1476 sprintCmd = pprintCommand False False
1477 printCmd = pprintCommand True False
1478 forceCmd = pprintCommand False True
1480 pprintCommand bind force str = do
1481 session <- getSession
1482 io $ pprintClosureCommand session bind force str
1484 stepCmd :: String -> GHCi ()
1485 stepCmd [] = doContinue GHC.SingleStep
1486 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1488 traceCmd :: String -> GHCi ()
1489 traceCmd [] = doContinue GHC.RunAndLogSteps
1490 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1492 continueCmd :: String -> GHCi ()
1493 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1495 doContinue :: SingleStep -> GHCi ()
1496 doContinue step = do
1497 session <- getSession
1498 runResult <- io $ GHC.resume session step
1499 afterRunStmt runResult
1502 abandonCmd :: String -> GHCi ()
1503 abandonCmd = noArgs $ do
1505 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1506 when (not b) $ io $ putStrLn "There is no computation running."
1509 deleteCmd :: String -> GHCi ()
1510 deleteCmd argLine = do
1511 deleteSwitch $ words argLine
1513 deleteSwitch :: [String] -> GHCi ()
1515 io $ putStrLn "The delete command requires at least one argument."
1516 -- delete all break points
1517 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1518 deleteSwitch idents = do
1519 mapM_ deleteOneBreak idents
1521 deleteOneBreak :: String -> GHCi ()
1523 | all isDigit str = deleteBreak (read str)
1524 | otherwise = return ()
1526 historyCmd :: String -> GHCi ()
1528 | null arg = history 20
1529 | all isDigit arg = history (read arg)
1530 | otherwise = io $ putStrLn "Syntax: :history [num]"
1534 resumes <- io $ GHC.getResumeContext s
1536 [] -> io $ putStrLn "Not stopped at a breakpoint"
1538 let hist = GHC.resumeHistory r
1539 (took,rest) = splitAt num hist
1540 spans <- mapM (io . GHC.getHistorySpan s) took
1541 let nums = map (printf "-%-3d:") [(1::Int)..]
1542 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1543 io $ putStrLn $ if null rest then "<end of history>" else "..."
1545 backCmd :: String -> GHCi ()
1546 backCmd = noArgs $ do
1548 (names, ix, span) <- io $ GHC.back s
1549 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1550 mapM_ (showTypeOfName s) names
1551 -- run the command set with ":set stop <cmd>"
1553 enqueueCommands [stop st]
1555 forwardCmd :: String -> GHCi ()
1556 forwardCmd = noArgs $ do
1558 (names, ix, span) <- io $ GHC.forward s
1559 printForUser $ (if (ix == 0)
1560 then ptext SLIT("Stopped at")
1561 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1562 mapM_ (showTypeOfName s) names
1563 -- run the command set with ":set stop <cmd>"
1565 enqueueCommands [stop st]
1567 -- handle the "break" command
1568 breakCmd :: String -> GHCi ()
1569 breakCmd argLine = do
1570 session <- getSession
1571 breakSwitch session $ words argLine
1573 breakSwitch :: Session -> [String] -> GHCi ()
1574 breakSwitch _session [] = do
1575 io $ putStrLn "The break command requires at least one argument."
1576 breakSwitch session args@(arg1:rest)
1577 | looksLikeModuleName arg1 = do
1578 mod <- wantInterpretedModule arg1
1579 breakByModule session mod rest
1580 | all isDigit arg1 = do
1581 (toplevel, _) <- io $ GHC.getContext session
1583 (mod : _) -> breakByModuleLine mod (read arg1) rest
1585 io $ putStrLn "Cannot find default module for breakpoint."
1586 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1587 | otherwise = do -- try parsing it as an identifier
1588 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1589 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1590 if GHC.isGoodSrcLoc loc
1591 then findBreakAndSet (GHC.nameModule name) $
1592 findBreakByCoord (Just (GHC.srcLocFile loc))
1593 (GHC.srcLocLine loc,
1595 else noCanDo name $ text "can't find its location: " <> ppr loc
1597 noCanDo n why = printForUser $
1598 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1600 breakByModule :: Session -> Module -> [String] -> GHCi ()
1601 breakByModule session mod args@(arg1:rest)
1602 | all isDigit arg1 = do -- looks like a line number
1603 breakByModuleLine mod (read arg1) rest
1604 | otherwise = io $ putStrLn "Invalid arguments to :break"
1606 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1607 breakByModuleLine mod line args
1608 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1609 | [col] <- args, all isDigit col =
1610 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1611 | otherwise = io $ putStrLn "Invalid arguments to :break"
1613 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1614 findBreakAndSet mod lookupTickTree = do
1615 tickArray <- getTickArray mod
1616 (breakArray, _) <- getModBreak mod
1617 case lookupTickTree tickArray of
1618 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1619 Just (tick, span) -> do
1620 success <- io $ setBreakFlag True breakArray tick
1621 session <- getSession
1625 recordBreak $ BreakLocation
1632 text "Breakpoint " <> ppr nm <>
1634 then text " was already set at " <> ppr span
1635 else text " activated at " <> ppr span
1637 printForUser $ text "Breakpoint could not be activated at"
1640 -- When a line number is specified, the current policy for choosing
1641 -- the best breakpoint is this:
1642 -- - the leftmost complete subexpression on the specified line, or
1643 -- - the leftmost subexpression starting on the specified line, or
1644 -- - the rightmost subexpression enclosing the specified line
1646 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1647 findBreakByLine line arr
1648 | not (inRange (bounds arr) line) = Nothing
1650 listToMaybe (sortBy leftmost_largest complete) `mplus`
1651 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1652 listToMaybe (sortBy rightmost ticks)
1656 starts_here = [ tick | tick@(nm,span) <- ticks,
1657 GHC.srcSpanStartLine span == line ]
1659 (complete,incomplete) = partition ends_here starts_here
1660 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1662 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1663 -> Maybe (BreakIndex,SrcSpan)
1664 findBreakByCoord mb_file (line, col) arr
1665 | not (inRange (bounds arr) line) = Nothing
1667 listToMaybe (sortBy rightmost contains)
1671 -- the ticks that span this coordinate
1672 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1673 is_correct_file span ]
1675 is_correct_file span
1676 | Just f <- mb_file = GHC.srcSpanFile span == f
1680 leftmost_smallest (_,a) (_,b) = a `compare` b
1681 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1683 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1684 rightmost (_,a) (_,b) = b `compare` a
1686 spans :: SrcSpan -> (Int,Int) -> Bool
1687 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1688 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1690 start_bold = BS.pack "\ESC[1m"
1691 end_bold = BS.pack "\ESC[0m"
1693 listCmd :: String -> GHCi ()
1695 mb_span <- getCurrentBreakSpan
1697 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1698 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1699 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1700 listCmd str = list2 (words str)
1702 list2 [arg] | all isDigit arg = do
1703 session <- getSession
1704 (toplevel, _) <- io $ GHC.getContext session
1706 [] -> io $ putStrLn "No module to list"
1707 (mod : _) -> listModuleLine mod (read arg)
1708 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1709 mod <- wantInterpretedModule arg1
1710 listModuleLine mod (read arg2)
1712 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1713 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1714 if GHC.isGoodSrcLoc loc
1716 tickArray <- getTickArray (GHC.nameModule name)
1717 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1718 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1721 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1722 Just (_,span) -> io $ listAround span False
1724 noCanDo name $ text "can't find its location: " <>
1727 noCanDo n why = printForUser $
1728 text "cannot list source code for " <> ppr n <> text ": " <> why
1730 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1732 listModuleLine :: Module -> Int -> GHCi ()
1733 listModuleLine modl line = do
1734 session <- getSession
1735 graph <- io (GHC.getModuleGraph session)
1736 let this = filter ((== modl) . GHC.ms_mod) graph
1738 [] -> panic "listModuleLine"
1740 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1741 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1742 io $ listAround (GHC.srcLocSpan loc) False
1744 -- | list a section of a source file around a particular SrcSpan.
1745 -- If the highlight flag is True, also highlight the span using
1746 -- start_bold/end_bold.
1747 listAround span do_highlight = do
1748 contents <- BS.readFile (unpackFS file)
1750 lines = BS.split '\n' contents
1751 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1752 drop (line1 - 1 - pad_before) $ lines
1753 fst_line = max 1 (line1 - pad_before)
1754 line_nos = [ fst_line .. ]
1756 highlighted | do_highlight = zipWith highlight line_nos these_lines
1757 | otherwise = these_lines
1759 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1760 prefixed = zipWith BS.append bs_line_nos highlighted
1762 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1764 file = GHC.srcSpanFile span
1765 line1 = GHC.srcSpanStartLine span
1766 col1 = GHC.srcSpanStartCol span
1767 line2 = GHC.srcSpanEndLine span
1768 col2 = GHC.srcSpanEndCol span
1770 pad_before | line1 == 1 = 0
1775 | no == line1 && no == line2
1776 = let (a,r) = BS.splitAt col1 line
1777 (b,c) = BS.splitAt (col2-col1) r
1779 BS.concat [a,start_bold,b,end_bold,c]
1781 = let (a,b) = BS.splitAt col1 line in
1782 BS.concat [a, start_bold, b]
1784 = let (a,b) = BS.splitAt col2 line in
1785 BS.concat [a, end_bold, b]
1788 -- --------------------------------------------------------------------------
1791 getTickArray :: Module -> GHCi TickArray
1792 getTickArray modl = do
1794 let arrmap = tickarrays st
1795 case lookupModuleEnv arrmap modl of
1796 Just arr -> return arr
1798 (breakArray, ticks) <- getModBreak modl
1799 let arr = mkTickArray (assocs ticks)
1800 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1803 discardTickArrays :: GHCi ()
1804 discardTickArrays = do
1806 setGHCiState st{tickarrays = emptyModuleEnv}
1808 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1810 = accumArray (flip (:)) [] (1, max_line)
1811 [ (line, (nm,span)) | (nm,span) <- ticks,
1812 line <- srcSpanLines span ]
1814 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1815 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1816 GHC.srcSpanEndLine span ]
1818 lookupModule :: String -> GHCi Module
1819 lookupModule modName
1820 = do session <- getSession
1821 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1823 -- don't reset the counter back to zero?
1824 discardActiveBreakPoints :: GHCi ()
1825 discardActiveBreakPoints = do
1827 mapM (turnOffBreak.snd) (breaks st)
1828 setGHCiState $ st { breaks = [] }
1830 deleteBreak :: Int -> GHCi ()
1831 deleteBreak identity = do
1833 let oldLocations = breaks st
1834 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1836 then printForUser (text "Breakpoint" <+> ppr identity <+>
1837 text "does not exist")
1839 mapM (turnOffBreak.snd) this
1840 setGHCiState $ st { breaks = rest }
1842 turnOffBreak loc = do
1843 (arr, _) <- getModBreak (breakModule loc)
1844 io $ setBreakFlag False arr (breakTick loc)
1846 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1847 getModBreak mod = do
1848 session <- getSession
1849 Just mod_info <- io $ GHC.getModuleInfo session mod
1850 let modBreaks = GHC.modInfoModBreaks mod_info
1851 let array = GHC.modBreaks_flags modBreaks
1852 let ticks = GHC.modBreaks_locs modBreaks
1853 return (array, ticks)
1855 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1856 setBreakFlag toggle array index
1857 | toggle = GHC.setBreakOn array index
1858 | otherwise = GHC.setBreakOff array index