-- The GHC interface
import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
- Type, Module, ModuleName, TyThing(..), Phase )
+ Type, Module, ModuleName, TyThing(..), Phase,
+ BreakIndex )
+import Debugger
import DynFlags
import Packages
import PackageConfig
import UniqFM
import PprTyThing
-import Outputable
+import Outputable hiding (printForUser)
+import Module -- for ModuleEnv
-- for createtags
import Name
import Digraph
import BasicTypes hiding (isTopLevel)
import Panic hiding (showException)
+import FastString ( unpackFS )
import Config
import StaticFlags
import Linker
import Util
--- The debugger
-import Debugger
-import HscTypes
-import Id
-import Var ( globaliseId )
-import IdInfo
-import NameEnv
-import RdrName
-import Module
-import Type
-import TcType
-
#ifndef mingw32_HOST_OS
import System.Posix
#if __GLASGOW_HASKELL__ > 504
import Control.Exception as Exception
-- import Control.Concurrent
+import qualified Data.ByteString.Char8 as BS
import Data.List
-import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
+import Data.Maybe
import System.Cmd
import System.Environment
import System.Exit ( exitWith, ExitCode(..) )
import Data.Dynamic
import Data.Array
import Control.Monad as Monad
-import Foreign.StablePtr ( StablePtr, newStablePtr, deRefStablePtr, freeStablePtr )
+import Foreign.StablePtr ( newStablePtr )
import GHC.Exts ( unsafeCoerce# )
-import GHC.IOBase ( IOErrorType(InvalidArgument), IO(IO) )
+import GHC.IOBase ( IOErrorType(InvalidArgument) )
import Data.IORef ( IORef, readIORef, writeIORef )
import System.Posix.Internals ( setNonBlockingFD )
--- these are needed by the new ghci debugger
-import ByteCodeLink (HValue)
-import ByteCodeInstr (BreakInfo (..))
-import BreakArray
-import TickTree
-
-----------------------------------------------------------------------------
ghciWelcomeMsg =
builtin_commands = [
-- Hugs users are accustomed to :e, so make sure it doesn't overlap
("?", keepGoing help, False, completeNone),
- ("add", tlC$ keepGoingPaths addModule, False, completeFilename),
- ("break", breakCmd, False, completeNone),
+ ("add", keepGoingPaths addModule, False, completeFilename),
+ ("break", keepGoing breakCmd, False, completeIdentifier),
("browse", keepGoing browseCmd, False, completeModule),
- ("cd", tlC$ keepGoing changeDirectory, False, completeFilename),
+ ("cd", keepGoing changeDirectory, False, completeFilename),
("check", keepGoing checkModule, False, completeHomeModule),
- ("continue", continueCmd, False, completeNone),
+ ("continue", continueCmd, False, completeNone),
("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
- ("delete", deleteCmd, False, completeNone),
+ ("delete", keepGoing deleteCmd, False, completeNone),
("e", keepGoing editFile, False, completeFilename),
("edit", keepGoing editFile, False, completeFilename),
("etags", keepGoing createETagsFileCmd, False, completeFilename),
("help", keepGoing help, False, completeNone),
("info", keepGoing info, False, completeIdentifier),
("kind", keepGoing kindOfType, False, completeIdentifier),
- ("load", tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
+ ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
+ ("list", keepGoing listCmd, False, completeNone),
("module", keepGoing setContext, False, completeModule),
- ("main", tlC$ keepGoing runMain, False, completeIdentifier),
+ ("main", keepGoing runMain, False, completeIdentifier),
("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
("quit", quit, False, completeNone),
- ("reload", tlC$ keepGoing reloadModule, 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, completeNone),
+ ("step", stepCmd, False, completeIdentifier),
("type", keepGoing typeOfExpr, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
("unset", keepGoing unsetOptions, True, completeSetOptions)
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False
--- tlC: Top Level Command, not allowed in inferior sessions
-tlC :: (String -> GHCi Bool) -> (String -> GHCi Bool)
-tlC a str = do
- top_level <- isTopLevel
- if not top_level
- then throwDyn (CmdLineError "Command only allowed at Top Level")
- else a str
-
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
keepGoingPaths a str = a (toArgs str) >> return False
shortHelpText = "use :? for help.\n"
--- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
helpText =
" Commands available from the prompt:\n" ++
"\n" ++
" <stmt> evaluate/run <stmt>\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" ++
+ " :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" ++
- " :print [<name> ...] prints a value without forcing its computation\n" ++
- " :sprint [<name> ...] simplified version of :print\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" ++
"\n" ++
" :set <option> ... set options\n" ++
" :set prog <progname> set the value returned by System.getProgName\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" ++
- " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
- " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\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" ++
- " :kind <type> show the kind of <type>\n" ++
" :undef <cmd> undefine user-defined command :<cmd>\n" ++
" :unset <option> ... unset options\n" ++
- " :quit exit GHCi\n" ++
" :!<command> run the shell command <command>\n" ++
"\n" ++
" Options for ':set' and ':unset':\n" ++
GHCiState{ progname = "<interactive>",
args = [],
prompt = "%s> ",
+ stop = "",
editor = default_editor,
session = session,
options = [],
prelude = prel_mod,
- topLevel = True,
resume = [],
- breaks = emptyActiveBreakPoints
+ breaks = emptyActiveBreakPoints,
+ tickarrays = emptyModuleEnv
}
#ifdef USE_READLINE
perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
hsep (map (ppr . GHC.moduleName) exports)
-
+
#ifdef USE_READLINE
readlineLoop :: GHCi ()
case nms of
Nothing -> io (exitWith (ExitFailure 1))
-- failure to run the command causes exit(1) for ghc -e.
- _ -> finishEvalExpr nms
+ _ -> do finishEvalExpr nms
+ return True
-runStmt :: String -> GHCi (Maybe [Name])
+runStmt :: String -> GHCi (Maybe (Bool,[Name]))
runStmt stmt
- | null (filter (not.isSpace) stmt) = return (Just [])
+ | null (filter (not.isSpace) stmt) = return (Just (False,[]))
| otherwise
= do st <- getGHCiState
session <- getSession
GHC.runStmt session stmt
switchOnRunResult result
-switchOnRunResult :: GHC.RunResult -> GHCi (Maybe [Name])
+switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
switchOnRunResult GHC.RunFailed = return Nothing
switchOnRunResult (GHC.RunException e) = throw e
-switchOnRunResult (GHC.RunOk names) = return $ Just names
-switchOnRunResult (GHC.RunBreak apStack _threadId info resume) = do -- Todo: we don't use threadID, perhaps delete?
+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 (breakInfo_module info)
+ Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
let modBreaks = GHC.modInfoModBreaks mod_info
- let ticks = modBreaks_ticks modBreaks
- io $ displayBreakInfo session ticks info
- io $ extendEnvironment session apStack (breakInfo_vars info)
- pushResume resume
- return Nothing
-
-displayBreakInfo :: Session -> Array Int SrcSpan -> BreakInfo -> IO ()
-displayBreakInfo session ticks info = do
- unqual <- GHC.getPrintUnqual session
- let location = ticks ! breakInfo_number info
- printForUser stdout unqual $
- ptext SLIT("Stopped at") <+> ppr location $$ localsMsg
- where
- vars = map fst $ breakInfo_vars info
- localsMsg = if null vars
- then text "No locals in scope."
- else text "Locals:" <+> (pprWithCommas showId vars)
- showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
-
--- Todo: turn this into a primop, and provide special version(s) for unboxed things
-foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
-
-getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue)
-getIdValFromApStack apStack (identifier, stackDepth) = do
- -- ToDo: check the type of the identifer and decide whether it is unboxed or not
- apSptr <- newStablePtr apStack
- resultSptr <- getApStackVal apSptr (stackDepth - 1)
- result <- deRefStablePtr resultSptr
- freeStablePtr apSptr
- freeStablePtr resultSptr
- return (identifier, unsafeCoerce# result)
-
-extendEnvironment :: Session -> a -> [(Id, Int)] -> IO ()
-extendEnvironment s@(Session ref) apStack idsOffsets = do
- idsVals <- mapM (getIdValFromApStack apStack) idsOffsets
- let (ids, hValues) = unzip idsVals
- let names = map idName ids
- let global_ids = map globaliseAndTidy ids
- typed_ids <- mapM instantiateIdType global_ids
- hsc_env <- readIORef ref
- let ictxt = hsc_IC hsc_env
- rn_env = ic_rn_local_env ictxt
- type_env = ic_type_env ictxt
- bound_names = map idName typed_ids
- new_rn_env = extendLocalRdrEnv rn_env bound_names
- -- Remove any shadowed bindings from the type_env;
- -- they are inaccessible but might, I suppose, cause
- -- a space leak if we leave them there
- shadowed = [ n | name <- bound_names,
- let rdr_name = mkRdrUnqual (nameOccName name),
- Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
- filtered_type_env = delListFromNameEnv type_env shadowed
- new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
- new_ic = ictxt { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
- writeIORef ref (hsc_env { hsc_IC = new_ic })
- extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint
- where
- globaliseAndTidy :: Id -> Id
- globaliseAndTidy id
- = let tidied_type = tidyTopType$ idType id
- in setIdType (globaliseId VanillaGlobal id) tidied_type
+ let ticks = GHC.modBreaks_locs modBreaks
- -- | Instantiate the tyVars with GHC.Base.Unknown
- instantiateIdType :: Id -> IO Id
- instantiateIdType id = do
- instantiatedType <- instantiateTyVarsToUnknown s (idType id)
- return$ setIdType id instantiatedType
+ -- display information about the breakpoint
+ let location = ticks ! GHC.breakInfo_number info
+ printForUser $ ptext SLIT("Stopped at") <+> ppr location
+
+ pushResume location threadId resume
+
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ runCommand (stop st)
+
+ return (Just (True,names))
-- possibly print the type and revert CAFs after evaluating an expression
finishEvalExpr mb_names
- = do b <- isOptionSet ShowType
+ = do show_types <- isOptionSet ShowType
session <- getSession
case mb_names of
Nothing -> return ()
- Just names -> when b (mapM_ (showTypeOfName session) names)
+ Just (is_break,names) ->
+ when (is_break || show_types) $
+ mapM_ (showTypeOfName session) names
flushInterpBuffers
io installSignalHandlers
b <- isOptionSet RevertCAFs
io (when b revertCAFs)
- return True
showTypeOfName :: Session -> Name -> GHCi ()
showTypeOfName session n
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'
case maybe_ty of
Nothing -> return ()
Just ty -> do ty' <- cleanType ty
- tystr <- showForUser (ppr ty')
- io (putStrLn (str ++ " :: " ++ tystr))
+ printForUser $ text str <> text " :: " <> ppr ty'
kindOfType :: String -> GHCi ()
kindOfType str
maybe_ty <- io (GHC.typeKind cms str)
case maybe_ty of
Nothing -> return ()
- Just ty -> do tystr <- showForUser (ppr ty)
- io (putStrLn (str ++ " :: " ++ tystr))
+ Just ty -> printForUser $ text str <> text " :: " <> ppr ty
quit :: String -> GHCi Bool
quit _ = return True
browseModule m exports_only = do
s <- getSession
- modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
- is_interpreted <- io (GHC.moduleIsInterpreted s modl)
- when (not is_interpreted && not exports_only) $
- throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
+ modl <- if exports_only then lookupModule s m
+ else wantInterpretedModule s m
-- Temporarily set the context to the module we're interested in,
-- just so we can get an appropriate PrintUnqualified
("prog":prog) -> setProg prog
("prompt":prompt) -> setPrompt (after 6)
("editor":cmd) -> setEditor (after 6)
+ ("stop":cmd) -> setStop (after 4)
wds -> setOptions wds
where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
st <- getGHCiState
setGHCiState st{ editor = cmd }
+setStop cmd = do
+ st <- getGHCiState
+ setGHCiState st{ stop = cmd }
+
setPrompt value = do
st <- getGHCiState
if null value
["bindings"] -> showBindings
["linker"] -> io showLinkerState
["breaks"] -> showBkptTable
- _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
+ ["context"] -> showContext
+ _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]")
showModules = do
session <- getSession
showTyThing (AnId id) = do
ty' <- cleanType (GHC.idType id)
- str <- showForUser (ppr id <> text " :: " <> ppr ty')
- io (putStrLn str)
+ printForUser $ ppr id <> text " :: " <> ppr ty'
showTyThing _ = return ()
-- if -fglasgow-exts is on we show the foralls, otherwise we don't.
showBkptTable :: GHCi ()
showBkptTable = do
activeBreaks <- getActiveBreakPoints
- str <- showForUser $ ppr activeBreaks
- io $ putStrLn str
+ printForUser $ ppr activeBreaks
+
+showContext :: GHCi ()
+showContext = do
+ st <- getGHCiState
+ printForUser $ vcat (map pp_resume (resume st))
+ where
+ pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
-- -----------------------------------------------------------------------------
-- Completion
#endif
return ()
+-- -----------------------------------------------------------------------------
-- commands for debugger
+
foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
stepCmd :: String -> GHCi Bool
doContinue :: IO () -> GHCi Bool
doContinue actionBeforeCont = do
- resumeAction <- getResume
- popResume
+ resumeAction <- popResume
case resumeAction of
Nothing -> do
io $ putStrLn "There is no computation running."
return False
- Just action -> do
+ Just (_,_,handle) -> do
io $ actionBeforeCont
- runResult <- io action
+ session <- getSession
+ runResult <- io $ GHC.resume session handle
names <- switchOnRunResult runResult
finishEvalExpr names
- return False
+ return False
-deleteCmd :: String -> GHCi Bool
+deleteCmd :: String -> GHCi ()
deleteCmd argLine = do
deleteSwitch $ words argLine
- return False
where
deleteSwitch :: [String] -> GHCi ()
deleteSwitch [] =
io $ putStrLn "The delete command requires at least one argument."
-- delete all break points
- deleteSwitch ("*":_rest) = clearActiveBreakPoints
+ deleteSwitch ("*":_rest) = discardActiveBreakPoints
deleteSwitch idents = do
mapM_ deleteOneBreak idents
where
| otherwise = return ()
-- handle the "break" command
-breakCmd :: String -> GHCi Bool
+breakCmd :: String -> GHCi ()
breakCmd argLine = do
session <- getSession
breakSwitch session $ words argLine
-breakSwitch :: Session -> [String] -> GHCi Bool
+breakSwitch :: Session -> [String] -> GHCi ()
breakSwitch _session [] = do
io $ putStrLn "The break command requires at least one argument."
- return False
breakSwitch session args@(arg1:rest)
- | looksLikeModule arg1 = do
- mod <- lookupModule session arg1
- breakByModule mod rest
- return False
- | otherwise = do
+ | looksLikeModuleName arg1 = do
+ mod <- wantInterpretedModule session arg1
+ breakByModule session mod rest
+ | all isDigit arg1 = do
(toplevel, _) <- io $ GHC.getContext session
case toplevel of
- (mod : _) -> breakByModule mod args
+ (mod : _) -> breakByModuleLine mod (read arg1) rest
[] -> do
io $ putStrLn "Cannot find default module for breakpoint."
io $ putStrLn "Perhaps no modules are loaded for debugging?"
- return False
- where
- -- Todo there may be a nicer way to test this
- looksLikeModule :: String -> Bool
- looksLikeModule [] = False
- looksLikeModule (x:_) = isUpper x
-
-breakByModule :: Module -> [String] -> GHCi ()
-breakByModule mod args@(arg1:rest)
+ | 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 $
+ 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 (read arg1) rest
- | looksLikeVar arg1 = do
- -- break by a function definition
- io $ putStrLn "Break by function definition not implemented."
- | otherwise = io $ putStrLn "Invalid arguments to break command."
- where
- -- Todo there may be a nicer way to test this
- looksLikeVar :: String -> Bool
- looksLikeVar [] = False
- looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+"
+ | otherwise = io $ putStrLn "Invalid arguments to :break"
breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
breakByModuleLine mod line args
- | [] <- args = findBreakAndSet mod $ lookupTickTreeLine line
+ | [] <- args = findBreakAndSet mod $ findBreakByLine line
| [col] <- args, all isDigit col =
- findBreakAndSet mod $ lookupTickTreeCoord (line, read col)
- | otherwise = io $ putStrLn "Invalid arguments to break command."
-
-findBreakAndSet :: Module -> (TickTree -> Maybe (Int, SrcSpan)) -> GHCi ()
+ findBreakAndSet mod $ findBreakByCoord (line, read col)
+ | otherwise = io $ putStrLn "Invalid arguments to :break"
+
+findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
findBreakAndSet mod lookupTickTree = do
- (breakArray, ticks) <- getModBreak mod
- let tickTree = tickTreeFromList (assocs ticks)
- case lookupTickTree tickTree of
+ tickArray <- getTickArray mod
+ (breakArray, _) <- getModBreak mod
+ case lookupTickTree tickArray of
Nothing -> io $ putStrLn $ "No breakpoints found at that location."
Just (tick, span) -> do
success <- io $ setBreakFlag True breakArray tick
session <- getSession
- unqual <- io $ GHC.getPrintUnqual session
if success
then do
(alreadySet, nm) <-
, breakLoc = span
, breakTick = tick
}
- io $ printForUser stdout unqual $
+ printForUser $
text "Breakpoint " <> ppr nm <>
if alreadySet
then text " was already set at " <> ppr span
else text " activated at " <> ppr span
else do
- str <- showForUser $ text "Breakpoint could not be activated at"
+ printForUser $ text "Breakpoint could not be activated at"
<+> ppr span
- io $ putStrLn str
-getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
+-- When a line number is specified, the current policy for choosing
+-- the best breakpoint is this:
+-- - the leftmost complete subexpression on the specified line, or
+-- - the leftmost subexpression starting on the specified line, or
+-- - the rightmost subexpression enclosing the specified line
+--
+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
+findBreakByLine line arr
+ | not (inRange (bounds arr) line) = Nothing
+ | otherwise =
+ listToMaybe (sortBy leftmost complete) `mplus`
+ listToMaybe (sortBy leftmost incomplete) `mplus`
+ listToMaybe (sortBy rightmost ticks)
+ where
+ ticks = arr ! line
+
+ starts_here = [ tick | tick@(nm,span) <- ticks,
+ srcSpanStartLine span == line ]
+
+ (complete,incomplete) = partition ends_here starts_here
+ where ends_here (nm,span) = srcSpanEndLine span == line
+
+findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
+findBreakByCoord (line, col) arr
+ | not (inRange (bounds arr) line) = Nothing
+ | otherwise =
+ listToMaybe (sortBy rightmost contains)
+ where
+ ticks = arr ! line
+
+ -- the ticks that span this coordinate
+ contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
+
+leftmost (_,a) (_,b) = a `compare` b
+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
+
+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
+
+-- | list a section of a source file around a particular SrcSpan.
+-- If the highlight flag is True, also highlight the span using
+-- start_bold/end_bold.
+listAround span do_highlight = do
+ 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)
+ line_nos = [ fst_line .. ]
+
+ highlighted | do_highlight = zipWith highlight line_nos these_lines
+ | otherwise = these_lines
+
+ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
+ prefixed = zipWith BS.append bs_line_nos highlighted
+ --
+ 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
+ | no == line1 && no == line2
+ = let (a,r) = BS.splitAt col1 line
+ (b,c) = BS.splitAt (col2-col1) r
+ in
+ BS.concat [a,start_bold,b,end_bold,c]
+ | no == line1
+ = let (a,b) = BS.splitAt col1 line in
+ BS.concat [a, start_bold, b]
+ | no == line2
+ = let (a,b) = BS.splitAt col2 line in
+ BS.concat [a, end_bold, b]
+ | otherwise = line
+
+-- --------------------------------------------------------------------------
+-- Tick arrays
+
+getTickArray :: Module -> GHCi TickArray
+getTickArray modl = do
+ st <- getGHCiState
+ let arrmap = tickarrays st
+ case lookupModuleEnv arrmap modl of
+ Just arr -> return arr
+ Nothing -> do
+ (breakArray, ticks) <- getModBreak modl
+ let arr = mkTickArray (assocs ticks)
+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
+ return arr
+
+discardTickArrays :: GHCi ()
+discardTickArrays = do
+ st <- getGHCiState
+ setGHCiState st{tickarrays = emptyModuleEnv}
+
+mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
+mkTickArray ticks
+ = accumArray (flip (:)) [] (1, max_line)
+ [ (line, (nm,span)) | (nm,span) <- ticks,
+ line <- srcSpanLines span ]
+ where
+ max_line = maximum (map srcSpanEndLine (map snd ticks))
+ srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
+
+getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
getModBreak mod = do
session <- getSession
Just mod_info <- io $ GHC.getModuleInfo session mod
let modBreaks = GHC.modInfoModBreaks mod_info
- let array = modBreaks_array modBreaks
- let ticks = modBreaks_ticks modBreaks
+ let array = GHC.modBreaks_flags modBreaks
+ 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 -> BreakArray -> Int -> IO Bool
+setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
setBreakFlag toggle array index
- | toggle = setBreakOn array index
- | otherwise = setBreakOff array index
+ | toggle = GHC.setBreakOn array index
+ | otherwise = GHC.setBreakOff array index
{- these should probably go to the GHC API at some point -}
projects / ghc-hetmet.git / blobdiff