Commit 38e7ac3f authored by Simon Marlow's avatar Simon Marlow
Browse files

Various cleanups and improvements to the breakpoint support

  - move parts of the debugger implementation below the GHC API where
    they belong.  There is still more in Debugger that violates the
    layering, hopefully I'll get to that later.

  - instead of returning an IO action from runStmt for resuming,
    return a ResumeHandle that is passed to GHC.resume.

  - breakpoints now return [Name] which is displayed in the same
    way as when a binding statement is executed.

  - :load, :add, :reload now clear the active breakpoints and context

  - :break gives a sensible error when used on a non-interpreted module

  - export breakpoint-related types from GHC

  - remove a bunch of layer-violating imports from InteractiveUI

  - remove some more vestiges of the old breakpoint code (topLevel in
    the GHCi state).

  - remove TickTree and use a simple array instead, cached per module
parent 71f74505
......@@ -30,7 +30,9 @@ module SrcLoc (
-- These are dubious exports, because they crash on some inputs,
-- used only in Lexer.x where we are sure what the Span looks like
srcSpanFile, srcSpanEndLine, srcSpanEndCol,
srcSpanFile,
srcSpanStartLine, srcSpanEndLine,
srcSpanStartCol, srcSpanEndCol,
Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc
) where
......
......@@ -87,8 +87,8 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do
| (P r1 c1 r2 c2, _box) <- entries ]
let modBreaks = emptyModBreaks
{ modBreaks_array = breakArray
, modBreaks_ticks = locsTicks
{ modBreaks_flags = breakArray
, modBreaks_locs = locsTicks
}
doIfSet_dyn dflags Opt_D_dump_hpc $ do
......@@ -170,6 +170,19 @@ addTickLHsExprBreakAlways e
| opt_Hpc = addTickLHsExpr e
| otherwise = addTickLHsExprAlways e
-- version of addTick that does not actually add a tick,
-- because the scope of this tick is completely subsumed by
-- another.
addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNever (L pos e0) = do
e1 <- addTickHsExpr e0
return $ L pos e1
addTickLHsExprBreakOnly :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprBreakOnly e
| opt_Hpc = addTickLHsExprNever e
| otherwise = addTickLHsExprAlways e
-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExpr (L pos e0) = do
......@@ -202,14 +215,6 @@ addTickLHsExprOptAlt oneOfMany (L pos e0)
fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos
return $ fn $ L pos e1
-- version of addTick that does not actually add a tick,
-- because the scope of this tick is completely subsumed by
-- another.
addTickLHsExpr' :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExpr' (L pos e0) = do
e1 <- addTickHsExpr e0
return $ L pos e1
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
addBinTickLHsExpr boxLabel (L pos e0) = do
e1 <- addTickHsExpr e0
......@@ -223,18 +228,18 @@ addTickHsExpr e@(HsLit _) = return e
addTickHsExpr e@(HsLam matchgroup) =
liftM HsLam (addTickMatchGroup matchgroup)
addTickHsExpr (HsApp e1 e2) =
liftM2 HsApp (addTickLHsExpr' e1) (addTickLHsExpr e2)
liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
addTickHsExpr (OpApp e1 e2 fix e3) =
liftM4 OpApp
(addTickLHsExpr e1)
(addTickLHsExpr' e2)
(addTickLHsExprNever e2)
(return fix)
(addTickLHsExpr e3)
addTickHsExpr (NegApp e neg) =
liftM2 NegApp
(addTickLHsExpr e)
(addTickSyntaxExpr hpcSrcSpan neg)
addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExpr' e)
addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExprNever e)
addTickHsExpr (SectionL e1 e2) =
liftM2 SectionL
(addTickLHsExpr e1)
......@@ -255,7 +260,7 @@ addTickHsExpr (HsIf e1 e2 e3) =
addTickHsExpr (HsLet binds e) =
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExpr' e)
(addTickLHsExprBreakOnly e)
addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
liftM4 HsDo
(return cxt)
......@@ -289,7 +294,7 @@ addTickHsExpr (RecordUpd e rec_binds ty1 ty2) =
addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
addTickHsExpr (ExprWithTySigOut e ty) =
liftM2 ExprWithTySigOut
(addTickLHsExpr' e) -- No need to tick the inner expression
(addTickLHsExprNever e) -- No need to tick the inner expression
-- for expressions with signatures
(return ty)
addTickHsExpr (ArithSeq ty arith_seq) =
......
......@@ -1446,7 +1446,7 @@ runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r)
runBc us modBreaks (BcM m)
= m (BcM_State us 0 [] breakArray)
where
breakArray = modBreaks_array modBreaks
breakArray = modBreaks_flags modBreaks
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
......
......@@ -4,10 +4,15 @@
--
-- Pepe Iborra (supported by Google SoC) 2006
--
-- ToDo: lots of violation of layering here. This module should
-- decide whether it is above the GHC API (import GHC and nothing
-- else) or below it.
--
-----------------------------------------------------------------------------
module Debugger (pprintClosureCommand, instantiateTyVarsToUnknown) where
module Debugger (pprintClosureCommand) where
import qualified DebuggerTys
import Linker
import RtClosureInspect
......@@ -24,7 +29,6 @@ import RdrName
import UniqSupply
import Type
import TyCon
import DataCon
import TcGadt
import GHC
import GhciMonad
......@@ -203,56 +207,6 @@ newGrimName cms userName = do
name = mkInternalName unique occname noSrcLoc
return name
----------------------------------------------------------------------------
-- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
----------------------------------------------------------------------------
instantiateTyVarsToUnknown :: Session -> Type -> IO Type
instantiateTyVarsToUnknown cms ty
-- We have a GADT, so just fix its tyvars
| Just (tycon, args) <- splitTyConApp_maybe ty
, tycon /= funTyCon
, isGADT tycon
= mapM fixTyVars args >>= return . mkTyConApp tycon
-- We have a regular TyCon, so map recursively to its args
| Just (tycon, args) <- splitTyConApp_maybe ty
, tycon /= funTyCon
= do unknownTyVar <- unknownTV
args' <- mapM (instantiateTyVarsToUnknown cms) args
return$ mkTyConApp tycon args'
-- we have a tyvar of kind *
| Just tyvar <- getTyVar_maybe ty
, ([],_) <- splitKindFunTys (tyVarKind tyvar)
= unknownTV
-- we have a higher kind tyvar, so insert an unknown of the appropriate kind
| Just tyvar <- getTyVar_maybe ty
, (args,_) <- splitKindFunTys (tyVarKind tyvar)
= liftM mkTyConTy $ unknownTC !! length args
-- Base case
| otherwise = return ty
where unknownTV = do
Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName
return$ mkTyConTy unknown_tc
unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
unknownTC1 = do
Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName
return unknown_tc
unknownTC2 = do
Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName
return unknown_tc
unknownTC3 = do
Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName
return unknown_tc
-- isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
| otherwise = False
fixTyVars ty
| Just (tycon, args) <- splitTyConApp_maybe ty
= mapM fixTyVars args >>= return . mkTyConApp tycon
-- Fix the tyvar so that the interactive environment doesn't choke on it TODO
| Just tv <- getTyVar_maybe ty = return ty --TODO
| otherwise = return ty
-- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
stripUnknowns :: [Name] -> Id -> Id
stripUnknowns names id = setIdType id . fst . go names . idType
......@@ -289,3 +243,8 @@ stripUnknowns names id = setIdType id . fst . go names . idType
kind1 = mkArrowKind liftedTypeKind liftedTypeKind
kind2 = mkArrowKind kind1 liftedTypeKind
kind3 = mkArrowKind kind2 liftedTypeKind
instantiateTyVarsToUnknown :: Session -> Type -> IO Type
instantiateTyVarsToUnknown (Session ref) ty
= do hsc_env <- readIORef ref
DebuggerTys.instantiateTyVarsToUnknown hsc_env ty
......@@ -17,11 +17,13 @@ import Util
import DynFlags
import HscTypes
import SrcLoc
import Module
import Numeric
import Control.Concurrent
import Control.Exception as Exception
import Data.Array
import Data.Char
import Data.Dynamic
import Data.Int ( Int64 )
import Data.IORef
import Data.List
......@@ -43,11 +45,16 @@ data GHCiState = GHCiState
session :: GHC.Session,
options :: [GHCiOption],
prelude :: GHC.Module,
topLevel :: Bool,
resume :: [IO GHC.RunResult],
breaks :: !ActiveBreakPoints
resume :: [(SrcSpan, ThreadId, GHC.ResumeHandle)],
breaks :: !ActiveBreakPoints,
tickarrays :: ModuleEnv TickArray
-- tickarrays caches the TickArray for loaded modules,
-- so that we don't rebuild it each time the user sets
-- a breakpoint.
}
type TickArray = Array Int [(BreakIndex,SrcSpan)]
data GHCiOption
= ShowTiming -- show time/allocs after evaluation
| ShowType -- show the type of expressions
......@@ -86,8 +93,8 @@ getActiveBreakPoints :: GHCi ActiveBreakPoints
getActiveBreakPoints = liftM breaks getGHCiState
-- don't reset the counter back to zero?
clearActiveBreakPoints :: GHCi ()
clearActiveBreakPoints = do
discardActiveBreakPoints :: GHCi ()
discardActiveBreakPoints = do
st <- getGHCiState
let oldActiveBreaks = breaks st
newActiveBreaks = oldActiveBreaks { breakLocations = [] }
......@@ -172,28 +179,23 @@ unsetOption opt
io :: IO a -> GHCi a
io m = GHCi { unGHCi = \s -> m >>= return }
isTopLevel :: GHCi Bool
isTopLevel = getGHCiState >>= return . topLevel
getResume :: GHCi (Maybe (IO GHC.RunResult))
getResume = do
st <- getGHCiState
case (resume st) of
[] -> return Nothing
(x:_) -> return $ Just x
popResume :: GHCi ()
popResume :: GHCi (Maybe (SrcSpan, ThreadId, GHC.ResumeHandle))
popResume = do
st <- getGHCiState
case (resume st) of
[] -> return ()
(_:xs) -> setGHCiState $ st { resume = xs }
[] -> return Nothing
(x:xs) -> do setGHCiState $ st { resume = xs } ; return (Just x)
pushResume :: IO GHC.RunResult -> GHCi ()
pushResume resumeAction = do
pushResume :: SrcSpan -> ThreadId -> GHC.ResumeHandle -> GHCi ()
pushResume span threadId resumeAction = do
st <- getGHCiState
let oldResume = resume st
setGHCiState $ st { resume = resumeAction : oldResume }
setGHCiState $ st { resume = (span, threadId, resumeAction) : oldResume }
discardResumeContext :: GHCi ()
discardResumeContext = do
st <- getGHCiState
setGHCiState st { resume = [] }
showForUser :: SDoc -> GHCi String
showForUser doc = do
......
......@@ -18,13 +18,16 @@ import GhciMonad
-- 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 Module -- for ModuleEnv
-- for createtags
import Name
......@@ -40,18 +43,6 @@ 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
......@@ -74,7 +65,7 @@ import Control.Exception as Exception
-- import Control.Concurrent
import Data.List
import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
import Data.Maybe
import System.Cmd
import System.Environment
import System.Exit ( exitWith, ExitCode(..) )
......@@ -85,8 +76,8 @@ import Data.Char
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) )
......@@ -98,7 +89,6 @@ import System.Posix.Internals ( setNonBlockingFD )
import ByteCodeLink (HValue)
import ByteCodeInstr (BreakInfo (..))
import BreakArray
import TickTree
-----------------------------------------------------------------------------
......@@ -118,10 +108,10 @@ builtin_commands :: [Command]
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),
("add", keepGoingPaths addModule, False, completeFilename),
("break", breakCmd, False, completeNone),
("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),
("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
......@@ -134,12 +124,12 @@ builtin_commands = [
("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),
("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),
......@@ -152,14 +142,6 @@ builtin_commands = [
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
......@@ -279,9 +261,9 @@ interactiveUI session srcs maybe_expr = do
session = session,
options = [],
prelude = prel_mod,
topLevel = True,
resume = [],
breaks = emptyActiveBreakPoints
breaks = emptyActiveBreakPoints,
tickarrays = emptyModuleEnv
}
#ifdef USE_READLINE
......@@ -462,7 +444,7 @@ mkPrompt toplevs exports prompt
perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
hsep (map (ppr . GHC.moduleName) exports)
#ifdef USE_READLINE
readlineLoop :: GHCi ()
......@@ -513,9 +495,9 @@ runCommandEval c = ghciHandle handleEval (doCommand c)
-- failure to run the command causes exit(1) for ghc -e.
_ -> finishEvalExpr nms
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
......@@ -523,90 +505,34 @@ runStmt stmt
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)
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 ticks = GHC.modBreaks_locs modBreaks
-- display information about the breakpoint
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
unqual <- io $ GHC.getPrintUnqual session
io $ printForUser stdout unqual $
ptext SLIT("Stopped at") <+> ppr location
-- | Instantiate the tyVars with GHC.Base.Unknown
instantiateIdType :: Id -> IO Id
instantiateIdType id = do
instantiatedType <- instantiateTyVarsToUnknown s (idType id)
return$ setIdType id instantiatedType
pushResume location threadId resume
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
......@@ -841,6 +767,9 @@ reloadModule m = do
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'
......@@ -1043,10 +972,8 @@ browseCmd m =
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
......@@ -1530,15 +1457,15 @@ continueCmd other = do
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
......@@ -1552,7 +1479,7 @@ deleteCmd argLine = do
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
......@@ -1573,7 +1500,7 @@ breakSwitch _session [] = do
return False
breakSwitch session args@(arg1:rest)
| looksLikeModule arg1 = do
mod <- lookupModule session arg1
mod <- wantInterpretedModule session arg1
breakByModule mod rest
return False
| otherwise = do
......@@ -1590,6 +1517,14 @@ breakSwitch session args@(arg1:rest)
looksLikeModule [] = False
looksLikeModule (x:_) = isUpper x
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 :: Module -> [String] -> GHCi ()
breakByModule mod args@(arg1:rest)
| all isDigit arg1 = do -- looks like a line number
......@@ -1606,16 +1541,16 @@ breakByModule mod args@(arg1:rest)
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)
findBreakAndSet mod $ findBreakByCoord (line, read col)
| otherwise = io $ putStrLn "Invalid arguments to break command."
findBreakAndSet :: Module -> (TickTree -> Maybe (Int, SrcSpan)) -> GHCi ()
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