Skip to content

Commit 3b5d8cd

Browse files
mpickeringmpickering
committed
Implement ExceptionInfo request
The ExceptionInfo request is used by debuggers in order to display information about the exception we are stopped at.
1 parent b0cf97d commit 3b5d8cd

10 files changed

Lines changed: 203 additions & 8 deletions

File tree

‎haskell-debugger-view/haskell-debugger-view.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ library
3737
GHC.Debugger.View.Containers
3838
GHC.Debugger.View.Text
3939
GHC.Debugger.View.ByteString
40+
GHC.Debugger.View.Exception
4041
build-depends: base >= 4.22 && < 5,
4142
containers >= 0.7 && < 0.9,
4243
text >= 2.1 && < 2.3,

‎haskell-debugger-view/src/GHC/Debugger/View/Exception.hs‎

Lines changed: 43 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,43 @@
1+
module GHC.Debugger.View.Exception
2+
( ExceptionInfoNode(..)
3+
, collectExceptionInfo
4+
) where
5+
6+
import Control.Exception
7+
import qualified Control.Exception.Context as Context
8+
import Data.Typeable (typeOf, typeRepTyCon, tyConModule, tyConName, tyConPackage)
9+
10+
data ExceptionInfoNode = ExceptionInfoNode
11+
{ exceptionNodeFullTypeName :: String
12+
, exceptionNodeTypeName :: String
13+
, exceptionNodeMessage :: String
14+
, exceptionNodeContext :: Maybe String
15+
, exceptionNodeInner :: [ExceptionInfoNode]
16+
}
17+
deriving Show
18+
19+
collectExceptionInfo :: SomeException -> ExceptionInfoNode
20+
collectExceptionInfo se@(SomeException exc) = ExceptionInfoNode
21+
{ exceptionNodeFullTypeName = fullTypeName
22+
, exceptionNodeTypeName = simpleTypeName
23+
, exceptionNodeMessage = displayException se
24+
, exceptionNodeContext = contextText
25+
, exceptionNodeInner = map (collectExceptionInfo . unwrap) whileHandling
26+
}
27+
where
28+
ctx = someExceptionContext se
29+
contextText =
30+
let rendered = Context.displayExceptionContext ctx
31+
in if null rendered then Nothing else Just rendered
32+
whileHandling :: [WhileHandling]
33+
whileHandling = Context.getExceptionAnnotations ctx
34+
unwrap (WhileHandling inner) = inner
35+
tc = typeRepTyCon (typeOf exc)
36+
simpleTypeName = tyConName tc
37+
packagePrefix = case tyConPackage tc of
38+
pkg | null pkg -> ""
39+
| otherwise -> pkg ++ ":"
40+
modulePrefix = case tyConModule tc of
41+
mdl | null mdl -> ""
42+
| otherwise -> mdl ++ "."
43+
fullTypeName = packagePrefix ++ modulePrefix ++ simpleTypeName

‎haskell-debugger.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -132,6 +132,7 @@ executable hdb
132132
Development.Debug.Adapter.Stepping,
133133
Development.Debug.Adapter.Stopped,
134134
Development.Debug.Adapter.Evaluation,
135+
Development.Debug.Adapter.ExceptionInfo,
135136
Development.Debug.Adapter.Init,
136137
Development.Debug.Adapter.Interface,
137138
Development.Debug.Adapter.Output,

‎haskell-debugger/GHC/Debugger.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ execute recorder = \case
3030
GetStacktrace i -> GotStacktrace <$> getStacktrace i
3131
GetScopes threadId frameIx -> GotScopes <$> getScopes threadId frameIx
3232
GetVariables threadId frameIx varRef -> GotVariables <$> getVariables threadId frameIx varRef
33+
GetExceptionInfo threadId -> GotExceptionInfo <$> getExceptionInfo threadId
3334
DoEval exp_s -> DidEval <$> doEval exp_s
3435
DoContinue -> DidContinue <$> doContinue
3536
DoSingleStep -> DidStep <$> doSingleStep
@@ -46,4 +47,3 @@ data DebuggerLog
4647
instance Pretty DebuggerLog where
4748
pretty = \ case
4849
EvalLog msg -> pretty msg
49-

‎haskell-debugger/GHC/Debugger/Interface/Messages.hs‎

Lines changed: 14 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ import GHC.Debugger.Runtime.Term.Key
2323
data Command
2424

2525
-- | Set a breakpoint on a given function, or module by line number
26-
= SetBreakpoint { brk :: Breakpoint
26+
= SetBreakpoint { brk :: Breakpoint
2727
, hitCount :: Maybe Int
2828
-- ^ Stop after N hits (if @isJust condition@, count down only when @eval condition == True@)
2929
, condition :: Maybe String
@@ -61,6 +61,9 @@ data Command
6161
-- | Evaluate an expression at the current breakpoint.
6262
| DoEval String
6363

64+
-- | Get information about the current exception (if any) on a thread.
65+
| GetExceptionInfo RemoteThreadId
66+
6467
-- | Continue executing from the current breakpoint
6568
| DoContinue
6669

@@ -196,6 +199,7 @@ data Response
196199
| GotStacktrace [DbgStackFrame]
197200
| GotScopes [ScopeInfo]
198201
| GotVariables (Either VarInfo [VarInfo])
202+
| GotExceptionInfo ExceptionInfo
199203
| Aborted String
200204
| Initialised
201205

@@ -268,10 +272,18 @@ data DbgStackFrame
268272
}
269273
deriving (Show)
270274

275+
data ExceptionInfo = ExceptionInfo
276+
{ exceptionInfoTypeName :: String
277+
, exceptionInfoFullTypeName :: String
278+
, exceptionInfoMessage :: String
279+
, exceptionInfoContext :: Maybe String
280+
, exceptionInfoInner :: [ExceptionInfo]
281+
}
282+
deriving (Show)
283+
271284
--------------------------------------------------------------------------------
272285
-- Instances
273286
--------------------------------------------------------------------------------
274287

275288
instance Show GHC.InternalBreakpointId where
276289
show (GHC.InternalBreakpointId m ix) = "InternalBreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix
277-

‎haskell-debugger/GHC/Debugger/Session/Builtin.hs‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -61,6 +61,10 @@ debuggerViewInstancesMods =
6161
, debuggerViewByteStringContents
6262
, "bytestring"
6363
)
64+
, ( debuggerViewExceptionModName
65+
, debuggerViewExceptionContents
66+
, "base"
67+
)
6468
]
6569

6670
-- | GHC.Debugger.View.Class
@@ -79,6 +83,10 @@ debuggerViewTextModName = mkModuleName "GHC.Debugger.View.Text"
7983
debuggerViewByteStringModName :: ModuleName
8084
debuggerViewByteStringModName = mkModuleName "GHC.Debugger.View.ByteString"
8185

86+
-- | GHC.Debugger.View.Exception
87+
debuggerViewExceptionModName :: ModuleName
88+
debuggerViewExceptionModName = mkModuleName "GHC.Debugger.View.Exception"
89+
8290
--------------------------------------------------------------------------------
8391
-- * In memory haskell-debugger-view
8492
--------------------------------------------------------------------------------
@@ -161,3 +169,6 @@ debuggerViewTextContents = stringToStringBuffer $(embedStringFile "haskell-debug
161169
debuggerViewByteStringContents :: StringBuffer
162170
debuggerViewByteStringContents = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs")
163171

172+
-- | GHC.Debugger.View.Exception
173+
debuggerViewExceptionContents :: StringBuffer
174+
debuggerViewExceptionContents = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/Exception.hs")

‎haskell-debugger/GHC/Debugger/Stopped.hs‎

Lines changed: 63 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -394,12 +394,12 @@ exceptionSourceSpanFromContext = do
394394
Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs)
395395
return Nothing
396396
Right Nothing -> return Nothing
397-
Right (Just (file, line, col)) ->
397+
Right (Just (file, srcLine, col)) ->
398398
return $ Just SourceSpan
399399
{ file = file
400-
, startLine = line
400+
, startLine = srcLine
401401
, startCol = col
402-
, endLine = line
402+
, endLine = srcLine
403403
, endCol = col
404404
}
405405
_ -> return Nothing
@@ -433,6 +433,50 @@ exceptionLocationExpr = unlines
433433
, " in go"
434434
]
435435

436+
getExceptionInfo :: RemoteThreadId -> Debugger ExceptionInfo
437+
getExceptionInfo req_tid = GHC.getResumeContext >>= \case
438+
[] -> return defaultExceptionInfo
439+
r:_ -> do
440+
r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r)
441+
case (r_tid == req_tid, GHC.resumeBreakpointId r) of
442+
(True, Nothing) -> do
443+
let excRef = resumeApStack r
444+
fromMaybe defaultExceptionInfo <$> exceptionInfoFromContext excRef
445+
_ -> return defaultExceptionInfo
446+
447+
exceptionInfoFromContext :: ForeignHValue -> Debugger (Maybe ExceptionInfo)
448+
exceptionInfoFromContext excRef = do
449+
evalRes <- Remote.eval
450+
(Remote.raw exceptionInfoExpr `Remote.app` Remote.untypedRef excRef)
451+
case evalRes of
452+
Left err -> do
453+
logSDoc Logger.Debug $
454+
Ppr.text "Failed to evaluate exception info:" Ppr.<+> Ppr.text (show err)
455+
return Nothing
456+
Right fhv -> do
457+
parsed <- obtainParsedTerm "Exception info" 4 True anyTy (castForeignRef fhv)
458+
exceptionInfoParser
459+
case parsed of
460+
Left errs -> do
461+
logSDoc Logger.Debug $
462+
Ppr.text "Failed to parse exception info:"
463+
Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs)
464+
return Nothing
465+
Right info -> return (Just info)
466+
467+
exceptionInfoParser :: TermParser ExceptionInfo
468+
exceptionInfoParser = do
469+
matchConstructorTerm "ExceptionInfoNode"
470+
ExceptionInfo
471+
<$> subtermWith 1 stringParser
472+
<*> subtermWith 0 stringParser
473+
<*> subtermWith 2 stringParser
474+
<*> subtermWith 3 (maybeParser stringParser)
475+
<*> subtermWith 4 (parseList exceptionInfoParser)
476+
477+
exceptionInfoExpr :: String
478+
exceptionInfoExpr = "GHC.Debugger.View.Exception.collectExceptionInfo"
479+
436480
fallbackExceptionSourceSpan :: Maybe SrcSpan -> SourceSpan
437481
fallbackExceptionSourceSpan mspan =
438482
let fileLabel = maybe "<exception>" spanLabel mspan
@@ -446,3 +490,19 @@ fallbackExceptionSourceSpan mspan =
446490
where
447491
spanLabel (RealSrcSpan rss _) = unpackFS (srcSpanFile rss)
448492
spanLabel (UnhelpfulSpan reason) = unpackFS (unhelpfulSpanFS reason)
493+
494+
defaultExceptionInfo :: ExceptionInfo
495+
defaultExceptionInfo = ExceptionInfo
496+
{ exceptionInfoTypeName = "Exception"
497+
, exceptionInfoFullTypeName = "Exception"
498+
, exceptionInfoMessage = "Exception information not available"
499+
, exceptionInfoContext = Nothing
500+
, exceptionInfoInner = []
501+
}
502+
503+
currentlyStoppedOnException :: Debugger Bool
504+
currentlyStoppedOnException = do
505+
resumes <- GHC.getResumeContext
506+
return $ case resumes of
507+
[] -> False
508+
r:_ -> resumeHistoryIx r == 0 && isNothing (GHC.resumeBreakpointId r)

‎hdb/Development/Debug/Adapter/ExceptionInfo.hs‎

Lines changed: 65 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,65 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
module Development.Debug.Adapter.ExceptionInfo
4+
( commandExceptionInfo
5+
) where
6+
7+
import qualified Data.Text as T
8+
9+
import DAP
10+
11+
import Development.Debug.Adapter
12+
import Development.Debug.Adapter.Interface
13+
import qualified GHC.Debugger.Interface.Messages as D
14+
15+
commandExceptionInfo :: DebugAdaptor ()
16+
commandExceptionInfo = do
17+
ExceptionInfoArguments{..} <- getArguments
18+
let remoteThread = D.RemoteThreadId exceptionInfoArgumentsThreadId
19+
D.GotExceptionInfo info <- sendSync (D.GetExceptionInfo remoteThread)
20+
sendExceptionInfoResponse (toDAPExceptionInfo info)
21+
22+
-- | Convert the debugger's 'ExceptionInfo' into a DAP 'ExceptionInfoResponse'.
23+
toDAPExceptionInfo :: D.ExceptionInfo -> ExceptionInfoResponse
24+
toDAPExceptionInfo info =
25+
let typeNameStr = exceptionTypeName info
26+
typeNameText = T.pack typeNameStr
27+
messageStr = exceptionMessage info
28+
messageText = T.pack <$> messageStr
29+
in ExceptionInfoResponse
30+
{ exceptionInfoResponseExceptionId = typeNameText
31+
, exceptionInfoResponseDescription = messageText
32+
, exceptionInfoResponseBreakMode = Always
33+
, exceptionInfoResponseDetails = Just (exceptionInfoToDetails (Just "_exception") info)
34+
}
35+
36+
exceptionInfoToDetails :: Maybe T.Text -> D.ExceptionInfo -> ExceptionDetails
37+
exceptionInfoToDetails evalName info@D.ExceptionInfo{..} =
38+
let typeNameText = T.pack (exceptionTypeName info)
39+
fullTypeNameText = T.pack (exceptionFullTypeName info)
40+
stackTraceText = T.pack <$> exceptionInfoContext
41+
innerDetails = map (exceptionInfoToDetails Nothing) exceptionInfoInner
42+
innerField = if null innerDetails then Nothing else Just innerDetails
43+
in defaultExceptionDetails
44+
{ exceptionDetailsMessage = exceptionMessage info
45+
, exceptionDetailstypeName = Just typeNameText
46+
, exceptionDetailsFullTypeName = Just fullTypeNameText
47+
, exceptionDetailsStackTrace = stackTraceText
48+
, exceptionDetailsInnerException = innerField
49+
, exceptionDetailsEvaluateName = evalName
50+
}
51+
52+
exceptionTypeName :: D.ExceptionInfo -> String
53+
exceptionTypeName D.ExceptionInfo{..}
54+
| null exceptionInfoTypeName = "Exception"
55+
| otherwise = exceptionInfoTypeName
56+
57+
exceptionFullTypeName :: D.ExceptionInfo -> String
58+
exceptionFullTypeName info@D.ExceptionInfo{..}
59+
| null exceptionInfoFullTypeName = exceptionTypeName info
60+
| otherwise = exceptionInfoFullTypeName
61+
62+
exceptionMessage :: D.ExceptionInfo -> Maybe String
63+
exceptionMessage D.ExceptionInfo{..}
64+
| null exceptionInfoMessage = Nothing
65+
| otherwise = Just exceptionInfoMessage

‎hdb/Development/Debug/Interactive.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -126,6 +126,7 @@ printResponse recd = \case
126126
GotStacktrace stackframes -> outputStrLn $ show stackframes
127127
GotScopes scopeinfos -> outputStrLn $ show scopeinfos
128128
GotVariables vis -> outputStrLn $ showVarInfoEither vis
129+
GotExceptionInfo exc_info -> outputStrLn $ show exc_info
129130
Aborted err_str -> outputStrLn ("Aborted: " ++ err_str)
130131
Initialised -> pure ()
131132

‎hdb/Main.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ import Development.Debug.Adapter.Breakpoints
1818
import Development.Debug.Adapter.Stepping
1919
import Development.Debug.Adapter.Stopped
2020
import Development.Debug.Adapter.Evaluation
21+
import Development.Debug.Adapter.ExceptionInfo
2122
import Development.Debug.Adapter.Exit
2223
import Development.Debug.Adapter.Handles
2324
import GHC.Debugger.Logger
@@ -115,7 +116,7 @@ getConfig port = do
115116
, supportsRestartRequest = False
116117
, supportsExceptionOptions = True
117118
, supportsValueFormattingOptions = True
118-
, supportsExceptionInfoRequest = False
119+
, supportsExceptionInfoRequest = True
119120
, supportTerminateDebuggee = True
120121
, supportSuspendDebuggee = False
121122
, supportsDelayedStackTraceLoading = False
@@ -220,6 +221,7 @@ talk l support_rit_var _pid_var client_proxy_signal = \ case
220221
CommandSetBreakpoints -> commandSetBreakpoints
221222
CommandSetFunctionBreakpoints -> commandSetFunctionBreakpoints
222223
CommandSetExceptionBreakpoints -> commandSetExceptionBreakpoints
224+
CommandExceptionInfo -> commandExceptionInfo
223225
CommandSetDataBreakpoints -> undefined
224226
CommandSetInstructionBreakpoints -> undefined
225227
----------------------------------------------------------------------------
@@ -276,4 +278,3 @@ ack l _ref rrr = case rrr.reverseRequestCommand of
276278
when rrr.success $ do
277279
logWith l Info $ LaunchLog $ T.pack "RunInTerminal was successful"
278280
_ -> pure ()
279-

0 commit comments

Comments
 (0)