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
78 import Foreign.StablePtr ( newStablePtr )
79 import GHC.Exts ( unsafeCoerce# )
80 import GHC.IOBase ( IOErrorType(InvalidArgument) )
82 import Data.IORef ( IORef, readIORef, writeIORef )
84 import System.Posix.Internals ( setNonBlockingFD )
86 -----------------------------------------------------------------------------
90 " / _ \\ /\\ /\\/ __(_)\n"++
91 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
92 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
93 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
95 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
98 GLOBAL_VAR(commands, builtin_commands, [Command])
100 builtin_commands :: [Command]
102 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
103 ("?", keepGoing help, False, completeNone),
104 ("add", keepGoingPaths addModule, False, completeFilename),
105 ("abandon", keepGoing abandonCmd, False, completeNone),
106 ("break", keepGoing breakCmd, False, completeIdentifier),
107 ("back", keepGoing backCmd, False, completeNone),
108 ("browse", keepGoing browseCmd, False, completeModule),
109 ("cd", keepGoing changeDirectory, False, completeFilename),
110 ("check", keepGoing checkModule, False, completeHomeModule),
111 ("continue", continueCmd, False, completeNone),
112 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
113 ("def", keepGoing defineMacro, False, completeIdentifier),
114 ("delete", keepGoing deleteCmd, False, completeNone),
115 ("e", keepGoing editFile, False, completeFilename),
116 ("edit", keepGoing editFile, False, completeFilename),
117 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
118 ("force", keepGoing forceCmd, False, completeIdentifier),
119 ("forward", keepGoing forwardCmd, False, completeNone),
120 ("help", keepGoing help, False, completeNone),
121 ("history", keepGoing historyCmd, False, completeNone),
122 ("info", keepGoing info, False, completeIdentifier),
123 ("kind", keepGoing kindOfType, False, completeIdentifier),
124 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
125 ("list", keepGoing listCmd, False, completeNone),
126 ("module", keepGoing setContext, False, completeModule),
127 ("main", keepGoing runMain, False, completeIdentifier),
128 ("print", keepGoing printCmd, False, completeIdentifier),
129 ("quit", quit, False, completeNone),
130 ("reload", keepGoing reloadModule, False, completeNone),
131 ("set", keepGoing setCmd, True, completeSetOptions),
132 ("show", keepGoing showCmd, False, completeNone),
133 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
134 ("step", stepCmd, False, completeIdentifier),
135 ("type", keepGoing typeOfExpr, False, completeIdentifier),
136 ("trace", traceCmd, False, completeIdentifier),
137 ("undef", keepGoing undefineMacro, False, completeMacro),
138 ("unset", keepGoing unsetOptions, True, completeSetOptions)
141 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
142 keepGoing a str = a str >> return False
144 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
145 keepGoingPaths a str = a (toArgs str) >> return False
147 shortHelpText = "use :? for help.\n"
150 " Commands available from the prompt:\n" ++
152 " <stmt> evaluate/run <stmt>\n" ++
153 " :add <filename> ... add module(s) to the current target set\n" ++
154 " :abandon at a breakpoint, abandon current computation\n" ++
155 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
156 " :break <name> set a breakpoint on the specified function\n" ++
157 " :browse [*]<module> display the names defined by <module>\n" ++
158 " :cd <dir> change directory to <dir>\n" ++
159 " :continue resume after a breakpoint\n" ++
160 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
161 " :def <cmd> <expr> define a command :<cmd>\n" ++
162 " :delete <number> delete the specified breakpoint\n" ++
163 " :delete * delete all breakpoints\n" ++
164 " :edit <file> edit file\n" ++
165 " :edit edit last module\n" ++
166 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
167 -- " :force <expr> print <expr>, forcing unevaluated parts\n" ++
168 " :help, :? display this list of commands\n" ++
169 " :info [<name> ...] display information about the given names\n" ++
170 " :kind <type> show the kind of <type>\n" ++
171 " :load <filename> ... load module(s) and their dependents\n" ++
172 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
173 " :main [<arguments> ...] run the main function with the given arguments\n" ++
174 " :print [<name> ...] prints a value without forcing its computation\n" ++
175 " :quit exit GHCi\n" ++
176 " :reload reload the current module set\n" ++
178 " :set <option> ... set options\n" ++
179 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
180 " :set prog <progname> set the value returned by System.getProgName\n" ++
181 " :set prompt <prompt> set the prompt used in GHCi\n" ++
182 " :set editor <cmd> set the command used for :edit\n" ++
183 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
185 " :show breaks show active breakpoints\n" ++
186 " :show context show the breakpoint context\n" ++
187 " :show modules show the currently loaded modules\n" ++
188 " :show bindings show the current bindings made at the prompt\n" ++
190 " :sprint [<name> ...] simplifed version of :print\n" ++
191 " :step single-step after stopping at a breakpoint\n"++
192 " :step <expr> single-step into <expr>\n"++
193 " :type <expr> show the type of <expr>\n" ++
194 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
195 " :unset <option> ... unset options\n" ++
196 " :!<command> run the shell command <command>\n" ++
198 " Options for ':set' and ':unset':\n" ++
200 " +r revert top-level expressions after each evaluation\n" ++
201 " +s print timing/memory stats after each evaluation\n" ++
202 " +t print type after evaluation\n" ++
203 " -<flags> most GHC command line flags can also be set here\n" ++
204 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
206 -- Todo: add help for breakpoint commands here
212 win <- System.Win32.getWindowsDirectory
213 return (win `joinFileName` "notepad.exe")
218 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
219 interactiveUI session srcs maybe_expr = do
220 -- HACK! If we happen to get into an infinite loop (eg the user
221 -- types 'let x=x in x' at the prompt), then the thread will block
222 -- on a blackhole, and become unreachable during GC. The GC will
223 -- detect that it is unreachable and send it the NonTermination
224 -- exception. However, since the thread is unreachable, everything
225 -- it refers to might be finalized, including the standard Handles.
226 -- This sounds like a bug, but we don't have a good solution right
232 -- Initialise buffering for the *interpreted* I/O system
233 initInterpBuffering session
235 when (isNothing maybe_expr) $ do
236 -- Only for GHCi (not runghc and ghc -e):
237 -- Turn buffering off for the compiled program's stdout/stderr
239 -- Turn buffering off for GHCi's stdout
241 hSetBuffering stdout NoBuffering
242 -- We don't want the cmd line to buffer any input that might be
243 -- intended for the program, so unbuffer stdin.
244 hSetBuffering stdin NoBuffering
246 -- initial context is just the Prelude
247 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
248 GHC.setContext session [] [prel_mod]
252 Readline.setAttemptedCompletionFunction (Just completeWord)
253 --Readline.parseAndBind "set show-all-if-ambiguous 1"
255 let symbols = "!#$%&*+/<=>?@\\^|-~"
256 specials = "(),;[]`{}"
258 word_break_chars = spaces ++ specials ++ symbols
260 Readline.setBasicWordBreakCharacters word_break_chars
261 Readline.setCompleterWordBreakCharacters word_break_chars
264 default_editor <- findEditor
266 startGHCi (runGHCi srcs maybe_expr)
267 GHCiState{ progname = "<interactive>",
271 editor = default_editor,
277 tickarrays = emptyModuleEnv
281 Readline.resetTerminal Nothing
286 prel_name = GHC.mkModuleName "Prelude"
288 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
289 runGHCi paths maybe_expr = do
290 let read_dot_files = not opt_IgnoreDotGhci
292 when (read_dot_files) $ do
295 exists <- io (doesFileExist file)
297 dir_ok <- io (checkPerms ".")
298 file_ok <- io (checkPerms file)
299 when (dir_ok && file_ok) $ do
300 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
303 Right hdl -> fileLoop hdl False
305 when (read_dot_files) $ do
306 -- Read in $HOME/.ghci
307 either_dir <- io (IO.try (getEnv "HOME"))
311 cwd <- io (getCurrentDirectory)
312 when (dir /= cwd) $ do
313 let file = dir ++ "/.ghci"
314 ok <- io (checkPerms file)
316 either_hdl <- io (IO.try (openFile file ReadMode))
319 Right hdl -> fileLoop hdl False
321 -- Perform a :load for files given on the GHCi command line
322 -- When in -e mode, if the load fails then we want to stop
323 -- immediately rather than going on to evaluate the expression.
324 when (not (null paths)) $ do
325 ok <- ghciHandle (\e -> do showException e; return Failed) $
327 when (isJust maybe_expr && failed ok) $
328 io (exitWith (ExitFailure 1))
330 -- if verbosity is greater than 0, or we are connected to a
331 -- terminal, display the prompt in the interactive loop.
332 is_tty <- io (hIsTerminalDevice stdin)
333 dflags <- getDynFlags
334 let show_prompt = verbosity dflags > 0 || is_tty
339 #if defined(mingw32_HOST_OS)
340 -- The win32 Console API mutates the first character of
341 -- type-ahead when reading from it in a non-buffered manner. Work
342 -- around this by flushing the input buffer of type-ahead characters,
343 -- but only if stdin is available.
344 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
346 Left err | isDoesNotExistError err -> return ()
347 | otherwise -> io (ioError err)
348 Right () -> return ()
350 -- initialise the console if necessary
353 -- enter the interactive loop
354 interactiveLoop is_tty show_prompt
356 -- just evaluate the expression we were given
361 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
364 interactiveLoop is_tty show_prompt =
365 -- Ignore ^C exceptions caught here
366 ghciHandleDyn (\e -> case e of
368 #if defined(mingw32_HOST_OS)
371 interactiveLoop is_tty show_prompt
372 _other -> return ()) $
374 ghciUnblock $ do -- unblock necessary if we recursed from the
375 -- exception handler above.
377 -- read commands from stdin
381 else fileLoop stdin show_prompt
383 fileLoop stdin show_prompt
387 -- NOTE: We only read .ghci files if they are owned by the current user,
388 -- and aren't world writable. Otherwise, we could be accidentally
389 -- running code planted by a malicious third party.
391 -- Furthermore, We only read ./.ghci if . is owned by the current user
392 -- and isn't writable by anyone else. I think this is sufficient: we
393 -- don't need to check .. and ../.. etc. because "." always refers to
394 -- the same directory while a process is running.
396 checkPerms :: String -> IO Bool
398 #ifdef mingw32_HOST_OS
401 Util.handle (\_ -> return False) $ do
402 st <- getFileStatus name
404 if fileOwner st /= me then do
405 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
408 let mode = fileMode st
409 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
410 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
412 putStrLn $ "*** WARNING: " ++ name ++
413 " is writable by someone else, IGNORING!"
418 fileLoop :: Handle -> Bool -> GHCi ()
419 fileLoop hdl show_prompt = do
420 when show_prompt $ do
423 l <- io (IO.try (hGetLine hdl))
425 Left e | isEOFError e -> return ()
426 | InvalidArgument <- etype -> return ()
427 | otherwise -> io (ioError e)
428 where etype = ioeGetErrorType e
429 -- treat InvalidArgument in the same way as EOF:
430 -- this can happen if the user closed stdin, or
431 -- perhaps did getContents which closes stdin at
434 case removeSpaces l of
435 "" -> fileLoop hdl show_prompt
436 l -> do quit <- runCommand l
437 if quit then return () else fileLoop hdl show_prompt
439 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
440 stringLoop [] = return False
441 stringLoop (s:ss) = do
442 case removeSpaces s of
444 l -> do quit <- runCommand l
445 if quit then return True else stringLoop ss
448 session <- getSession
449 (toplevs,exports) <- io (GHC.getContext session)
450 resumes <- io $ GHC.getResumeContext session
456 let ix = GHC.resumeHistoryIx r
458 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
460 let hist = GHC.resumeHistory r !! (ix-1)
461 span <- io $ GHC.getHistorySpan session hist
462 return (brackets (ppr (negate ix) <> char ':'
463 <+> ppr span) <> space)
465 dots | r:rs <- resumes, not (null rs) = text "... "
469 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
470 hsep (map (ppr . GHC.moduleName) exports)
472 deflt_prompt = dots <> context_bit <> modules_bit
474 f ('%':'s':xs) = deflt_prompt <> f xs
475 f ('%':'%':xs) = char '%' <> f xs
476 f (x:xs) = char x <> f xs
480 return (showSDoc (f (prompt st)))
484 readlineLoop :: GHCi ()
486 session <- getSession
487 (mod,imports) <- io (GHC.getContext session)
489 saveSession -- for use by completion
491 mb_span <- getCurrentBreakSpan
493 l <- io (readline prompt `finally` setNonBlockingFD 0)
494 -- readline sometimes puts stdin into blocking mode,
495 -- so we need to put it back for the IO library
500 case removeSpaces l of
505 if quit then return () else readlineLoop
508 runCommand :: String -> GHCi Bool
509 runCommand c = ghciHandle handler (doCommand c)
511 doCommand (':' : command) = specialCommand command
513 = do timeIt $ runStmt stmt GHC.RunToCompletion
516 -- This version is for the GHC command-line option -e. The only difference
517 -- from runCommand is that it catches the ExitException exception and
518 -- exits, rather than printing out the exception.
519 runCommandEval c = ghciHandle handleEval (doCommand c)
521 handleEval (ExitException code) = io (exitWith code)
522 handleEval e = do handler e
523 io (exitWith (ExitFailure 1))
525 doCommand (':' : command) = specialCommand command
527 = do r <- runStmt stmt GHC.RunToCompletion
529 False -> io (exitWith (ExitFailure 1))
530 -- failure to run the command causes exit(1) for ghc -e.
533 runStmt :: String -> SingleStep -> GHCi Bool
535 | null (filter (not.isSpace) stmt) = return False
537 = do st <- getGHCiState
538 session <- getSession
539 result <- io $ withProgName (progname st) $ withArgs (args st) $
540 GHC.runStmt session stmt step
545 afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
546 afterRunStmt run_result = do
547 mb_result <- switchOnRunResult run_result
548 -- possibly print the type and revert CAFs after evaluating an expression
549 show_types <- isOptionSet ShowType
550 session <- getSession
553 Just (is_break,names) ->
554 when (is_break || show_types) $
555 mapM_ (showTypeOfName session) names
558 io installSignalHandlers
559 b <- isOptionSet RevertCAFs
560 io (when b revertCAFs)
565 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
566 switchOnRunResult GHC.RunFailed = return Nothing
567 switchOnRunResult (GHC.RunException e) = throw e
568 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
569 switchOnRunResult (GHC.RunBreak threadId names info) = do
570 session <- getSession
571 Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
572 let modBreaks = GHC.modInfoModBreaks mod_info
573 let ticks = GHC.modBreaks_locs modBreaks
575 -- display information about the breakpoint
576 let location = ticks ! GHC.breakInfo_number info
577 printForUser $ ptext SLIT("Stopped at") <+> ppr location
579 -- run the command set with ":set stop <cmd>"
583 return (Just (True,names))
586 showTypeOfName :: Session -> Name -> GHCi ()
587 showTypeOfName session n
588 = do maybe_tything <- io (GHC.lookupName session n)
589 case maybe_tything of
591 Just thing -> showTyThing thing
593 specialCommand :: String -> GHCi Bool
594 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
595 specialCommand str = do
596 let (cmd,rest) = break isSpace str
597 maybe_cmd <- io (lookupCommand cmd)
599 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
600 ++ shortHelpText) >> return False)
601 Just (_,f,_,_) -> f (dropWhile isSpace rest)
603 lookupCommand :: String -> IO (Maybe Command)
604 lookupCommand str = do
605 cmds <- readIORef commands
606 -- look for exact match first, then the first prefix match
607 case [ c | c <- cmds, str == cmdName c ] of
608 c:_ -> return (Just c)
609 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
611 c:_ -> return (Just c)
614 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
615 getCurrentBreakSpan = do
616 session <- getSession
617 resumes <- io $ GHC.getResumeContext session
621 let ix = GHC.resumeHistoryIx r
623 then return (Just (GHC.resumeSpan r))
625 let hist = GHC.resumeHistory r !! (ix-1)
626 span <- io $ GHC.getHistorySpan session hist
629 -----------------------------------------------------------------------------
632 noArgs :: GHCi () -> String -> GHCi ()
634 noArgs m _ = io $ putStrLn "This command takes no arguments"
636 help :: String -> GHCi ()
637 help _ = io (putStr helpText)
639 info :: String -> GHCi ()
640 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
641 info s = do { let names = words s
642 ; session <- getSession
643 ; dflags <- getDynFlags
644 ; let exts = dopt Opt_GlasgowExts dflags
645 ; mapM_ (infoThing exts session) names }
647 infoThing exts session str = io $ do
648 names <- GHC.parseName session str
649 let filtered = filterOutChildren names
650 mb_stuffs <- mapM (GHC.getInfo session) filtered
651 unqual <- GHC.getPrintUnqual session
652 putStrLn (showSDocForUser unqual $
653 vcat (intersperse (text "") $
654 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
656 -- Filter out names whose parent is also there Good
657 -- example is '[]', which is both a type and data
658 -- constructor in the same type
659 filterOutChildren :: [Name] -> [Name]
660 filterOutChildren names = filter (not . parent_is_there) names
661 where parent_is_there n
662 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
666 pprInfo exts (thing, fixity, insts)
667 = pprTyThingInContextLoc exts thing
668 $$ show_fixity fixity
669 $$ vcat (map GHC.pprInstance insts)
672 | fix == GHC.defaultFixity = empty
673 | otherwise = ppr fix <+> ppr (GHC.getName thing)
675 runMain :: String -> GHCi ()
677 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
678 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
681 addModule :: [FilePath] -> GHCi ()
683 io (revertCAFs) -- always revert CAFs on load/add.
684 files <- mapM expandPath files
685 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
686 session <- getSession
687 io (mapM_ (GHC.addTarget session) targets)
688 ok <- io (GHC.load session LoadAllTargets)
691 changeDirectory :: String -> GHCi ()
692 changeDirectory dir = do
693 session <- getSession
694 graph <- io (GHC.getModuleGraph session)
695 when (not (null graph)) $
696 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
697 io (GHC.setTargets session [])
698 io (GHC.load session LoadAllTargets)
699 setContextAfterLoad session []
700 io (GHC.workingDirectoryChanged session)
701 dir <- expandPath dir
702 io (setCurrentDirectory dir)
704 editFile :: String -> GHCi ()
707 -- find the name of the "topmost" file loaded
708 session <- getSession
709 graph0 <- io (GHC.getModuleGraph session)
710 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
711 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
712 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
713 Just file -> do_edit file
714 Nothing -> throwDyn (CmdLineError "unknown file name")
715 | otherwise = do_edit str
721 throwDyn (CmdLineError "editor not set, use :set editor")
722 io $ system (cmd ++ ' ':file)
725 defineMacro :: String -> GHCi ()
727 let (macro_name, definition) = break isSpace s
728 cmds <- io (readIORef commands)
730 then throwDyn (CmdLineError "invalid macro name")
732 if (macro_name `elem` map cmdName cmds)
733 then throwDyn (CmdLineError
734 ("command '" ++ macro_name ++ "' is already defined"))
737 -- give the expression a type signature, so we can be sure we're getting
738 -- something of the right type.
739 let new_expr = '(' : definition ++ ") :: String -> IO String"
741 -- compile the expression
743 maybe_hv <- io (GHC.compileExpr cms new_expr)
746 Just hv -> io (writeIORef commands --
747 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
749 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
751 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
752 stringLoop (lines str)
754 undefineMacro :: String -> GHCi ()
755 undefineMacro macro_name = do
756 cmds <- io (readIORef commands)
757 if (macro_name `elem` map cmdName builtin_commands)
758 then throwDyn (CmdLineError
759 ("command '" ++ macro_name ++ "' cannot be undefined"))
761 if (macro_name `notElem` map cmdName cmds)
762 then throwDyn (CmdLineError
763 ("command '" ++ macro_name ++ "' not defined"))
765 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
768 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
769 loadModule fs = timeIt (loadModule' fs)
771 loadModule_ :: [FilePath] -> GHCi ()
772 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
774 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
775 loadModule' files = do
776 session <- getSession
779 io (GHC.setTargets session [])
780 io (GHC.load session LoadAllTargets)
783 let (filenames, phases) = unzip files
784 exp_filenames <- mapM expandPath filenames
785 let files' = zip exp_filenames phases
786 targets <- io (mapM (uncurry GHC.guessTarget) files')
788 -- NOTE: we used to do the dependency anal first, so that if it
789 -- fails we didn't throw away the current set of modules. This would
790 -- require some re-working of the GHC interface, so we'll leave it
791 -- as a ToDo for now.
793 io (GHC.setTargets session targets)
794 ok <- io (GHC.load session LoadAllTargets)
798 checkModule :: String -> GHCi ()
800 let modl = GHC.mkModuleName m
801 session <- getSession
802 result <- io (GHC.checkModule session modl)
804 Nothing -> io $ putStrLn "Nothing"
805 Just r -> io $ putStrLn (showSDoc (
806 case GHC.checkedModuleInfo r of
807 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
809 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
811 (text "global names: " <+> ppr global) $$
812 (text "local names: " <+> ppr local)
814 afterLoad (successIf (isJust result)) session
816 reloadModule :: String -> GHCi ()
818 io (revertCAFs) -- always revert CAFs on reload.
819 session <- getSession
820 ok <- io (GHC.load session LoadAllTargets)
823 io (revertCAFs) -- always revert CAFs on reload.
824 session <- getSession
825 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
828 afterLoad ok session = do
829 io (revertCAFs) -- always revert CAFs on load.
831 discardActiveBreakPoints
832 graph <- io (GHC.getModuleGraph session)
833 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
834 setContextAfterLoad session graph'
835 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
837 setContextAfterLoad session [] = do
838 prel_mod <- getPrelude
839 io (GHC.setContext session [] [prel_mod])
840 setContextAfterLoad session ms = do
841 -- load a target if one is available, otherwise load the topmost module.
842 targets <- io (GHC.getTargets session)
843 case [ m | Just m <- map (findTarget ms) targets ] of
845 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
846 load_this (last graph')
851 = case filter (`matches` t) ms of
855 summary `matches` Target (TargetModule m) _
856 = GHC.ms_mod_name summary == m
857 summary `matches` Target (TargetFile f _) _
858 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
859 summary `matches` target
862 load_this summary | m <- GHC.ms_mod summary = do
863 b <- io (GHC.moduleIsInterpreted session m)
864 if b then io (GHC.setContext session [m] [])
866 prel_mod <- getPrelude
867 io (GHC.setContext session [] [prel_mod,m])
870 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
871 modulesLoadedMsg ok mods = do
872 dflags <- getDynFlags
873 when (verbosity dflags > 0) $ do
875 | null mods = text "none."
877 punctuate comma (map ppr mods)) <> text "."
880 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
882 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
885 typeOfExpr :: String -> GHCi ()
887 = do cms <- getSession
888 maybe_ty <- io (GHC.exprType cms str)
891 Just ty -> do ty' <- cleanType ty
892 printForUser $ text str <> text " :: " <> ppr ty'
894 kindOfType :: String -> GHCi ()
896 = do cms <- getSession
897 maybe_ty <- io (GHC.typeKind cms str)
900 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
902 quit :: String -> GHCi Bool
905 shellEscape :: String -> GHCi Bool
906 shellEscape str = io (system str >> return False)
908 -----------------------------------------------------------------------------
909 -- Browsing a module's contents
911 browseCmd :: String -> GHCi ()
914 ['*':m] | looksLikeModuleName m -> browseModule m False
915 [m] | looksLikeModuleName m -> browseModule m True
916 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
918 browseModule m exports_only = do
920 modl <- if exports_only then lookupModule m
921 else wantInterpretedModule m
923 -- Temporarily set the context to the module we're interested in,
924 -- just so we can get an appropriate PrintUnqualified
925 (as,bs) <- io (GHC.getContext s)
926 prel_mod <- getPrelude
927 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
928 else GHC.setContext s [modl] [])
929 unqual <- io (GHC.getPrintUnqual s)
930 io (GHC.setContext s as bs)
932 mb_mod_info <- io $ GHC.getModuleInfo s modl
934 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
937 | exports_only = GHC.modInfoExports mod_info
938 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
940 filtered = filterOutChildren names
942 things <- io $ mapM (GHC.lookupName s) filtered
944 dflags <- getDynFlags
945 let exts = dopt Opt_GlasgowExts dflags
946 io (putStrLn (showSDocForUser unqual (
947 vcat (map (pprTyThingInContext exts) (catMaybes things))
949 -- ToDo: modInfoInstances currently throws an exception for
950 -- package modules. When it works, we can do this:
951 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
953 -----------------------------------------------------------------------------
954 -- Setting the module context
957 | all sensible mods = fn mods
958 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
960 (fn, mods) = case str of
961 '+':stuff -> (addToContext, words stuff)
962 '-':stuff -> (removeFromContext, words stuff)
963 stuff -> (newContext, words stuff)
965 sensible ('*':m) = looksLikeModuleName m
966 sensible m = looksLikeModuleName m
968 separate :: Session -> [String] -> [Module] -> [Module]
969 -> GHCi ([Module],[Module])
970 separate session [] as bs = return (as,bs)
971 separate session (('*':str):ms) as bs = do
972 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
973 b <- io $ GHC.moduleIsInterpreted session m
974 if b then separate session ms (m:as) bs
975 else throwDyn (CmdLineError ("module '"
976 ++ GHC.moduleNameString (GHC.moduleName m)
977 ++ "' is not interpreted"))
978 separate session (str:ms) as bs = do
979 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
980 separate session ms as (m:bs)
982 newContext :: [String] -> GHCi ()
985 (as,bs) <- separate s strs [] []
986 prel_mod <- getPrelude
987 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
988 io $ GHC.setContext s as bs'
991 addToContext :: [String] -> GHCi ()
992 addToContext strs = do
994 (as,bs) <- io $ GHC.getContext s
996 (new_as,new_bs) <- separate s strs [] []
998 let as_to_add = new_as \\ (as ++ bs)
999 bs_to_add = new_bs \\ (as ++ bs)
1001 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1004 removeFromContext :: [String] -> GHCi ()
1005 removeFromContext strs = do
1007 (as,bs) <- io $ GHC.getContext s
1009 (as_to_remove,bs_to_remove) <- separate s strs [] []
1011 let as' = as \\ (as_to_remove ++ bs_to_remove)
1012 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1014 io $ GHC.setContext s as' bs'
1016 ----------------------------------------------------------------------------
1019 -- set options in the interpreter. Syntax is exactly the same as the
1020 -- ghc command line, except that certain options aren't available (-C,
1023 -- This is pretty fragile: most options won't work as expected. ToDo:
1024 -- figure out which ones & disallow them.
1026 setCmd :: String -> GHCi ()
1028 = do st <- getGHCiState
1029 let opts = options st
1030 io $ putStrLn (showSDoc (
1031 text "options currently set: " <>
1034 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1037 = case toArgs str of
1038 ("args":args) -> setArgs args
1039 ("prog":prog) -> setProg prog
1040 ("prompt":prompt) -> setPrompt (after 6)
1041 ("editor":cmd) -> setEditor (after 6)
1042 ("stop":cmd) -> setStop (after 4)
1043 wds -> setOptions wds
1044 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1048 setGHCiState st{ args = args }
1052 setGHCiState st{ progname = prog }
1054 io (hPutStrLn stderr "syntax: :set prog <progname>")
1058 setGHCiState st{ editor = cmd }
1062 setGHCiState st{ stop = cmd }
1064 setPrompt value = do
1067 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1068 else setGHCiState st{ prompt = remQuotes value }
1070 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1074 do -- first, deal with the GHCi opts (+s, +t, etc.)
1075 let (plus_opts, minus_opts) = partition isPlus wds
1076 mapM_ setOpt plus_opts
1078 -- then, dynamic flags
1079 dflags <- getDynFlags
1080 let pkg_flags = packageFlags dflags
1081 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1083 if (not (null leftovers))
1084 then throwDyn (CmdLineError ("unrecognised flags: " ++
1088 new_pkgs <- setDynFlags dflags'
1090 -- if the package flags changed, we should reset the context
1091 -- and link the new packages.
1092 dflags <- getDynFlags
1093 when (packageFlags dflags /= pkg_flags) $ do
1094 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1095 session <- getSession
1096 io (GHC.setTargets session [])
1097 io (GHC.load session LoadAllTargets)
1098 io (linkPackages dflags new_pkgs)
1099 setContextAfterLoad session []
1103 unsetOptions :: String -> GHCi ()
1105 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1106 let opts = words str
1107 (minus_opts, rest1) = partition isMinus opts
1108 (plus_opts, rest2) = partition isPlus rest1
1110 if (not (null rest2))
1111 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1114 mapM_ unsetOpt plus_opts
1116 -- can't do GHC flags for now
1117 if (not (null minus_opts))
1118 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1121 isMinus ('-':s) = True
1124 isPlus ('+':s) = True
1128 = case strToGHCiOpt str of
1129 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1130 Just o -> setOption o
1133 = case strToGHCiOpt str of
1134 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1135 Just o -> unsetOption o
1137 strToGHCiOpt :: String -> (Maybe GHCiOption)
1138 strToGHCiOpt "s" = Just ShowTiming
1139 strToGHCiOpt "t" = Just ShowType
1140 strToGHCiOpt "r" = Just RevertCAFs
1141 strToGHCiOpt _ = Nothing
1143 optToStr :: GHCiOption -> String
1144 optToStr ShowTiming = "s"
1145 optToStr ShowType = "t"
1146 optToStr RevertCAFs = "r"
1148 -- ---------------------------------------------------------------------------
1153 ["modules" ] -> showModules
1154 ["bindings"] -> showBindings
1155 ["linker"] -> io showLinkerState
1156 ["breaks"] -> showBkptTable
1157 ["context"] -> showContext
1158 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]")
1161 session <- getSession
1162 let show_one ms = do m <- io (GHC.showModule session ms)
1164 graph <- io (GHC.getModuleGraph session)
1165 mapM_ show_one graph
1169 unqual <- io (GHC.getPrintUnqual s)
1170 bindings <- io (GHC.getBindings s)
1171 mapM_ showTyThing bindings
1174 showTyThing (AnId id) = do
1175 ty' <- cleanType (GHC.idType id)
1176 printForUser $ ppr id <> text " :: " <> ppr ty'
1177 showTyThing _ = return ()
1179 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1180 cleanType :: Type -> GHCi Type
1182 dflags <- getDynFlags
1183 if dopt Opt_GlasgowExts dflags
1185 else return $! GHC.dropForAlls ty
1187 showBkptTable :: GHCi ()
1190 printForUser $ prettyLocations (breaks st)
1192 showContext :: GHCi ()
1194 session <- getSession
1195 resumes <- io $ GHC.getResumeContext session
1196 printForUser $ vcat (map pp_resume (reverse resumes))
1199 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1200 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1203 -- -----------------------------------------------------------------------------
1206 completeNone :: String -> IO [String]
1207 completeNone w = return []
1210 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1211 completeWord w start end = do
1212 line <- Readline.getLineBuffer
1214 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1216 | Just c <- is_cmd line -> do
1217 maybe_cmd <- lookupCommand c
1218 let (n,w') = selectWord (words' 0 line)
1220 Nothing -> return Nothing
1221 Just (_,_,False,complete) -> wrapCompleter complete w
1222 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1223 return (map (drop n) rets)
1224 in wrapCompleter complete' w'
1226 --printf "complete %s, start = %d, end = %d\n" w start end
1227 wrapCompleter completeIdentifier w
1228 where words' _ [] = []
1229 words' n str = let (w,r) = break isSpace str
1230 (s,r') = span isSpace r
1231 in (n,w):words' (n+length w+length s) r'
1232 -- In a Haskell expression we want to parse 'a-b' as three words
1233 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1234 -- only be a single word.
1235 selectWord [] = (0,w)
1236 selectWord ((offset,x):xs)
1237 | offset+length x >= start = (start-offset,take (end-offset) x)
1238 | otherwise = selectWord xs
1241 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1242 | otherwise = Nothing
1245 cmds <- readIORef commands
1246 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1248 completeMacro w = do
1249 cmds <- readIORef commands
1250 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1251 return (filter (w `isPrefixOf`) cmds')
1253 completeIdentifier w = do
1255 rdrs <- GHC.getRdrNamesInScope s
1256 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1258 completeModule w = do
1260 dflags <- GHC.getSessionDynFlags s
1261 let pkg_mods = allExposedModules dflags
1262 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1264 completeHomeModule w = do
1266 g <- GHC.getModuleGraph s
1267 let home_mods = map GHC.ms_mod_name g
1268 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1270 completeSetOptions w = do
1271 return (filter (w `isPrefixOf`) options)
1272 where options = "args":"prog":allFlags
1274 completeFilename = Readline.filenameCompletionFunction
1276 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1278 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1279 unionComplete f1 f2 w = do
1284 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1285 wrapCompleter fun w = do
1288 [] -> return Nothing
1289 [x] -> return (Just (x,[]))
1290 xs -> case getCommonPrefix xs of
1291 "" -> return (Just ("",xs))
1292 pref -> return (Just (pref,xs))
1294 getCommonPrefix :: [String] -> String
1295 getCommonPrefix [] = ""
1296 getCommonPrefix (s:ss) = foldl common s ss
1297 where common s "" = ""
1299 common (c:cs) (d:ds)
1300 | c == d = c : common cs ds
1303 allExposedModules :: DynFlags -> [ModuleName]
1304 allExposedModules dflags
1305 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1307 pkg_db = pkgIdMap (pkgState dflags)
1309 completeCmd = completeNone
1310 completeMacro = completeNone
1311 completeIdentifier = completeNone
1312 completeModule = completeNone
1313 completeHomeModule = completeNone
1314 completeSetOptions = completeNone
1315 completeFilename = completeNone
1316 completeHomeModuleOrFile=completeNone
1317 completeBkpt = completeNone
1320 -- ---------------------------------------------------------------------------
1321 -- User code exception handling
1323 -- This is the exception handler for exceptions generated by the
1324 -- user's code and exceptions coming from children sessions;
1325 -- it normally just prints out the exception. The
1326 -- handler must be recursive, in case showing the exception causes
1327 -- more exceptions to be raised.
1329 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1330 -- raising another exception. We therefore don't put the recursive
1331 -- handler arond the flushing operation, so if stderr is closed
1332 -- GHCi will just die gracefully rather than going into an infinite loop.
1333 handler :: Exception -> GHCi Bool
1335 handler exception = do
1337 io installSignalHandlers
1338 ghciHandle handler (showException exception >> return False)
1340 showException (DynException dyn) =
1341 case fromDynamic dyn of
1342 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1343 Just Interrupted -> io (putStrLn "Interrupted.")
1344 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1345 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1346 Just other_ghc_ex -> io (print other_ghc_ex)
1348 showException other_exception
1349 = io (putStrLn ("*** Exception: " ++ show other_exception))
1351 -----------------------------------------------------------------------------
1352 -- recursive exception handlers
1354 -- Don't forget to unblock async exceptions in the handler, or if we're
1355 -- in an exception loop (eg. let a = error a in a) the ^C exception
1356 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1358 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1359 ghciHandle h (GHCi m) = GHCi $ \s ->
1360 Exception.catch (m s)
1361 (\e -> unGHCi (ghciUnblock (h e)) s)
1363 ghciUnblock :: GHCi a -> GHCi a
1364 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1367 -- ----------------------------------------------------------------------------
1370 expandPath :: String -> GHCi String
1372 case dropWhile isSpace path of
1374 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1375 return (tilde ++ '/':d)
1379 wantInterpretedModule :: String -> GHCi Module
1380 wantInterpretedModule str = do
1381 session <- getSession
1382 modl <- lookupModule str
1383 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1384 when (not is_interpreted) $
1385 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1388 wantNameFromInterpretedModule noCanDo str and_then = do
1389 session <- getSession
1390 names <- io $ GHC.parseName session str
1394 let modl = GHC.nameModule n
1395 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1396 if not is_interpreted
1397 then noCanDo n $ text "module " <> ppr modl <>
1398 text " is not interpreted"
1401 -- ----------------------------------------------------------------------------
1402 -- Windows console setup
1404 setUpConsole :: IO ()
1406 #ifdef mingw32_HOST_OS
1407 -- On Windows we need to set a known code page, otherwise the characters
1408 -- we read from the console will be be in some strange encoding, and
1409 -- similarly for characters we write to the console.
1411 -- At the moment, GHCi pretends all input is Latin-1. In the
1412 -- future we should support UTF-8, but for now we set the code pages
1415 -- It seems you have to set the font in the console window to
1416 -- a Unicode font in order for output to work properly,
1417 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1418 -- (see MSDN for SetConsoleOutputCP()).
1420 setConsoleCP 28591 -- ISO Latin-1
1421 setConsoleOutputCP 28591 -- ISO Latin-1
1425 -- -----------------------------------------------------------------------------
1426 -- commands for debugger
1428 sprintCmd = pprintCommand False False
1429 printCmd = pprintCommand True False
1430 forceCmd = pprintCommand False True
1432 pprintCommand bind force str = do
1433 session <- getSession
1434 io $ pprintClosureCommand session bind force str
1436 stepCmd :: String -> GHCi Bool
1437 stepCmd [] = doContinue GHC.SingleStep
1438 stepCmd expression = runStmt expression GHC.SingleStep
1440 traceCmd :: String -> GHCi Bool
1441 traceCmd [] = doContinue GHC.RunAndLogSteps
1442 traceCmd expression = runStmt expression GHC.RunAndLogSteps
1444 continueCmd :: String -> GHCi Bool
1445 continueCmd [] = doContinue GHC.RunToCompletion
1446 continueCmd other = do
1447 io $ putStrLn "The continue command accepts no arguments."
1450 doContinue :: SingleStep -> GHCi Bool
1451 doContinue step = do
1452 session <- getSession
1453 runResult <- io $ GHC.resume session step
1454 afterRunStmt runResult
1457 abandonCmd :: String -> GHCi ()
1458 abandonCmd = noArgs $ do
1460 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1461 when (not b) $ io $ putStrLn "There is no computation running."
1464 deleteCmd :: String -> GHCi ()
1465 deleteCmd argLine = do
1466 deleteSwitch $ words argLine
1468 deleteSwitch :: [String] -> GHCi ()
1470 io $ putStrLn "The delete command requires at least one argument."
1471 -- delete all break points
1472 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1473 deleteSwitch idents = do
1474 mapM_ deleteOneBreak idents
1476 deleteOneBreak :: String -> GHCi ()
1478 | all isDigit str = deleteBreak (read str)
1479 | otherwise = return ()
1481 historyCmd :: String -> GHCi ()
1482 historyCmd = noArgs $ do
1484 resumes <- io $ GHC.getResumeContext s
1486 [] -> io $ putStrLn "Not stopped at a breakpoint"
1488 let hist = GHC.resumeHistory r
1489 spans <- mapM (io . GHC.getHistorySpan s) hist
1490 printForUser (vcat (map ppr spans))
1492 backCmd :: String -> GHCi ()
1493 backCmd = noArgs $ do
1495 (names, ix, span) <- io $ GHC.back s
1496 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1497 mapM_ (showTypeOfName s) names
1498 -- run the command set with ":set stop <cmd>"
1500 runCommand (stop st)
1503 forwardCmd :: String -> GHCi ()
1504 forwardCmd = noArgs $ do
1506 (names, ix, span) <- io $ GHC.forward s
1507 printForUser $ (if (ix == 0)
1508 then ptext SLIT("Stopped at")
1509 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1510 mapM_ (showTypeOfName s) names
1511 -- run the command set with ":set stop <cmd>"
1513 runCommand (stop st)
1516 -- handle the "break" command
1517 breakCmd :: String -> GHCi ()
1518 breakCmd argLine = do
1519 session <- getSession
1520 breakSwitch session $ words argLine
1522 breakSwitch :: Session -> [String] -> GHCi ()
1523 breakSwitch _session [] = do
1524 io $ putStrLn "The break command requires at least one argument."
1525 breakSwitch session args@(arg1:rest)
1526 | looksLikeModuleName arg1 = do
1527 mod <- wantInterpretedModule arg1
1528 breakByModule session mod rest
1529 | all isDigit arg1 = do
1530 (toplevel, _) <- io $ GHC.getContext session
1532 (mod : _) -> breakByModuleLine mod (read arg1) rest
1534 io $ putStrLn "Cannot find default module for breakpoint."
1535 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1536 | otherwise = do -- try parsing it as an identifier
1537 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1538 let loc = GHC.nameSrcLoc name
1539 if GHC.isGoodSrcLoc loc
1540 then findBreakAndSet (GHC.nameModule name) $
1541 findBreakByCoord (Just (GHC.srcLocFile loc))
1542 (GHC.srcLocLine loc,
1544 else noCanDo name $ text "can't find its location: " <> ppr loc
1546 noCanDo n why = printForUser $
1547 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1549 breakByModule :: Session -> Module -> [String] -> GHCi ()
1550 breakByModule session mod args@(arg1:rest)
1551 | all isDigit arg1 = do -- looks like a line number
1552 breakByModuleLine mod (read arg1) rest
1553 | otherwise = io $ putStrLn "Invalid arguments to :break"
1555 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1556 breakByModuleLine mod line args
1557 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1558 | [col] <- args, all isDigit col =
1559 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1560 | otherwise = io $ putStrLn "Invalid arguments to :break"
1562 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1563 findBreakAndSet mod lookupTickTree = do
1564 tickArray <- getTickArray mod
1565 (breakArray, _) <- getModBreak mod
1566 case lookupTickTree tickArray of
1567 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1568 Just (tick, span) -> do
1569 success <- io $ setBreakFlag True breakArray tick
1570 session <- getSession
1574 recordBreak $ BreakLocation
1580 text "Breakpoint " <> ppr nm <>
1582 then text " was already set at " <> ppr span
1583 else text " activated at " <> ppr span
1585 printForUser $ text "Breakpoint could not be activated at"
1588 -- When a line number is specified, the current policy for choosing
1589 -- the best breakpoint is this:
1590 -- - the leftmost complete subexpression on the specified line, or
1591 -- - the leftmost subexpression starting on the specified line, or
1592 -- - the rightmost subexpression enclosing the specified line
1594 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1595 findBreakByLine line arr
1596 | not (inRange (bounds arr) line) = Nothing
1598 listToMaybe (sortBy leftmost_largest complete) `mplus`
1599 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1600 listToMaybe (sortBy rightmost ticks)
1604 starts_here = [ tick | tick@(nm,span) <- ticks,
1605 GHC.srcSpanStartLine span == line ]
1607 (complete,incomplete) = partition ends_here starts_here
1608 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1610 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1611 -> Maybe (BreakIndex,SrcSpan)
1612 findBreakByCoord mb_file (line, col) arr
1613 | not (inRange (bounds arr) line) = Nothing
1615 listToMaybe (sortBy rightmost contains)
1619 -- the ticks that span this coordinate
1620 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1621 is_correct_file span ]
1623 is_correct_file span
1624 | Just f <- mb_file = GHC.srcSpanFile span == f
1628 leftmost_smallest (_,a) (_,b) = a `compare` b
1629 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1631 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1632 rightmost (_,a) (_,b) = b `compare` a
1634 spans :: SrcSpan -> (Int,Int) -> Bool
1635 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1636 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1638 start_bold = BS.pack "\ESC[1m"
1639 end_bold = BS.pack "\ESC[0m"
1641 listCmd :: String -> GHCi ()
1643 mb_span <- getCurrentBreakSpan
1645 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1646 Just span -> io $ listAround span True
1647 listCmd str = list2 (words str)
1649 list2 [arg] | all isDigit arg = do
1650 session <- getSession
1651 (toplevel, _) <- io $ GHC.getContext session
1653 [] -> io $ putStrLn "No module to list"
1654 (mod : _) -> listModuleLine mod (read arg)
1655 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1656 mod <- wantInterpretedModule arg1
1657 listModuleLine mod (read arg2)
1659 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1660 let loc = GHC.nameSrcLoc name
1661 if GHC.isGoodSrcLoc loc
1663 tickArray <- getTickArray (GHC.nameModule name)
1664 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1665 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1668 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1669 Just (_,span) -> io $ listAround span False
1671 noCanDo name $ text "can't find its location: " <>
1674 noCanDo n why = printForUser $
1675 text "cannot list source code for " <> ppr n <> text ": " <> why
1677 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1679 listModuleLine :: Module -> Int -> GHCi ()
1680 listModuleLine modl line = do
1681 session <- getSession
1682 graph <- io (GHC.getModuleGraph session)
1683 let this = filter ((== modl) . GHC.ms_mod) graph
1685 [] -> panic "listModuleLine"
1687 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1688 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1689 io $ listAround (GHC.srcLocSpan loc) False
1691 -- | list a section of a source file around a particular SrcSpan.
1692 -- If the highlight flag is True, also highlight the span using
1693 -- start_bold/end_bold.
1694 listAround span do_highlight = do
1695 contents <- BS.readFile (unpackFS file)
1697 lines = BS.split '\n' contents
1698 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1699 drop (line1 - 1 - pad_before) $ lines
1700 fst_line = max 1 (line1 - pad_before)
1701 line_nos = [ fst_line .. ]
1703 highlighted | do_highlight = zipWith highlight line_nos these_lines
1704 | otherwise = these_lines
1706 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1707 prefixed = zipWith BS.append bs_line_nos highlighted
1709 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1711 file = GHC.srcSpanFile span
1712 line1 = GHC.srcSpanStartLine span
1713 col1 = GHC.srcSpanStartCol span
1714 line2 = GHC.srcSpanEndLine span
1715 col2 = GHC.srcSpanEndCol span
1717 pad_before | line1 == 1 = 0
1722 | no == line1 && no == line2
1723 = let (a,r) = BS.splitAt col1 line
1724 (b,c) = BS.splitAt (col2-col1) r
1726 BS.concat [a,start_bold,b,end_bold,c]
1728 = let (a,b) = BS.splitAt col1 line in
1729 BS.concat [a, start_bold, b]
1731 = let (a,b) = BS.splitAt col2 line in
1732 BS.concat [a, end_bold, b]
1735 -- --------------------------------------------------------------------------
1738 getTickArray :: Module -> GHCi TickArray
1739 getTickArray modl = do
1741 let arrmap = tickarrays st
1742 case lookupModuleEnv arrmap modl of
1743 Just arr -> return arr
1745 (breakArray, ticks) <- getModBreak modl
1746 let arr = mkTickArray (assocs ticks)
1747 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1750 discardTickArrays :: GHCi ()
1751 discardTickArrays = do
1753 setGHCiState st{tickarrays = emptyModuleEnv}
1755 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1757 = accumArray (flip (:)) [] (1, max_line)
1758 [ (line, (nm,span)) | (nm,span) <- ticks,
1759 line <- srcSpanLines span ]
1761 max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
1762 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1763 GHC.srcSpanEndLine span ]
1765 lookupModule :: String -> GHCi Module
1766 lookupModule modName
1767 = do session <- getSession
1768 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1770 -- don't reset the counter back to zero?
1771 discardActiveBreakPoints :: GHCi ()
1772 discardActiveBreakPoints = do
1774 mapM (turnOffBreak.snd) (breaks st)
1775 setGHCiState $ st { breaks = [] }
1777 deleteBreak :: Int -> GHCi ()
1778 deleteBreak identity = do
1780 let oldLocations = breaks st
1781 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1783 then printForUser (text "Breakpoint" <+> ppr identity <+>
1784 text "does not exist")
1786 mapM (turnOffBreak.snd) this
1787 setGHCiState $ st { breaks = rest }
1789 turnOffBreak loc = do
1790 (arr, _) <- getModBreak (breakModule loc)
1791 io $ setBreakFlag False arr (breakTick loc)
1793 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1794 getModBreak mod = do
1795 session <- getSession
1796 Just mod_info <- io $ GHC.getModuleInfo session mod
1797 let modBreaks = GHC.modInfoModBreaks mod_info
1798 let array = GHC.modBreaks_flags modBreaks
1799 let ticks = GHC.modBreaks_locs modBreaks
1800 return (array, ticks)
1802 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1803 setBreakFlag toggle array index
1804 | toggle = GHC.setBreakOn array index
1805 | otherwise = GHC.setBreakOff array index