-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------
-module InteractiveUI (
- interactiveUI,
- ghciWelcomeMsg
- ) where
+module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
#include "HsVersions.h"
import GhciMonad
+import GhciTags
+import Debugger
-- The GHC interface
import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
Type, Module, ModuleName, TyThing(..), Phase,
- BreakIndex )
-import Debugger
+ BreakIndex, SrcSpan, Resume, SingleStep )
import DynFlags
import Packages
import PackageConfig
import PprTyThing
import Outputable hiding (printForUser)
import Module -- for ModuleEnv
-
--- for createtags
import Name
-import OccName
-import SrcLoc
-- Other random utilities
import Digraph
import BasicTypes hiding (isTopLevel)
import Panic hiding (showException)
-import FastString ( unpackFS )
import Config
import StaticFlags
import Linker
import Util
+import FastString
#ifndef mingw32_HOST_OS
-import System.Posix
-#if __GLASGOW_HASKELL__ > 504
- hiding (getEnv)
-#endif
+import System.Posix hiding (getEnv)
#else
import GHC.ConsoleHandler ( flushConsole )
import System.Win32 ( setConsoleCP, setConsoleOutputCP )
import Data.Dynamic
import Data.Array
import Control.Monad as Monad
+import Text.Printf
import Foreign.StablePtr ( newStablePtr )
import GHC.Exts ( unsafeCoerce# )
-----------------------------------------------------------------------------
-ghciWelcomeMsg =
- " ___ ___ _\n"++
- " / _ \\ /\\ /\\/ __(_)\n"++
- " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
- "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
- "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
+ghciWelcomeMsg :: String
+ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
+ ": http://www.haskell.org/ghc/ :? for help"
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
cmdName (n,_,_,_) = n
-- Hugs users are accustomed to :e, so make sure it doesn't overlap
("?", keepGoing help, False, completeNone),
("add", keepGoingPaths addModule, False, completeFilename),
+ ("abandon", keepGoing abandonCmd, False, completeNone),
("break", keepGoing breakCmd, False, completeIdentifier),
+ ("back", keepGoing backCmd, False, completeNone),
("browse", keepGoing browseCmd, False, completeModule),
("cd", keepGoing changeDirectory, False, completeFilename),
("check", keepGoing checkModule, False, completeHomeModule),
- ("continue", continueCmd, False, completeNone),
+ ("continue", keepGoing continueCmd, False, completeNone),
+ ("cmd", keepGoing cmdCmd, False, completeIdentifier),
("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
("delete", keepGoing deleteCmd, False, completeNone),
("e", keepGoing editFile, False, completeFilename),
("edit", keepGoing editFile, False, completeFilename),
("etags", keepGoing createETagsFileCmd, False, completeFilename),
- ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
+ ("force", keepGoing forceCmd, False, completeIdentifier),
+ ("forward", keepGoing forwardCmd, False, completeNone),
("help", keepGoing help, False, completeNone),
+ ("history", keepGoing historyCmd, False, completeNone),
("info", keepGoing info, False, completeIdentifier),
("kind", keepGoing kindOfType, False, completeIdentifier),
("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
("list", keepGoing listCmd, False, completeNone),
("module", keepGoing setContext, False, completeModule),
("main", keepGoing runMain, False, completeIdentifier),
- ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+ ("print", keepGoing printCmd, False, completeIdentifier),
("quit", quit, False, completeNone),
("reload", keepGoing reloadModule, False, completeNone),
("set", keepGoing setCmd, True, completeSetOptions),
("show", keepGoing showCmd, False, completeNone),
- ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
- ("step", stepCmd, False, completeIdentifier),
+ ("sprint", keepGoing sprintCmd, False, completeIdentifier),
+ ("step", keepGoing stepCmd, False, completeIdentifier),
("type", keepGoing typeOfExpr, False, completeIdentifier),
+ ("trace", keepGoing traceCmd, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
("unset", keepGoing unsetOptions, True, completeSetOptions)
]
helpText =
" Commands available from the prompt:\n" ++
"\n" ++
- " <stmt> evaluate/run <stmt>\n" ++
+ " <statement> evaluate/run <statement>\n" ++
" :add <filename> ... add module(s) to the current target set\n" ++
- " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
- " :break <name> set a breakpoint on the specified function\n" ++
" :browse [*]<module> display the names defined by <module>\n" ++
" :cd <dir> change directory to <dir>\n" ++
- " :continue resume after a breakpoint\n" ++
+ " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
" :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
" :def <cmd> <expr> define a command :<cmd>\n" ++
- " :delete <number> delete the specified breakpoint\n" ++
- " :delete * delete all breakpoints\n" ++
" :edit <file> edit file\n" ++
" :edit edit last module\n" ++
" :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
--- " :force <expr> print <expr>, forcing unevaluated parts\n" ++
" :help, :? display this list of commands\n" ++
" :info [<name> ...] display information about the given names\n" ++
" :kind <type> show the kind of <type>\n" ++
" :load <filename> ... load module(s) and their dependents\n" ++
" :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
" :main [<arguments> ...] run the main function with the given arguments\n" ++
- " :print [<name> ...] prints a value without forcing its computation\n" ++
" :quit exit GHCi\n" ++
" :reload reload the current module set\n" ++
+ " :type <expr> show the type of <expr>\n" ++
+ " :undef <cmd> undefine user-defined command :<cmd>\n" ++
+ " :!<command> run the shell command <command>\n" ++
+ "\n" ++
+ " -- Commands for debugging:\n" ++
+ "\n" ++
+ " :abandon at a breakpoint, abandon current computation\n" ++
+ " :back go back in the history (after :trace)\n" ++
+ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
+ " :break <name> set a breakpoint on the specified function\n" ++
+ " :continue resume after a breakpoint\n" ++
+ " :delete <number> delete the specified breakpoint\n" ++
+ " :delete * delete all breakpoints\n" ++
+ " :force <expr> print <expr>, forcing unevaluated parts\n" ++
+ " :forward go forward in the history (after :back)\n" ++
+ " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
+ " :print [<name> ...] prints a value without forcing its computation\n" ++
+ " :sprint [<name> ...] simplifed version of :print\n" ++
+ " :step single-step after stopping at a breakpoint\n"++
+ " :step <expr> single-step into <expr>\n"++
+ " :trace trace after stopping at a breakpoint\n"++
+ " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
+
+ "\n" ++
+ " -- Commands for changing settings:\n" ++
"\n" ++
" :set <option> ... set options\n" ++
" :set args <arg> ... set the arguments returned by System.getArgs\n" ++
" :set prompt <prompt> set the prompt used in GHCi\n" ++
" :set editor <cmd> set the command used for :edit\n" ++
" :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
- "\n" ++
- " :show breaks show active breakpoints\n" ++
- " :show context show the breakpoint context\n" ++
- " :show modules show the currently loaded modules\n" ++
- " :show bindings show the current bindings made at the prompt\n" ++
- "\n" ++
- " :sprint [<name> ...] simplifed version of :print\n" ++
- " :step single-step after stopping at a breakpoint\n"++
- " :step <expr> single-step into <expr>\n"++
- " :type <expr> show the type of <expr>\n" ++
- " :undef <cmd> undefine user-defined command :<cmd>\n" ++
" :unset <option> ... unset options\n" ++
- " :!<command> run the shell command <command>\n" ++
"\n" ++
- " Options for ':set' and ':unset':\n" ++
+ " Options for ':set' and ':unset':\n" ++
"\n" ++
" +r revert top-level expressions after each evaluation\n" ++
" +s print timing/memory stats after each evaluation\n" ++
" +t print type after evaluation\n" ++
" -<flags> most GHC command line flags can also be set here\n" ++
" (eg. -v2, -fglasgow-exts, etc.)\n" ++
+ "\n" ++
+ " -- Commands for displaying information:\n" ++
+ "\n" ++
+ " :show bindings show the current bindings made at the prompt\n" ++
+ " :show breaks show the active breakpoints\n" ++
+ " :show context show the breakpoint context\n" ++
+ " :show modules show the currently loaded modules\n" ++
+ " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
"\n"
--- Todo: add help for breakpoint commands here
findEditor = do
getEnv "EDITOR"
newStablePtr stdout
newStablePtr stderr
- -- Initialise buffering for the *interpreted* I/O system
+ -- Initialise buffering for the *interpreted* I/O system
initInterpBuffering session
when (isNothing maybe_expr) $ do
- -- Only for GHCi (not runghc and ghc -e):
- -- Turn buffering off for the compiled program's stdout/stderr
- turnOffBuffering
- -- Turn buffering off for GHCi's stdout
- hFlush stdout
- hSetBuffering stdout NoBuffering
- -- We don't want the cmd line to buffer any input that might be
- -- intended for the program, so unbuffer stdin.
- hSetBuffering stdin NoBuffering
-
- -- initial context is just the Prelude
+ -- Only for GHCi (not runghc and ghc -e):
+
+ -- Turn buffering off for the compiled program's stdout/stderr
+ turnOffBuffering
+ -- Turn buffering off for GHCi's stdout
+ hFlush stdout
+ hSetBuffering stdout NoBuffering
+ -- We don't want the cmd line to buffer any input that might be
+ -- intended for the program, so unbuffer stdin.
+ hSetBuffering stdin NoBuffering
+
+ -- initial context is just the Prelude
prel_mod <- GHC.findModule session prel_name (Just basePackageId)
GHC.setContext session [] [prel_mod]
session = session,
options = [],
prelude = prel_mod,
- resume = [],
- breaks = emptyActiveBreakPoints,
- tickarrays = emptyModuleEnv
+ break_ctr = 0,
+ breaks = [],
+ tickarrays = emptyModuleEnv,
+ cmdqueue = []
}
#ifdef USE_READLINE
let show_prompt = verbosity dflags > 0 || is_tty
case maybe_expr of
- Nothing ->
+ Nothing ->
do
#if defined(mingw32_HOST_OS)
- -- The win32 Console API mutates the first character of
+ -- The win32 Console API mutates the first character of
-- type-ahead when reading from it in a non-buffered manner. Work
-- around this by flushing the input buffer of type-ahead characters,
-- but only if stdin is available.
flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
- case flushed of
- Left err | isDoesNotExistError err -> return ()
- | otherwise -> io (ioError err)
- Right () -> return ()
+ case flushed of
+ Left err | isDoesNotExistError err -> return ()
+ | otherwise -> io (ioError err)
+ Right () -> return ()
#endif
- -- initialise the console if necessary
- io setUpConsole
+ -- initialise the console if necessary
+ io setUpConsole
- -- enter the interactive loop
- interactiveLoop is_tty show_prompt
- Just expr -> do
- -- just evaluate the expression we were given
- runCommandEval expr
- return ()
+ -- enter the interactive loop
+ interactiveLoop is_tty show_prompt
+ Just expr -> do
+ -- just evaluate the expression we were given
+ runCommandEval expr
+ return ()
-- and finally, exit
io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
fileLoop :: Handle -> Bool -> GHCi ()
fileLoop hdl show_prompt = do
- session <- getSession
- (mod,imports) <- io (GHC.getContext session)
- st <- getGHCiState
- when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
+ when show_prompt $ do
+ prompt <- mkPrompt
+ (io (putStr prompt))
l <- io (IO.try (hGetLine hdl))
case l of
Left e | isEOFError e -> return ()
Right l ->
case removeSpaces l of
"" -> fileLoop hdl show_prompt
- l -> do quit <- runCommand l
+ l -> do quit <- runCommands l
if quit then return () else fileLoop hdl show_prompt
-stringLoop :: [String] -> GHCi Bool{-True: we quit-}
-stringLoop [] = return False
-stringLoop (s:ss) = do
- case removeSpaces s of
- "" -> stringLoop ss
- l -> do quit <- runCommand l
- if quit then return True else stringLoop ss
-
-mkPrompt toplevs exports prompt
- = showSDoc $ f prompt
- where
- f ('%':'s':xs) = perc_s <> f xs
+mkPrompt = do
+ session <- getSession
+ (toplevs,exports) <- io (GHC.getContext session)
+ resumes <- io $ GHC.getResumeContext session
+
+ context_bit <-
+ case resumes of
+ [] -> return empty
+ r:rs -> do
+ let ix = GHC.resumeHistoryIx r
+ if ix == 0
+ then return (brackets (ppr (GHC.resumeSpan r)) <> space)
+ else do
+ let hist = GHC.resumeHistory r !! (ix-1)
+ span <- io $ GHC.getHistorySpan session hist
+ return (brackets (ppr (negate ix) <> char ':'
+ <+> ppr span) <> space)
+ let
+ dots | r:rs <- resumes, not (null rs) = text "... "
+ | otherwise = empty
+
+ modules_bit =
+ hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
+ hsep (map (ppr . GHC.moduleName) exports)
+
+ deflt_prompt = dots <> context_bit <> modules_bit
+
+ f ('%':'s':xs) = deflt_prompt <> f xs
f ('%':'%':xs) = char '%' <> f xs
f (x:xs) = char x <> f xs
f [] = empty
-
- perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
- hsep (map (ppr . GHC.moduleName) exports)
+ --
+ st <- getGHCiState
+ return (showSDoc (f (prompt st)))
#ifdef USE_READLINE
io yield
saveSession -- for use by completion
st <- getGHCiState
- l <- io (readline (mkPrompt mod imports (prompt st))
- `finally` setNonBlockingFD 0)
+ mb_span <- getCurrentBreakSpan
+ prompt <- mkPrompt
+ l <- io (readline prompt `finally` setNonBlockingFD 0)
-- readline sometimes puts stdin into blocking mode,
-- so we need to put it back for the IO library
splatSavedSession
"" -> readlineLoop
l -> do
io (addHistory l)
- quit <- runCommand l
+ quit <- runCommands l
if quit then return () else readlineLoop
#endif
-runCommand :: String -> GHCi Bool
-runCommand c = ghciHandle handler (doCommand c)
- where
- doCommand (':' : command) = specialCommand command
- doCommand stmt
- = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
- return False
+runCommands :: String -> GHCi Bool
+runCommands cmd = do
+ q <- ghciHandle handler (doCommand cmd)
+ if q then return True else runNext
+ where
+ runNext = do
+ st <- getGHCiState
+ case cmdqueue st of
+ [] -> return False
+ c:cs -> do setGHCiState st{ cmdqueue = cs }
+ runCommands c
+
+ doCommand (':' : cmd) = specialCommand cmd
+ doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
+ return False
+
+enqueueCommands :: [String] -> GHCi ()
+enqueueCommands cmds = do
+ st <- getGHCiState
+ setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
+
-- This version is for the GHC command-line option -e. The only difference
-- from runCommand is that it catches the ExitException exception and
doCommand (':' : command) = specialCommand command
doCommand stmt
- = do nms <- runStmt stmt
- case nms of
- Nothing -> io (exitWith (ExitFailure 1))
+ = do r <- runStmt stmt GHC.RunToCompletion
+ case r of
+ False -> io (exitWith (ExitFailure 1))
-- failure to run the command causes exit(1) for ghc -e.
- _ -> do finishEvalExpr nms
- return True
+ _ -> return True
-runStmt :: String -> GHCi (Maybe (Bool,[Name]))
-runStmt stmt
- | null (filter (not.isSpace) stmt) = return (Just (False,[]))
+runStmt :: String -> SingleStep -> GHCi Bool
+runStmt stmt step
+ | null (filter (not.isSpace) stmt) = return False
+ | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
| otherwise
= do st <- getGHCiState
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
- GHC.runStmt session stmt
- switchOnRunResult result
-
-switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
-switchOnRunResult GHC.RunFailed = return Nothing
-switchOnRunResult (GHC.RunException e) = throw e
-switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
-switchOnRunResult (GHC.RunBreak threadId names info resume) = do
- session <- getSession
- Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
- let modBreaks = GHC.modInfoModBreaks mod_info
- let ticks = GHC.modBreaks_locs modBreaks
+ GHC.runStmt session stmt step
+ afterRunStmt result
- -- display information about the breakpoint
- let location = ticks ! GHC.breakInfo_number info
- printForUser $ ptext SLIT("Stopped at") <+> ppr location
- pushResume location threadId resume
+afterRunStmt :: GHC.RunResult -> GHCi Bool
+ -- False <=> the statement failed to compile
+afterRunStmt (GHC.RunException e) = throw e
+afterRunStmt run_result = do
+ session <- getSession
+ case run_result of
+ GHC.RunOk names -> do
+ show_types <- isOptionSet ShowType
+ when show_types $ printTypeOfNames session names
+ GHC.RunBreak _ names mb_info -> do
+ resumes <- io $ GHC.getResumeContext session
+ printForUser $ ptext SLIT("Stopped at") <+>
+ ppr (GHC.resumeSpan (head resumes))
+ printTypeOfNames session names
+ maybe (return ()) runBreakCmd mb_info
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+ return ()
+ _ -> return ()
- -- run the command set with ":set stop <cmd>"
- st <- getGHCiState
- runCommand (stop st)
+ flushInterpBuffers
+ io installSignalHandlers
+ b <- isOptionSet RevertCAFs
+ io (when b revertCAFs)
- return (Just (True,names))
+ return (case run_result of GHC.RunOk _ -> True; _ -> False)
--- possibly print the type and revert CAFs after evaluating an expression
-finishEvalExpr mb_names
- = do show_types <- isOptionSet ShowType
- session <- getSession
- case mb_names of
- Nothing -> return ()
- Just (is_break,names) ->
- when (is_break || show_types) $
- mapM_ (showTypeOfName session) names
-
- flushInterpBuffers
- io installSignalHandlers
- b <- isOptionSet RevertCAFs
- io (when b revertCAFs)
-
-showTypeOfName :: Session -> Name -> GHCi ()
-showTypeOfName session n
+runBreakCmd :: GHC.BreakInfo -> GHCi ()
+runBreakCmd info = do
+ let mod = GHC.breakInfo_module info
+ nm = GHC.breakInfo_number info
+ st <- getGHCiState
+ case [ loc | (i,loc) <- breaks st,
+ breakModule loc == mod, breakTick loc == nm ] of
+ [] -> return ()
+ loc:_ | null cmd -> return ()
+ | otherwise -> do enqueueCommands [cmd]; return ()
+ where cmd = onBreakCmd loc
+
+printTypeOfNames :: Session -> [Name] -> GHCi ()
+printTypeOfNames session names
+ = mapM_ (printTypeOfName session) $ sortBy compareNames names
+
+compareNames :: Name -> Name -> Ordering
+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
+ where compareWith n = (getOccString n, getSrcSpan n)
+
+printTypeOfName :: Session -> Name -> GHCi ()
+printTypeOfName session n
= do maybe_tything <- io (GHC.lookupName session n)
- case maybe_tything of
- Nothing -> return ()
- Just thing -> showTyThing thing
+ case maybe_tything of
+ Nothing -> return ()
+ Just thing -> printTyThing thing
specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
-- look for exact match first, then the first prefix match
case [ c | c <- cmds, str == cmdName c ] of
c:_ -> return (Just c)
- [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
+ [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
[] -> return Nothing
c:_ -> return (Just c)
+
+getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
+getCurrentBreakSpan = do
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
+ case resumes of
+ [] -> return Nothing
+ (r:rs) -> do
+ let ix = GHC.resumeHistoryIx r
+ if ix == 0
+ then return (Just (GHC.resumeSpan r))
+ else do
+ let hist = GHC.resumeHistory r !! (ix-1)
+ span <- io $ GHC.getHistorySpan session hist
+ return (Just span)
+
-----------------------------------------------------------------------------
-- Commands
+noArgs :: GHCi () -> String -> GHCi ()
+noArgs m "" = m
+noArgs m _ = io $ putStrLn "This command takes no arguments"
+
help :: String -> GHCi ()
help _ = io (putStr helpText)
| fix == GHC.defaultFixity = empty
| otherwise = ppr fix <+> ppr (GHC.getName thing)
------------------------------------------------------------------------------
--- Commands
-
runMain :: String -> GHCi ()
runMain args = do
let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
- runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
- return ()
+ enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
addModule :: [FilePath] -> GHCi ()
addModule files = do
io (setCurrentDirectory dir)
editFile :: String -> GHCi ()
-editFile str
- | null str = do
- -- find the name of the "topmost" file loaded
- session <- getSession
- graph0 <- io (GHC.getModuleGraph session)
- graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
- let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
- case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
- Just file -> do_edit file
- Nothing -> throwDyn (CmdLineError "unknown file name")
- | otherwise = do_edit str
- where
- do_edit file = do
- st <- getGHCiState
- let cmd = editor st
- when (null cmd) $
- throwDyn (CmdLineError "editor not set, use :set editor")
- io $ system (cmd ++ ' ':file)
- return ()
+editFile str =
+ do file <- if null str then chooseEditFile else return str
+ st <- getGHCiState
+ let cmd = editor st
+ when (null cmd)
+ $ throwDyn (CmdLineError "editor not set, use :set editor")
+ io $ system (cmd ++ ' ':file)
+ return ()
+
+-- The user didn't specify a file so we pick one for them.
+-- Our strategy is to pick the first module that failed to load,
+-- or otherwise the first target.
+--
+-- XXX: Can we figure out what happened if the depndecy analysis fails
+-- (e.g., because the porgrammeer mistyped the name of a module)?
+-- XXX: Can we figure out the location of an error to pass to the editor?
+-- XXX: if we could figure out the list of errors that occured during the
+-- last load/reaload, then we could start the editor focused on the first
+-- of those.
+chooseEditFile :: GHCi String
+chooseEditFile =
+ do session <- getSession
+ let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
+
+ graph <- io (GHC.getModuleGraph session)
+ failed_graph <- filterM hasFailed graph
+ let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
+ pick xs = case xs of
+ x : _ -> GHC.ml_hs_file (GHC.ms_location x)
+ _ -> Nothing
+
+ case pick (order failed_graph) of
+ Just file -> return file
+ Nothing ->
+ do targets <- io (GHC.getTargets session)
+ case msum (map fromTarget targets) of
+ Just file -> return file
+ Nothing -> throwDyn (CmdLineError "No files to edit.")
+
+ where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
+ fromTarget _ = Nothing -- when would we get a module target?
defineMacro :: String -> GHCi ()
defineMacro s = do
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
runMacro fun s = do
str <- io ((unsafeCoerce# fun :: String -> IO String) s)
- stringLoop (lines str)
+ enqueueCommands (lines str)
+ return False
undefineMacro :: String -> GHCi ()
undefineMacro macro_name = do
else do
io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
+cmdCmd :: String -> GHCi ()
+cmdCmd str = do
+ let expr = '(' : str ++ ") :: IO String"
+ session <- getSession
+ maybe_hv <- io (GHC.compileExpr session expr)
+ case maybe_hv of
+ Nothing -> return ()
+ Just hv -> do
+ cmds <- io $ (unsafeCoerce# hv :: IO String)
+ enqueueCommands (lines cmds)
+ return ()
loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
loadModule fs = timeIt (loadModule' fs)
session <- getSession
-- unload first
+ discardActiveBreakPoints
io (GHC.setTargets session [])
io (GHC.load session LoadAllTargets)
-- as a ToDo for now.
io (GHC.setTargets session targets)
- ok <- io (GHC.load session LoadAllTargets)
- afterLoad ok session
- return ok
+ doLoad session LoadAllTargets
checkModule :: String -> GHCi ()
checkModule m = do
let modl = GHC.mkModuleName m
session <- getSession
- result <- io (GHC.checkModule session modl)
+ result <- io (GHC.checkModule session modl False)
case result of
Nothing -> io $ putStrLn "Nothing"
Just r -> io $ putStrLn (showSDoc (
afterLoad (successIf (isJust result)) session
reloadModule :: String -> GHCi ()
-reloadModule "" = do
- io (revertCAFs) -- always revert CAFs on reload.
- session <- getSession
- ok <- io (GHC.load session LoadAllTargets)
- afterLoad ok session
reloadModule m = do
io (revertCAFs) -- always revert CAFs on reload.
+ discardActiveBreakPoints
session <- getSession
- ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
+ doLoad session $ if null m then LoadAllTargets
+ else LoadUpTo (GHC.mkModuleName m)
+ return ()
+
+doLoad session howmuch = do
+ -- turn off breakpoints before we load: we can't turn them off later, because
+ -- the ModBreaks will have gone away.
+ discardActiveBreakPoints
+ ok <- io (GHC.load session howmuch)
afterLoad ok session
+ return ok
afterLoad ok session = do
io (revertCAFs) -- always revert CAFs on load.
- discardResumeContext
discardTickArrays
- discardActiveBreakPoints
graph <- io (GHC.getModuleGraph session)
graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
setContextAfterLoad session graph'
shellEscape str = io (system str >> return False)
-----------------------------------------------------------------------------
--- create tags file for currently loaded modules.
-
-createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
-
-createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
-createCTagsFileCmd file = ghciCreateTagsFile CTags file
-
-createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
-createETagsFileCmd file = ghciCreateTagsFile ETags file
-
-data TagsKind = ETags | CTags
-
-ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
-ghciCreateTagsFile kind file = do
- session <- getSession
- io $ createTagsFile session kind file
-
--- ToDo:
--- - remove restriction that all modules must be interpreted
--- (problem: we don't know source locations for entities unless
--- we compiled the module.
---
--- - extract createTagsFile so it can be used from the command-line
--- (probably need to fix first problem before this is useful).
---
-createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
-createTagsFile session tagskind tagFile = do
- graph <- GHC.getModuleGraph session
- let ms = map GHC.ms_mod graph
- tagModule m = do
- is_interpreted <- GHC.moduleIsInterpreted session m
- -- should we just skip these?
- when (not is_interpreted) $
- throwDyn (CmdLineError ("module '"
- ++ GHC.moduleNameString (GHC.moduleName m)
- ++ "' is not interpreted"))
- mbModInfo <- GHC.getModuleInfo session m
- let unqual
- | Just modinfo <- mbModInfo,
- Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
- | otherwise = GHC.alwaysQualify
-
- case mbModInfo of
- Just modInfo -> return $! listTags unqual modInfo
- _ -> return []
-
- mtags <- mapM tagModule ms
- either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
- case either_res of
- Left e -> hPutStrLn stderr $ ioeGetErrorString e
- Right _ -> return ()
-
-listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
-listTags unqual modInfo =
- [ tagInfo unqual name loc
- | name <- GHC.modInfoExports modInfo
- , let loc = nameSrcLoc name
- , isGoodSrcLoc loc
- ]
-
-type TagInfo = (String -- tag name
- ,String -- file name
- ,Int -- line number
- ,Int -- column number
- )
-
--- get tag info, for later translation into Vim or Emacs style
-tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
-tagInfo unqual name loc
- = ( showSDocForUser unqual $ pprOccName (nameOccName name)
- , showSDocForUser unqual $ ftext (srcLocFile loc)
- , srcLocLine loc
- , srcLocCol loc
- )
-
-collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
-collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
- let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
- IO.try (writeFile file tags)
-collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
- let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
- groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
- tagGroups <- mapM tagFileGroup groups
- IO.try (writeFile file $ concat tagGroups)
- where
- tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
- tagFileGroup group@((_,fileName,_,_):_) = do
- file <- readFile fileName -- need to get additional info from sources..
- let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
- sortedGroup = sortLe byLine group
- tags = unlines $ perFile sortedGroup 1 0 $ lines file
- return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
- perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
- perFile (tagInfo:tags) (count+1) (pos+length line) lines
- perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
- showETag tagInfo line pos : perFile tags count pos lines
- perFile tags count pos lines = []
-
--- simple ctags format, for Vim et al
-showTag :: TagInfo -> String
-showTag (tag,file,lineNo,colNo)
- = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
-
--- etags format, for Emacs/XEmacs
-showETag :: TagInfo -> String -> Int -> String
-showETag (tag,file,lineNo,colNo) line charPos
- = take colNo line ++ tag
- ++ "\x7f" ++ tag
- ++ "\x01" ++ show lineNo
- ++ "," ++ show charPos
-
------------------------------------------------------------------------------
-- Browsing a module's contents
browseCmd :: String -> GHCi ()
browseModule m exports_only = do
s <- getSession
- modl <- if exports_only then lookupModule s m
- else wantInterpretedModule s m
+ modl <- if exports_only then lookupModule m
+ else wantInterpretedModule m
-- Temporarily set the context to the module we're interested in,
-- just so we can get an appropriate PrintUnqualified
st <- getGHCiState
setGHCiState st{ editor = cmd }
+setStop str@(c:_) | isDigit c
+ = do let (nm_str,rest) = break (not.isDigit) str
+ nm = read nm_str
+ st <- getGHCiState
+ let old_breaks = breaks st
+ if all ((/= nm) . fst) old_breaks
+ then printForUser (text "Breakpoint" <+> ppr nm <+>
+ text "does not exist")
+ else do
+ let new_breaks = map fn old_breaks
+ fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
+ | otherwise = (i,loc)
+ setGHCiState st{ breaks = new_breaks }
setStop cmd = do
st <- getGHCiState
setGHCiState st{ stop = cmd }
do -- first, deal with the GHCi opts (+s, +t, etc.)
let (plus_opts, minus_opts) = partition isPlus wds
mapM_ setOpt plus_opts
-
-- then, dynamic flags
+ newDynFlags minus_opts
+
+newDynFlags minus_opts = do
dflags <- getDynFlags
let pkg_flags = packageFlags dflags
(dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
mapM_ unsetOpt plus_opts
- -- can't do GHC flags for now
- if (not (null minus_opts))
- then throwDyn (CmdLineError "can't unset GHC command-line flags")
- else return ()
+ let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
+ no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
+
+ no_flags <- mapM no_flag minus_opts
+ newDynFlags no_flags
isMinus ('-':s) = True
isMinus _ = False
-- ---------------------------------------------------------------------------
-- code for `:show'
-showCmd str =
+showCmd str = do
+ st <- getGHCiState
case words str of
+ ["args"] -> io $ putStrLn (show (args st))
+ ["prog"] -> io $ putStrLn (show (progname st))
+ ["prompt"] -> io $ putStrLn (show (prompt st))
+ ["editor"] -> io $ putStrLn (show (editor st))
+ ["stop"] -> io $ putStrLn (show (stop st))
["modules" ] -> showModules
["bindings"] -> showBindings
["linker"] -> io showLinkerState
- ["breaks"] -> showBkptTable
- ["context"] -> showContext
- _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]")
+ ["breaks"] -> showBkptTable
+ ["context"] -> showContext
+ _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
showModules = do
session <- getSession
s <- getSession
unqual <- io (GHC.getPrintUnqual s)
bindings <- io (GHC.getBindings s)
- mapM_ showTyThing bindings
+ mapM_ printTyThing $ sortBy compareTyThings bindings
return ()
-showTyThing (AnId id) = do
+compareTyThings :: TyThing -> TyThing -> Ordering
+t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
+
+printTyThing :: TyThing -> GHCi ()
+printTyThing (AnId id) = do
ty' <- cleanType (GHC.idType id)
printForUser $ ppr id <> text " :: " <> ppr ty'
-showTyThing _ = return ()
+printTyThing _ = return ()
-- if -fglasgow-exts is on we show the foralls, otherwise we don't.
cleanType :: Type -> GHCi Type
showBkptTable :: GHCi ()
showBkptTable = do
- activeBreaks <- getActiveBreakPoints
- printForUser $ ppr activeBreaks
+ st <- getGHCiState
+ printForUser $ prettyLocations (breaks st)
showContext :: GHCi ()
showContext = do
- st <- getGHCiState
- printForUser $ vcat (map pp_resume (resume st))
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
+ printForUser $ vcat (map pp_resume (reverse resumes))
where
- pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
+ pp_resume resume =
+ ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
+ $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
+
-- -----------------------------------------------------------------------------
-- Completion
other ->
return other
+wantInterpretedModule :: String -> GHCi Module
+wantInterpretedModule str = do
+ session <- getSession
+ modl <- lookupModule str
+ is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+ when (not is_interpreted) $
+ throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
+ return modl
+
+wantNameFromInterpretedModule noCanDo str and_then = do
+ session <- getSession
+ names <- io $ GHC.parseName session str
+ case names of
+ [] -> return ()
+ (n:_) -> do
+ let modl = GHC.nameModule n
+ if not (GHC.isExternalName n)
+ then noCanDo n $ ppr n <>
+ text " is not defined in an interpreted module"
+ else do
+ is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+ if not is_interpreted
+ then noCanDo n $ text "module " <> ppr modl <>
+ text " is not interpreted"
+ else and_then n
+
-- ----------------------------------------------------------------------------
-- Windows console setup
-- -----------------------------------------------------------------------------
-- commands for debugger
-foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
-
-stepCmd :: String -> GHCi Bool
-stepCmd [] = doContinue setStepFlag
-stepCmd expression = do
- io $ setStepFlag
- runCommand expression
-
-continueCmd :: String -> GHCi Bool
-continueCmd [] = doContinue $ return ()
-continueCmd other = do
- io $ putStrLn "The continue command accepts no arguments."
- return False
-
-doContinue :: IO () -> GHCi Bool
-doContinue actionBeforeCont = do
- resumeAction <- popResume
- case resumeAction of
- Nothing -> do
- io $ putStrLn "There is no computation running."
- return False
- Just (_,_,handle) -> do
- io $ actionBeforeCont
- session <- getSession
- runResult <- io $ GHC.resume session handle
- names <- switchOnRunResult runResult
- finishEvalExpr names
- return False
+sprintCmd = pprintCommand False False
+printCmd = pprintCommand True False
+forceCmd = pprintCommand False True
+
+pprintCommand bind force str = do
+ session <- getSession
+ io $ pprintClosureCommand session bind force str
+
+stepCmd :: String -> GHCi ()
+stepCmd [] = doContinue GHC.SingleStep
+stepCmd expression = do runStmt expression GHC.SingleStep; return ()
+
+traceCmd :: String -> GHCi ()
+traceCmd [] = doContinue GHC.RunAndLogSteps
+traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
+
+continueCmd :: String -> GHCi ()
+continueCmd = noArgs $ doContinue GHC.RunToCompletion
+
+doContinue :: SingleStep -> GHCi ()
+doContinue step = do
+ session <- getSession
+ runResult <- io $ GHC.resume session step
+ afterRunStmt runResult
+ return ()
+
+abandonCmd :: String -> GHCi ()
+abandonCmd = noArgs $ do
+ s <- getSession
+ b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
+ when (not b) $ io $ putStrLn "There is no computation running."
+ return ()
deleteCmd :: String -> GHCi ()
deleteCmd argLine = do
| all isDigit str = deleteBreak (read str)
| otherwise = return ()
+historyCmd :: String -> GHCi ()
+historyCmd arg
+ | null arg = history 20
+ | all isDigit arg = history (read arg)
+ | otherwise = io $ putStrLn "Syntax: :history [num]"
+ where
+ history num = do
+ s <- getSession
+ resumes <- io $ GHC.getResumeContext s
+ case resumes of
+ [] -> io $ putStrLn "Not stopped at a breakpoint"
+ (r:rs) -> do
+ let hist = GHC.resumeHistory r
+ (took,rest) = splitAt num hist
+ spans <- mapM (io . GHC.getHistorySpan s) took
+ let nums = map (printf "-%-3d:") [(1::Int)..]
+ printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
+ io $ putStrLn $ if null rest then "<end of history>" else "..."
+
+backCmd :: String -> GHCi ()
+backCmd = noArgs $ do
+ s <- getSession
+ (names, ix, span) <- io $ GHC.back s
+ printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
+ printTypeOfNames s names
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+
+forwardCmd :: String -> GHCi ()
+forwardCmd = noArgs $ do
+ s <- getSession
+ (names, ix, span) <- io $ GHC.forward s
+ printForUser $ (if (ix == 0)
+ then ptext SLIT("Stopped at")
+ else ptext SLIT("Logged breakpoint at")) <+> ppr span
+ printTypeOfNames s names
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+
-- handle the "break" command
breakCmd :: String -> GHCi ()
breakCmd argLine = do
io $ putStrLn "The break command requires at least one argument."
breakSwitch session args@(arg1:rest)
| looksLikeModuleName arg1 = do
- mod <- wantInterpretedModule session arg1
+ mod <- wantInterpretedModule arg1
breakByModule session mod rest
| all isDigit arg1 = do
(toplevel, _) <- io $ GHC.getContext session
[] -> do
io $ putStrLn "Cannot find default module for breakpoint."
io $ putStrLn "Perhaps no modules are loaded for debugging?"
- | otherwise = do -- assume it's a name
- names <- io $ GHC.parseName session arg1
- case names of
- [] -> return ()
- (n:_) -> do
- let loc = nameSrcLoc n
- modl = nameModule n
- is_interpreted <- io (GHC.moduleIsInterpreted session modl)
- if not is_interpreted
- then noCanDo $ text "module " <> ppr modl <>
- text " is not interpreted"
- else do
- if isGoodSrcLoc loc
- then findBreakAndSet (nameModule n) $
- findBreakByCoord (srcLocLine loc, srcLocCol loc)
- else noCanDo $ text "can't find its location: " <>
- ppr loc
- where
- noCanDo why = printForUser $
+ | otherwise = do -- try parsing it as an identifier
+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
+ if GHC.isGoodSrcLoc loc
+ then findBreakAndSet (GHC.nameModule name) $
+ findBreakByCoord (Just (GHC.srcLocFile loc))
+ (GHC.srcLocLine loc,
+ GHC.srcLocCol loc)
+ else noCanDo name $ text "can't find its location: " <> ppr loc
+ where
+ noCanDo n why = printForUser $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
-
-wantInterpretedModule :: Session -> String -> GHCi Module
-wantInterpretedModule session str = do
- modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
- is_interpreted <- io (GHC.moduleIsInterpreted session modl)
- when (not is_interpreted) $
- throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
- return modl
-
breakByModule :: Session -> Module -> [String] -> GHCi ()
breakByModule session mod args@(arg1:rest)
| all isDigit arg1 = do -- looks like a line number
breakByModuleLine mod line args
| [] <- args = findBreakAndSet mod $ findBreakByLine line
| [col] <- args, all isDigit col =
- findBreakAndSet mod $ findBreakByCoord (line, read col)
+ findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
| otherwise = io $ putStrLn "Invalid arguments to :break"
findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
{ breakModule = mod
, breakLoc = span
, breakTick = tick
+ , onBreakCmd = ""
}
printForUser $
text "Breakpoint " <> ppr nm <>
ticks = arr ! line
starts_here = [ tick | tick@(nm,span) <- ticks,
- srcSpanStartLine span == line ]
+ GHC.srcSpanStartLine span == line ]
(complete,incomplete) = partition ends_here starts_here
- where ends_here (nm,span) = srcSpanEndLine span == line
+ where ends_here (nm,span) = GHC.srcSpanEndLine span == line
-findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
-findBreakByCoord (line, col) arr
+findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
+ -> Maybe (BreakIndex,SrcSpan)
+findBreakByCoord mb_file (line, col) arr
| not (inRange (bounds arr) line) = Nothing
| otherwise =
- listToMaybe (sortBy rightmost contains)
+ listToMaybe (sortBy rightmost contains) `mplus`
+ listToMaybe (sortBy leftmost_smallest after_here)
where
ticks = arr ! line
-- the ticks that span this coordinate
- contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
+ contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
+ is_correct_file span ]
+
+ is_correct_file span
+ | Just f <- mb_file = GHC.srcSpanFile span == f
+ | otherwise = True
+
+ after_here = [ tick | tick@(nm,span) <- ticks,
+ GHC.srcSpanStartLine span == line,
+ GHC.srcSpanStartCol span >= col ]
+
leftmost_smallest (_,a) (_,b) = a `compare` b
-leftmost_largest (_,a) (_,b) = (srcSpanStart a `compare` srcSpanStart b)
+leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
`thenCmp`
- (srcSpanEnd b `compare` srcSpanEnd a)
+ (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
rightmost (_,a) (_,b) = b `compare` a
spans :: SrcSpan -> (Int,Int) -> Bool
-spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
- where loc = mkSrcLoc (srcSpanFile span) l c
+spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
+ where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
+
+-- for now, use ANSI bold on Unixy systems. On Windows, we add a line
+-- of carets under the active expression instead. The Windows console
+-- doesn't support ANSI escape sequences, and most Unix terminals
+-- (including xterm) do, so this is a reasonable guess until we have a
+-- proper termcap/terminfo library.
+#if !defined(mingw32_TARGET_OS)
+do_bold = True
+#else
+do_bold = False
+#endif
start_bold = BS.pack "\ESC[1m"
end_bold = BS.pack "\ESC[0m"
listCmd :: String -> GHCi ()
-listCmd str = do
- st <- getGHCiState
- case resume st of
- [] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
- (span,_,_):_ -> io $ listAround span True
+listCmd "" = do
+ mb_span <- getCurrentBreakSpan
+ case mb_span of
+ Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
+ Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
+ | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
+listCmd str = list2 (words str)
+
+list2 [arg] | all isDigit arg = do
+ session <- getSession
+ (toplevel, _) <- io $ GHC.getContext session
+ case toplevel of
+ [] -> io $ putStrLn "No module to list"
+ (mod : _) -> listModuleLine mod (read arg)
+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
+ mod <- wantInterpretedModule arg1
+ listModuleLine mod (read arg2)
+list2 [arg] = do
+ wantNameFromInterpretedModule noCanDo arg $ \name -> do
+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
+ if GHC.isGoodSrcLoc loc
+ then do
+ tickArray <- getTickArray (GHC.nameModule name)
+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
+ (GHC.srcLocLine loc, GHC.srcLocCol loc)
+ tickArray
+ case mb_span of
+ Nothing -> io $ listAround (GHC.srcLocSpan loc) False
+ Just (_,span) -> io $ listAround span False
+ else
+ noCanDo name $ text "can't find its location: " <>
+ ppr loc
+ where
+ noCanDo n why = printForUser $
+ text "cannot list source code for " <> ppr n <> text ": " <> why
+list2 _other =
+ io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
+
+listModuleLine :: Module -> Int -> GHCi ()
+listModuleLine modl line = do
+ session <- getSession
+ graph <- io (GHC.getModuleGraph session)
+ let this = filter ((== modl) . GHC.ms_mod) graph
+ case this of
+ [] -> panic "listModuleLine"
+ summ:_ -> do
+ let filename = fromJust (ml_hs_file (GHC.ms_location summ))
+ loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
+ io $ listAround (GHC.srcLocSpan loc) False
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
contents <- BS.readFile (unpackFS file)
let
lines = BS.split '\n' contents
- these_lines = take (line2 - line1 + 1 + 2*padding) $
- drop (line1 - 1 - padding) $ lines
- fst_line = max 1 (line1 - padding)
+ these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
+ drop (line1 - 1 - pad_before) $ lines
+ fst_line = max 1 (line1 - pad_before)
line_nos = [ fst_line .. ]
highlighted | do_highlight = zipWith highlight line_nos these_lines
--
BS.putStrLn (BS.join (BS.pack "\n") prefixed)
where
- file = srcSpanFile span
- line1 = srcSpanStartLine span
- col1 = srcSpanStartCol span
- line2 = srcSpanEndLine span
- col2 = srcSpanEndCol span
- padding = 1
-
- highlight no line
+ file = GHC.srcSpanFile span
+ line1 = GHC.srcSpanStartLine span
+ col1 = GHC.srcSpanStartCol span
+ line2 = GHC.srcSpanEndLine span
+ col2 = GHC.srcSpanEndCol span
+
+ pad_before | line1 == 1 = 0
+ | otherwise = 1
+ pad_after = 1
+
+ highlight | do_bold = highlight_bold
+ | otherwise = highlight_carets
+
+ highlight_bold no line
| no == line1 && no == line2
= let (a,r) = BS.splitAt col1 line
(b,c) = BS.splitAt (col2-col1) r
BS.concat [a, end_bold, b]
| otherwise = line
+ highlight_carets no line
+ | no == line1 && no == line2
+ = BS.concat [line, nl, indent, BS.replicate col1 ' ',
+ BS.replicate (col2-col1) '^']
+ | no == line1
+ = BS.concat [line, nl, indent, BS.replicate col1 ' ',
+ BS.replicate (BS.length line-col1) '^']
+ | no == line2
+ = BS.concat [line, nl, indent, BS.replicate col2 '^']
+ | otherwise = line
+ where
+ indent = BS.pack " "
+ nl = BS.singleton '\n'
+
-- --------------------------------------------------------------------------
-- Tick arrays
[ (line, (nm,span)) | (nm,span) <- ticks,
line <- srcSpanLines span ]
where
- max_line = maximum (map srcSpanEndLine (map snd ticks))
- srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
+ max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
+ srcSpanLines span = [ GHC.srcSpanStartLine span ..
+ GHC.srcSpanEndLine span ]
+
+lookupModule :: String -> GHCi Module
+lookupModule modName
+ = do session <- getSession
+ io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
+
+-- don't reset the counter back to zero?
+discardActiveBreakPoints :: GHCi ()
+discardActiveBreakPoints = do
+ st <- getGHCiState
+ mapM (turnOffBreak.snd) (breaks st)
+ setGHCiState $ st { breaks = [] }
+
+deleteBreak :: Int -> GHCi ()
+deleteBreak identity = do
+ st <- getGHCiState
+ let oldLocations = breaks st
+ (this,rest) = partition (\loc -> fst loc == identity) oldLocations
+ if null this
+ then printForUser (text "Breakpoint" <+> ppr identity <+>
+ text "does not exist")
+ else do
+ mapM (turnOffBreak.snd) this
+ setGHCiState $ st { breaks = rest }
+
+turnOffBreak loc = do
+ (arr, _) <- getModBreak (breakModule loc)
+ io $ setBreakFlag False arr (breakTick loc)
getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
getModBreak mod = do
let ticks = GHC.modBreaks_locs modBreaks
return (array, ticks)
-lookupModule :: Session -> String -> GHCi Module
-lookupModule session modName
- = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
-
setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
setBreakFlag toggle array index
| toggle = GHC.setBreakOn array index
| otherwise = GHC.setBreakOff array index
-
-{- these should probably go to the GHC API at some point -}
-enableBreakPoint :: Session -> Module -> Int -> IO ()
-enableBreakPoint session mod index = return ()
-
-disableBreakPoint :: Session -> Module -> Int -> IO ()
-disableBreakPoint session mod index = return ()
-
-activeBreakPoints :: Session -> IO [(Module,Int)]
-activeBreakPoints session = return []
-
-enableSingleStep :: Session -> IO ()
-enableSingleStep session = return ()
-
-disableSingleStep :: Session -> IO ()
-disableSingleStep session = return ()
projects / ghc-hetmet.git / blobdiff