From bfc9154497dca245989fe696f4a05c6e2c046b86 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Wed, 14 Jan 2026 15:26:30 +0000 Subject: [PATCH 1/5] Update dap dependency --- haskell-debugger.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index 311069c7..319f0891 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -170,7 +170,7 @@ executable hdb network-run >= 0.4.4, async >= 2.2.5 && < 2.3, text >= 2.1 && < 2.3, - dap >= 0.3.1 && < 0.4, + dap >= 0.4 && < 0.5, haskeline >= 0.8 && < 1, optparse-applicative >= 0.18 && < 0.20 From c453810722aff365297206eba456434192afbb11 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Mon, 12 Jan 2026 13:47:58 +0000 Subject: [PATCH 2/5] Create a dummy stack frame and location for exceptions We query the HasCallStack backtrace from an exception and if it's present, use that to show a location to the user. --- haskell-debugger/GHC/Debugger/Stopped.hs | 150 ++++++++++++++++++----- 1 file changed, 119 insertions(+), 31 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Stopped.hs b/haskell-debugger/GHC/Debugger/Stopped.hs index 8d0ccf30..e8fa4733 100644 --- a/haskell-debugger/GHC/Debugger/Stopped.hs +++ b/haskell-debugger/GHC/Debugger/Stopped.hs @@ -21,6 +21,7 @@ import GHC.Driver.Env as GHC import GHC.Runtime.Eval import GHC.Types.SrcLoc import GHC.InfoProv +import GHC.Data.FastString (unpackFS) import GHC.Utils.Outputable as Ppr import qualified GHC.Unit.Home.Graph as HUG @@ -34,6 +35,10 @@ import GHC.Debugger.Interface.Messages import qualified GHC.Debugger.Interface.Messages as DbgStackFrame (DbgStackFrame(..)) import GHC.Debugger.Utils import qualified GHC.Debugger.Logger as Logger +import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote +import GHC.Debugger.Runtime.Term.Parser +import GHCi.RemoteTypes (castForeignRef) +import GHC.Builtin.Types (anyTy) {- Note [Don't crash if not stopped] @@ -154,31 +159,36 @@ getStacktrace req_tid = do [] -> -- See Note [Don't crash if not stopped] return Nothing - r:_ - | Just ss <- realSrcSpanToSourceSpan <$> srcSpanToRealSrcSpan (GHC.resumeSpan r) - , Just ss /= (fmap DbgStackFrame.sourceSpan (listToMaybe decoded_frames)) - -- don't include the resume context entry if it is already at the - -- start of the decoded frames - , Just ibi <- GHC.resumeBreakpointId r - -> do - r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r) - if r_tid == req_tid then do - -- We're getting the stacktrace for the thread we're stopped at. - info_brks <- liftIO $ readIModBreaks hug ibi - let modl = getBreakSourceMod ibi info_brks - modl_str <- display modl - return $ - Just DbgStackFrame - { name = modl_str ++ "." ++ GHC.resumeDecl r - , sourceSpan = ss - , breakId = Just ibi - } - else - return Nothing - | otherwise -> - -- No resume span; which should mean we're stopped on an exception. - -- No info for now. - return Nothing + r:_ -> do + let resumeSpanR = GHC.resumeSpan r + mRealSpan = realSrcSpanToSourceSpan <$> srcSpanToRealSrcSpan resumeSpanR + firstSpan = DbgStackFrame.sourceSpan <$> listToMaybe decoded_frames + r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r) + if r_tid /= req_tid then + return Nothing + else case GHC.resumeBreakpointId r of + Just ibi + | Just ss <- mRealSpan + , Just ss /= firstSpan -> do + -- We're getting the stacktrace for the thread we're stopped at. + info_brks <- liftIO $ readIModBreaks hug ibi + let modl = getBreakSourceMod ibi info_brks + modl_str <- display modl + return $ + Just DbgStackFrame + { name = modl_str ++ "." ++ GHC.resumeDecl r + , sourceSpan = ss + , breakId = Just ibi + } + _ -> do + mExcSpan <- exceptionSourceSpanFromContext + case mExcSpan of + Just sourceSpan -> return $ Just DbgStackFrame + { name = GHC.resumeDecl r + , sourceSpan + , breakId = Nothing + } + Nothing -> return Nothing return (maybe id (:) head_frame $ decoded_frames) -------------------------------------------------------------------------------- @@ -191,6 +201,12 @@ getScopes threadId frameIx = do frames <- getStacktrace threadId let frame = frames !! frameIx let sourceSpan = DbgStackFrame.sourceSpan frame + localsScope = ScopeInfo + { kind = LocalVariablesScope + , expensive = False + , numVars = Nothing + , sourceSpan + } if | frameIx < length frames , Just ibi <- DbgStackFrame.breakId frame @@ -204,11 +220,7 @@ getScopes threadId frameIx = do in_mod <- getTopEnv brk_modl imported <- getTopImported brk_modl return - [ ScopeInfo { kind = LocalVariablesScope - , expensive = False - , numVars = Nothing - , sourceSpan - } + [ localsScope , ScopeInfo { kind = ModuleVariablesScope , expensive = True , numVars = Just (sizeUFM in_mod) @@ -221,7 +233,7 @@ getScopes threadId frameIx = do } ] | otherwise -> - return [] + return [localsScope] -------------------------------------------------------------------------------- -- * Variables @@ -354,3 +366,79 @@ getTopImported modl = do liftIO $ HUG.lookupHugByModule modl (hsc_HUG hsc_env) >>= \case Nothing -> return emptyGlobalRdrEnv Just hmi -> mkTopLevImportedEnv hsc_env hmi + +-------------------------------------------------------------------------------- +-- * Exception context helpers +-------------------------------------------------------------------------------- + +exceptionSourceSpanFromContext :: Debugger (Maybe SourceSpan) +exceptionSourceSpanFromContext = do + GHC.getResumeContext >>= \case + r:_ | resumeHistoryIx r == 0 + , Nothing <- GHC.resumeBreakpointId r -> do + let excRef = resumeApStack r + evalRes <- Remote.eval + (Remote.raw exceptionLocationExpr `Remote.app` Remote.untypedRef excRef) + case evalRes of + Left err -> do + logSDoc Logger.Debug $ + Ppr.text "Failed to evaluate exception context:" Ppr.<+> Ppr.text (show err) + return Nothing + Right fhv -> do + parsed <- obtainParsedTerm "Exception context location" 4 True anyTy (castForeignRef fhv) + (maybeParser exceptionLocationTupleParser) + case parsed of + Left errs -> do + logSDoc Logger.Debug $ + Ppr.text "Failed to parse exception context location:" + Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs) + return Nothing + Right Nothing -> return Nothing + Right (Just (file, line, col)) -> + return $ Just SourceSpan + { file = file + , startLine = line + , startCol = col + , endLine = line + , endCol = col + } + _ -> return Nothing + +exceptionLocationTupleParser :: TermParser (String, Int, Int) +exceptionLocationTupleParser = + (,,) <$> subtermWith 0 stringParser + <*> subtermWith 1 intParser + <*> subtermWith 2 intParser + +exceptionLocationExpr :: String +exceptionLocationExpr = unlines + [ "let" + , " fromCallStack cs = case GHC.Internal.Data.Maybe.listToMaybe (GHC.Internal.Stack.getCallStack cs) of" + , " Just (_, loc) -> Just ( GHC.Internal.Stack.Types.srcLocFile loc" + , " , GHC.Internal.Stack.Types.srcLocStartLine loc" + , " , GHC.Internal.Stack.Types.srcLocStartCol loc)" + , " go exc =" + , " let ctx = GHC.Internal.Exception.Type.someExceptionContext exc" + , " bts :: [GHC.Internal.Exception.Backtrace.Backtraces]" + , " bts = Control.Exception.Context.getExceptionAnnotations ctx" + , " in case bts of" + , " bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of" + , " Just cs -> fromCallStack cs" + , " Nothing -> Nothing" + , " [] -> Nothing" + , " in go" + ] + +fallbackExceptionSourceSpan :: Maybe SrcSpan -> SourceSpan +fallbackExceptionSourceSpan mspan = + let fileLabel = maybe "" spanLabel mspan + in SourceSpan + { file = fileLabel + , startLine = 0 + , startCol = 0 + , endLine = 0 + , endCol = 0 + } + where + spanLabel (RealSrcSpan rss _) = unpackFS (srcSpanFile rss) + spanLabel (UnhelpfulSpan reason) = unpackFS (unhelpfulSpanFS reason) From 0156caad896abb51c749a0d658a8197e114ad2c6 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Mon, 12 Jan 2026 17:19:40 +0000 Subject: [PATCH 3/5] Add DebugView SomeException --- haskell-debugger-view/src/GHC/Debugger/View/Class.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs index 55b4ef6b..3d50794c 100644 --- a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs +++ b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs @@ -51,6 +51,7 @@ module GHC.Debugger.View.Class import Data.Int import Data.Word +import Control.Exception -- | Custom handling of debug terms (e.g. in the variables pane, or when -- inspecting a lazy variable) @@ -180,6 +181,15 @@ instance DebugView (a, b) where [ ("fst", VarFieldValue x) , ("snd", VarFieldValue y) ] +instance DebugView SomeException where + debugValue e = simpleValue (displayException e) True + debugFields e@(SomeException exc) = + let !ctx = someExceptionContext e + in pure $ VarFields + [ ("exception", VarFieldValue exc) + , ("context", VarFieldValue ctx) + ] + -- | This instance will display up to the first 50 forced elements of a list. instance {-# OVERLAPPABLE #-} DebugView [a] where debugValue [] = simpleValue "[]" False @@ -219,4 +229,3 @@ toVarFieldsIO :: VarFields -> [(IO String, VarFieldValue)] toVarFieldsIO x = case x of VarFields fls -> [ (pure fl_s, b) | (fl_s, b) <- fls] - From 160fbf9363993e150063eb0331bd16019413e450 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Wed, 14 Jan 2026 11:40:41 +0000 Subject: [PATCH 4/5] Implement ExceptionInfo request The ExceptionInfo request is used by debuggers in order to display information about the exception we are stopped at. --- haskell-debugger.cabal | 1 + haskell-debugger/GHC/Debugger.hs | 2 +- .../GHC/Debugger/Interface/Messages.hs | 16 ++- .../GHC/Debugger/Session/Builtin.hs | 1 - haskell-debugger/GHC/Debugger/Stopped.hs | 117 ++++++++++++++++-- .../Debug/Adapter/ExceptionInfo.hs | 65 ++++++++++ hdb/Development/Debug/Interactive.hs | 57 ++++++++- hdb/Main.hs | 5 +- test/golden/T79/T79.hdb-test | 5 +- .../exceptions-multiple.hdb-stdin | 4 + .../exceptions-multiple.hdb-stdout | 25 ++++ .../exceptions-multiple.hdb-test | 3 + test/golden/exceptions-multiple/prog/Main.hs | 13 ++ .../exceptions-uncaught.hdb-stdin | 3 + .../exceptions-uncaught.hdb-stdout | 24 ++++ .../exceptions-uncaught.hdb-test | 3 + test/golden/exceptions-uncaught/prog/Main.hs | 14 +++ test/golden/exceptions/exceptions.hdb-stdin | 3 + test/golden/exceptions/exceptions.hdb-stdout | 14 +++ test/golden/exceptions/exceptions.hdb-test | 3 + test/golden/exceptions/prog/Main.hs | 6 + .../integration-tests/data/exceptions/Main.hs | 17 +++ test/integration-tests/test/adapter.test.ts | 76 ++++++++++++ 23 files changed, 455 insertions(+), 22 deletions(-) create mode 100644 hdb/Development/Debug/Adapter/ExceptionInfo.hs create mode 100644 test/golden/exceptions-multiple/exceptions-multiple.hdb-stdin create mode 100644 test/golden/exceptions-multiple/exceptions-multiple.hdb-stdout create mode 100755 test/golden/exceptions-multiple/exceptions-multiple.hdb-test create mode 100644 test/golden/exceptions-multiple/prog/Main.hs create mode 100644 test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdin create mode 100644 test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdout create mode 100755 test/golden/exceptions-uncaught/exceptions-uncaught.hdb-test create mode 100644 test/golden/exceptions-uncaught/prog/Main.hs create mode 100644 test/golden/exceptions/exceptions.hdb-stdin create mode 100644 test/golden/exceptions/exceptions.hdb-stdout create mode 100644 test/golden/exceptions/exceptions.hdb-test create mode 100644 test/golden/exceptions/prog/Main.hs create mode 100644 test/integration-tests/data/exceptions/Main.hs diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index 319f0891..8fa4afdb 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -132,6 +132,7 @@ executable hdb Development.Debug.Adapter.Stepping, Development.Debug.Adapter.Stopped, Development.Debug.Adapter.Evaluation, + Development.Debug.Adapter.ExceptionInfo, Development.Debug.Adapter.Init, Development.Debug.Adapter.Interface, Development.Debug.Adapter.Output, diff --git a/haskell-debugger/GHC/Debugger.hs b/haskell-debugger/GHC/Debugger.hs index 14daf849..57fe28dc 100644 --- a/haskell-debugger/GHC/Debugger.hs +++ b/haskell-debugger/GHC/Debugger.hs @@ -30,6 +30,7 @@ execute recorder = \case GetStacktrace i -> GotStacktrace <$> getStacktrace i GetScopes threadId frameIx -> GotScopes <$> getScopes threadId frameIx GetVariables threadId frameIx varRef -> GotVariables <$> getVariables threadId frameIx varRef + GetExceptionInfo threadId -> GotExceptionInfo <$> getExceptionInfo threadId DoEval exp_s -> DidEval <$> doEval exp_s DoContinue -> DidContinue <$> doContinue DoSingleStep -> DidStep <$> doSingleStep @@ -46,4 +47,3 @@ data DebuggerLog instance Pretty DebuggerLog where pretty = \ case EvalLog msg -> pretty msg - diff --git a/haskell-debugger/GHC/Debugger/Interface/Messages.hs b/haskell-debugger/GHC/Debugger/Interface/Messages.hs index 0b5ade99..5051fa96 100644 --- a/haskell-debugger/GHC/Debugger/Interface/Messages.hs +++ b/haskell-debugger/GHC/Debugger/Interface/Messages.hs @@ -23,7 +23,7 @@ import GHC.Debugger.Runtime.Term.Key data Command -- | Set a breakpoint on a given function, or module by line number - = SetBreakpoint { brk :: Breakpoint + = SetBreakpoint { brk :: Breakpoint , hitCount :: Maybe Int -- ^ Stop after N hits (if @isJust condition@, count down only when @eval condition == True@) , condition :: Maybe String @@ -61,6 +61,9 @@ data Command -- | Evaluate an expression at the current breakpoint. | DoEval String + -- | Get information about the current exception (if any) on a thread. + | GetExceptionInfo RemoteThreadId + -- | Continue executing from the current breakpoint | DoContinue @@ -196,6 +199,7 @@ data Response | GotStacktrace [DbgStackFrame] | GotScopes [ScopeInfo] | GotVariables (Either VarInfo [VarInfo]) + | GotExceptionInfo ExceptionInfo | Aborted String | Initialised @@ -268,10 +272,18 @@ data DbgStackFrame } deriving (Show) +data ExceptionInfo = ExceptionInfo + { exceptionInfoTypeName :: String + , exceptionInfoFullTypeName :: String + , exceptionInfoMessage :: String + , exceptionInfoContext :: Maybe String + , exceptionInfoInner :: [ExceptionInfo] + } + deriving (Show) + -------------------------------------------------------------------------------- -- Instances -------------------------------------------------------------------------------- instance Show GHC.InternalBreakpointId where show (GHC.InternalBreakpointId m ix) = "InternalBreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix - diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs index a306b108..3191fe17 100644 --- a/haskell-debugger/GHC/Debugger/Session/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -160,4 +160,3 @@ debuggerViewTextContents = stringToStringBuffer $(embedStringFile "haskell-debug -- | GHC.Debugger.View.ByteString debuggerViewByteStringContents :: StringBuffer debuggerViewByteStringContents = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs") - diff --git a/haskell-debugger/GHC/Debugger/Stopped.hs b/haskell-debugger/GHC/Debugger/Stopped.hs index e8fa4733..198ed6e7 100644 --- a/haskell-debugger/GHC/Debugger/Stopped.hs +++ b/haskell-debugger/GHC/Debugger/Stopped.hs @@ -374,8 +374,7 @@ getTopImported modl = do exceptionSourceSpanFromContext :: Debugger (Maybe SourceSpan) exceptionSourceSpanFromContext = do GHC.getResumeContext >>= \case - r:_ | resumeHistoryIx r == 0 - , Nothing <- GHC.resumeBreakpointId r -> do + r:_ | Nothing <- GHC.resumeBreakpointId r -> do let excRef = resumeApStack r evalRes <- Remote.eval (Remote.raw exceptionLocationExpr `Remote.app` Remote.untypedRef excRef) @@ -394,12 +393,12 @@ exceptionSourceSpanFromContext = do Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs) return Nothing Right Nothing -> return Nothing - Right (Just (file, line, col)) -> + Right (Just (file, srcLine, col)) -> return $ Just SourceSpan { file = file - , startLine = line + , startLine = srcLine , startCol = col - , endLine = line + , endLine = srcLine , endCol = col } _ -> return Nothing @@ -413,13 +412,13 @@ exceptionLocationTupleParser = exceptionLocationExpr :: String exceptionLocationExpr = unlines [ "let" - , " fromCallStack cs = case GHC.Internal.Data.Maybe.listToMaybe (GHC.Internal.Stack.getCallStack cs) of" - , " Just (_, loc) -> Just ( GHC.Internal.Stack.Types.srcLocFile loc" - , " , GHC.Internal.Stack.Types.srcLocStartLine loc" - , " , GHC.Internal.Stack.Types.srcLocStartCol loc)" + , " fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of" + , " Just (_, loc) -> Just ( GHC.Exception.srcLocFile loc" + , " , GHC.Exception.srcLocStartLine loc" + , " , GHC.Exception.srcLocStartCol loc)" , " go exc =" - , " let ctx = GHC.Internal.Exception.Type.someExceptionContext exc" - , " bts :: [GHC.Internal.Exception.Backtrace.Backtraces]" + , " let ctx = Control.Exception.someExceptionContext exc" + , " bts :: [Control.Exception.Backtrace.Backtraces]" , " bts = Control.Exception.Context.getExceptionAnnotations ctx" , " in case bts of" , " bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of" @@ -429,6 +428,85 @@ exceptionLocationExpr = unlines , " in go" ] +getExceptionInfo :: RemoteThreadId -> Debugger ExceptionInfo +getExceptionInfo req_tid = GHC.getResumeContext >>= \case + [] -> return defaultExceptionInfo + r:_ -> do + r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r) + case (r_tid == req_tid, GHC.resumeBreakpointId r) of + (True, Nothing) -> do + let excRef = resumeApStack r + fromMaybe defaultExceptionInfo <$> exceptionInfoFromContext excRef + _ -> return defaultExceptionInfo + +exceptionInfoFromContext :: ForeignHValue -> Debugger (Maybe ExceptionInfo) +exceptionInfoFromContext excRef = do + -- 1. Compile the datatype definition we need + _ <- runDecls exceptionInfoData + -- 2. Gather the exception information. + evalRes <- Remote.eval + (Remote.raw exceptionInfoExpr `Remote.app` Remote.untypedRef excRef) + case evalRes of + Left err -> do + logSDoc Logger.Debug $ + Ppr.text "Failed to evaluate exception info:" Ppr.<+> Ppr.text (show err) + return Nothing + Right fhv -> do + parsed <- obtainParsedTerm "Exception info" 4 True anyTy (castForeignRef fhv) + exceptionInfoParser + case parsed of + Left errs -> do + logSDoc Logger.Debug $ + Ppr.text "Failed to parse exception info:" + Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs) + return Nothing + Right info -> return (Just info) + +exceptionInfoParser :: TermParser ExceptionInfo +exceptionInfoParser = do + ExceptionInfo + <$> subtermWith 0 stringParser + <*> subtermWith 1 stringParser + <*> subtermWith 2 stringParser + <*> subtermWith 3 (maybeParser stringParser) + <*> subtermWith 4 (parseList exceptionInfoParser) + +-- Need to use a specific datatype since ExceptionInfoNode is recursive +exceptionInfoData :: String +exceptionInfoData = "data ExceptionInfoNode = ExceptionInfoNode String String String (Maybe String) [ExceptionInfoNode]" + +exceptionInfoExpr :: String +exceptionInfoExpr = + unlines + [ "\\se ->" + , " let collectExceptionInfo :: SomeException -> ExceptionInfoNode" + , " collectExceptionInfo se' =" + , " case se' of" + , " SomeException exc ->" + , " let ctx = Control.Exception.someExceptionContext se'" + , " rendered = Control.Exception.Context.displayExceptionContext ctx" + , " whileHandling = Control.Exception.Context.getExceptionAnnotations ctx" + , " innerNodes = map (collectExceptionInfo . unwrap) whileHandling" + , " simpleTypeName = Data.Typeable.tyConName tc" + , " modulePrefix = case Data.Typeable.tyConModule tc of" + , " mdl | null mdl -> \"\"" + , " | otherwise -> mdl ++ \".\"" + , " packagePrefix = case Data.Typeable.tyConPackage tc of" + , " pkg | null pkg -> \"\"" + , " | otherwise -> pkg ++ \":\"" + , " tc = Data.Typeable.typeRepTyCon (Data.Typeable.typeOf exc)" + , " fullTypeName = packagePrefix ++ modulePrefix ++ simpleTypeName" + , " unwrap (Control.Exception.WhileHandling inner) = inner" + , " contextText = if null rendered then Nothing else Just rendered" + , " in ExceptionInfoNode" + , " simpleTypeName" + , " fullTypeName" + , " (Control.Exception.displayException se')" + , " contextText" + , " innerNodes" + , " in collectExceptionInfo se" + ] + fallbackExceptionSourceSpan :: Maybe SrcSpan -> SourceSpan fallbackExceptionSourceSpan mspan = let fileLabel = maybe "" spanLabel mspan @@ -442,3 +520,20 @@ fallbackExceptionSourceSpan mspan = where spanLabel (RealSrcSpan rss _) = unpackFS (srcSpanFile rss) spanLabel (UnhelpfulSpan reason) = unpackFS (unhelpfulSpanFS reason) + +defaultExceptionInfo :: ExceptionInfo +defaultExceptionInfo = ExceptionInfo + { exceptionInfoTypeName = "Exception" + , exceptionInfoFullTypeName = "Exception" + , exceptionInfoMessage = "Exception information not available" + , exceptionInfoContext = Nothing + , exceptionInfoInner = [] + } + +currentlyStoppedOnException :: Debugger Bool +currentlyStoppedOnException = do + resumes <- GHC.getResumeContext + return $ case resumes of + [] -> False + r:_ -> isNothing (GHC.resumeBreakpointId r) + diff --git a/hdb/Development/Debug/Adapter/ExceptionInfo.hs b/hdb/Development/Debug/Adapter/ExceptionInfo.hs new file mode 100644 index 00000000..713a1f4e --- /dev/null +++ b/hdb/Development/Debug/Adapter/ExceptionInfo.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Development.Debug.Adapter.ExceptionInfo + ( commandExceptionInfo + ) where + +import qualified Data.Text as T + +import DAP + +import Development.Debug.Adapter +import Development.Debug.Adapter.Interface +import qualified GHC.Debugger.Interface.Messages as D + +commandExceptionInfo :: DebugAdaptor () +commandExceptionInfo = do + ExceptionInfoArguments{..} <- getArguments + let remoteThread = D.RemoteThreadId exceptionInfoArgumentsThreadId + D.GotExceptionInfo info <- sendSync (D.GetExceptionInfo remoteThread) + sendExceptionInfoResponse (toDAPExceptionInfo info) + +-- | Convert the debugger's 'ExceptionInfo' into a DAP 'ExceptionInfoResponse'. +toDAPExceptionInfo :: D.ExceptionInfo -> ExceptionInfoResponse +toDAPExceptionInfo info = + let typeNameStr = exceptionTypeName info + typeNameText = T.pack typeNameStr + messageStr = exceptionMessage info + messageText = T.pack <$> messageStr + in ExceptionInfoResponse + { exceptionInfoResponseExceptionId = typeNameText + , exceptionInfoResponseDescription = messageText + , exceptionInfoResponseBreakMode = Always + , exceptionInfoResponseDetails = Just (exceptionInfoToDetails (Just "_exception") info) + } + +exceptionInfoToDetails :: Maybe T.Text -> D.ExceptionInfo -> ExceptionDetails +exceptionInfoToDetails evalName info@D.ExceptionInfo{..} = + let typeNameText = T.pack (exceptionTypeName info) + fullTypeNameText = T.pack (exceptionFullTypeName info) + stackTraceText = T.pack <$> exceptionInfoContext + innerDetails = map (exceptionInfoToDetails Nothing) exceptionInfoInner + innerField = if null innerDetails then Nothing else Just innerDetails + in defaultExceptionDetails + { exceptionDetailsMessage = exceptionMessage info + , exceptionDetailstypeName = Just typeNameText + , exceptionDetailsFullTypeName = Just fullTypeNameText + , exceptionDetailsStackTrace = stackTraceText + , exceptionDetailsInnerException = innerField + , exceptionDetailsEvaluateName = evalName + } + +exceptionTypeName :: D.ExceptionInfo -> String +exceptionTypeName D.ExceptionInfo{..} + | null exceptionInfoTypeName = "Exception" + | otherwise = exceptionInfoTypeName + +exceptionFullTypeName :: D.ExceptionInfo -> String +exceptionFullTypeName info@D.ExceptionInfo{..} + | null exceptionInfoFullTypeName = exceptionTypeName info + | otherwise = exceptionInfoFullTypeName + +exceptionMessage :: D.ExceptionInfo -> Maybe String +exceptionMessage D.ExceptionInfo{..} + | null exceptionInfoMessage = Nothing + | otherwise = Just exceptionInfoMessage diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs index 957745f5..3fada44b 100644 --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, ViewPatterns, RecordWildCards #-} +{-# LANGUAGE LambdaCase, ViewPatterns, RecordWildCards, OverloadedRecordDot #-} module Development.Debug.Interactive where import System.IO @@ -20,6 +20,8 @@ import GHC.Debugger.Logger import GHC.Debugger.Interface.Messages import GHC.Debugger.Monad import GHC.Debugger +import Control.Monad +import Data.List (intercalate) -- | Interactive debugging monad type InteractiveDM a = InputT (RWST (FilePath{-entry file-},String{-entry point-}, [String]{-run args-}) () @@ -108,31 +110,55 @@ debugInteractive recorder = withInterrupt loop printResponse debugRec out loop +showExceptionDetails :: Recorder (WithSeverity DebuggerLog) -> RemoteThreadId -> InteractiveDM () +showExceptionDetails recd tid = do + infoResp <- lift . lift $ execute recd (GetExceptionInfo tid) + case infoResp of + GotExceptionInfo exc_info -> outputStrLn $ renderExceptionInfo exc_info + _ -> pure () + stackResp <- lift . lift $ execute recd (GetStacktrace tid) + case stackResp of + GotStacktrace (frame:_) -> + outputStrLn $ + "Exception location: " ++ renderSourceSpan (frame.sourceSpan) + _ -> outputStrLn "Exception location: " + -------------------------------------------------------------------------------- -- Printing -------------------------------------------------------------------------------- printResponse :: Recorder (WithSeverity DebuggerLog) -> Response -> InteractiveDM () printResponse recd = \case - DidEval er -> outputStrLn $ showEvalResult er + DidEval er -> outputEvalResult recd er DidSetBreakpoint bf -> outputStrLn $ show bf DidRemoveBreakpoint bf -> outputStrLn $ show bf DidGetBreakpoints mb_span -> outputStrLn $ show mb_span DidClearBreakpoints -> outputStrLn "Cleared all breakpoints." - DidContinue er -> outputStrLn $ showEvalResult er + DidContinue er -> outputEvalResult recd er DidStep er -> printEvalResult recd er - DidExec er -> outputStrLn $ showEvalResult er + DidExec er -> outputEvalResult recd er GotThreads threads -> outputStrLn $ show threads GotStacktrace stackframes -> outputStrLn $ show stackframes GotScopes scopeinfos -> outputStrLn $ show scopeinfos GotVariables vis -> outputStrLn $ showVarInfoEither vis + GotExceptionInfo exc_info -> outputStrLn $ renderExceptionInfo exc_info Aborted err_str -> outputStrLn ("Aborted: " ++ err_str) Initialised -> pure () + where + outputEvalResult recd' er = do + outputStrLn (showEvalResult er) + maybeShowException recd' er + + maybeShowException recd' EvalStopped{breakId = Nothing, breakThread=tid} = + showExceptionDetails recd' tid + maybeShowException _ _ = pure () printEvalResult :: Recorder (WithSeverity DebuggerLog) -> EvalResult -> InteractiveDM () printEvalResult recd EvalStopped{..} = do out <- lift . lift $ execute recd (GetScopes breakThread 0) printResponse recd out + when (breakId == Nothing) $ + showExceptionDetails recd breakThread printEvalResult _ er = outputStrLn $ showEvalResult er showEvalResult :: EvalResult -> String @@ -148,6 +174,29 @@ showVarInfoEither (Right vis) = unlines $ map showVarInfo vis showVarInfo :: VarInfo -> String showVarInfo VarInfo{..} = unwords [varName, ":", varType, "=", varValue] +renderSourceSpan :: SourceSpan -> String +renderSourceSpan SourceSpan{..} = + file ++ ":" ++ show startLine ++ ":" ++ show startCol + +renderExceptionInfo :: ExceptionInfo -> String +renderExceptionInfo = unlines . go 0 + where + go depth exInfo = + let indent = replicate (depth * 2) ' ' + typeLine = indent ++ "Exception: " ++ exceptionInfoTypeName exInfo + messageLine = indent ++ "Message: " ++ exceptionInfoMessage exInfo + ctxLine = case exceptionInfoContext exInfo of + Nothing -> indent ++ "Call stack: " + Just ctx -> indent ++ "Call stack:\n" ++ indentMultiline (depth + 1) ctx + innerLines = case exceptionInfoInner exInfo of + [] -> [] + xs -> (indent ++ "Inner exceptions:") : concatMap (go (depth + 1)) xs + in typeLine : messageLine : ctxLine : innerLines + + indentMultiline depth txt = + let pref = replicate (depth * 2) ' ' + in intercalate "\n" (map (pref ++) (lines txt)) + -------------------------------------------------------------------------------- -- Command parser -------------------------------------------------------------------------------- diff --git a/hdb/Main.hs b/hdb/Main.hs index 28ed91ed..9a4fdced 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -18,6 +18,7 @@ import Development.Debug.Adapter.Breakpoints import Development.Debug.Adapter.Stepping import Development.Debug.Adapter.Stopped import Development.Debug.Adapter.Evaluation +import Development.Debug.Adapter.ExceptionInfo import Development.Debug.Adapter.Exit import Development.Debug.Adapter.Handles import GHC.Debugger.Logger @@ -115,7 +116,7 @@ getConfig port = do , supportsRestartRequest = False , supportsExceptionOptions = True , supportsValueFormattingOptions = True - , supportsExceptionInfoRequest = False + , supportsExceptionInfoRequest = True , supportTerminateDebuggee = True , supportSuspendDebuggee = False , supportsDelayedStackTraceLoading = False @@ -220,6 +221,7 @@ talk l support_rit_var _pid_var client_proxy_signal = \ case CommandSetBreakpoints -> commandSetBreakpoints CommandSetFunctionBreakpoints -> commandSetFunctionBreakpoints CommandSetExceptionBreakpoints -> commandSetExceptionBreakpoints + CommandExceptionInfo -> commandExceptionInfo CommandSetDataBreakpoints -> undefined CommandSetInstructionBreakpoints -> undefined ---------------------------------------------------------------------------- @@ -276,4 +278,3 @@ ack l _ref rrr = case rrr.reverseRequestCommand of when rrr.success $ do logWith l Info $ LaunchLog $ T.pack "RunInTerminal was successful" _ -> pure () - diff --git a/test/golden/T79/T79.hdb-test b/test/golden/T79/T79.hdb-test index 09f28a77..be6dd03d 100644 --- a/test/golden/T79/T79.hdb-test +++ b/test/golden/T79/T79.hdb-test @@ -1 +1,4 @@ -cd $(mktemp -d) && cabal init -m -n -d base -p T79-tmp && (echo "run\nexit" | hdb app/Main.hs) +cd $(mktemp -d) && cabal init -m -n -d base -p T79-tmp && hdb app/Main.hs <<'EOF' +run +exit +EOF diff --git a/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdin b/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdin new file mode 100644 index 00000000..69c48fd8 --- /dev/null +++ b/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdin @@ -0,0 +1,4 @@ +break --exceptions +run +continue +exit diff --git a/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdout b/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdout new file mode 100644 index 00000000..c9867c78 --- /dev/null +++ b/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdout @@ -0,0 +1,25 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] +(hdb) BreakFoundNoLoc {changed = True} +(hdb) About to throw first +Stopped at breakpoint +Exception: ErrorCall +Message: boom first +Call stack: + IPE backtrace: + HasCallStack backtrace: + error, called at /prog/Main.hs:8:10 in main:Main + +Exception location: /prog/Main.hs:8:10 +(hdb) Handled first exception: boom first +Continuing after first exception +Stopped at breakpoint +Exception: ErrorCall +Message: boom second +Call stack: + IPE backtrace: + HasCallStack backtrace: + error, called at /prog/Main.hs:10:3 in main:Main + +Exception location: /prog/Main.hs:10:3 +(hdb) \ No newline at end of file diff --git a/test/golden/exceptions-multiple/exceptions-multiple.hdb-test b/test/golden/exceptions-multiple/exceptions-multiple.hdb-test new file mode 100755 index 00000000..be5a4382 --- /dev/null +++ b/test/golden/exceptions-multiple/exceptions-multiple.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +hdb cli prog/Main.hs < exceptions-multiple.hdb-stdin diff --git a/test/golden/exceptions-multiple/prog/Main.hs b/test/golden/exceptions-multiple/prog/Main.hs new file mode 100644 index 00000000..76c1b42c --- /dev/null +++ b/test/golden/exceptions-multiple/prog/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Control.Exception + +main :: IO () +main = do + putStrLn "About to throw first" + catch (error "boom first") handler + putStrLn "Continuing after first exception" + error "boom second" + +handler :: SomeException -> IO () +handler se = putStrLn ("Handled first exception: " ++ displayException se) diff --git a/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdin b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdin new file mode 100644 index 00000000..9237cc27 --- /dev/null +++ b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdin @@ -0,0 +1,3 @@ +break --error +run +exit diff --git a/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdout b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdout new file mode 100644 index 00000000..3a701892 --- /dev/null +++ b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdout @@ -0,0 +1,24 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] +(hdb) BreakFoundNoLoc {changed = True} +(hdb) About to throw +Handling exception: boom outer +Stopped at breakpoint +Exception: ErrorCall +Message: boom while handling +Call stack: + While handling boom outer + + IPE backtrace: + HasCallStack backtrace: + error, called at /prog/Main.hs:14:3 in main:Main +Inner exceptions: + Exception: ErrorCall + Message: boom outer + Call stack: + IPE backtrace: + HasCallStack backtrace: + error, called at /prog/Main.hs:8:10 in main:Main + +Exception location: /prog/Main.hs:14:3 +(hdb) \ No newline at end of file diff --git a/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-test b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-test new file mode 100755 index 00000000..b7ada582 --- /dev/null +++ b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +hdb cli prog/Main.hs < exceptions-uncaught.hdb-stdin diff --git a/test/golden/exceptions-uncaught/prog/Main.hs b/test/golden/exceptions-uncaught/prog/Main.hs new file mode 100644 index 00000000..c20c9b04 --- /dev/null +++ b/test/golden/exceptions-uncaught/prog/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import Control.Exception + +main :: IO () +main = do + putStrLn "About to throw" + catch (error "boom outer") handler + putStrLn "Should not reach here" + +handler :: SomeException -> IO () +handler se = do + putStrLn ("Handling exception: " ++ displayException se) + error "boom while handling" diff --git a/test/golden/exceptions/exceptions.hdb-stdin b/test/golden/exceptions/exceptions.hdb-stdin new file mode 100644 index 00000000..3a67def3 --- /dev/null +++ b/test/golden/exceptions/exceptions.hdb-stdin @@ -0,0 +1,3 @@ +break --exceptions +run +exit diff --git a/test/golden/exceptions/exceptions.hdb-stdout b/test/golden/exceptions/exceptions.hdb-stdout new file mode 100644 index 00000000..0ee5dffb --- /dev/null +++ b/test/golden/exceptions/exceptions.hdb-stdout @@ -0,0 +1,14 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] +(hdb) BreakFoundNoLoc {changed = True} +(hdb) About to throw +Stopped at breakpoint +Exception: ErrorCall +Message: boom +Call stack: + IPE backtrace: + HasCallStack backtrace: + error, called at /prog/Main.hs:6:3 in main:Main + +Exception location: /prog/Main.hs:6:3 +(hdb) \ No newline at end of file diff --git a/test/golden/exceptions/exceptions.hdb-test b/test/golden/exceptions/exceptions.hdb-test new file mode 100644 index 00000000..a4f47a10 --- /dev/null +++ b/test/golden/exceptions/exceptions.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +hdb cli prog/Main.hs < exceptions.hdb-stdin diff --git a/test/golden/exceptions/prog/Main.hs b/test/golden/exceptions/prog/Main.hs new file mode 100644 index 00000000..59cf3b79 --- /dev/null +++ b/test/golden/exceptions/prog/Main.hs @@ -0,0 +1,6 @@ +module Main where + +main :: IO () +main = do + putStrLn "About to throw" + error "boom" diff --git a/test/integration-tests/data/exceptions/Main.hs b/test/integration-tests/data/exceptions/Main.hs new file mode 100644 index 00000000..f037f35c --- /dev/null +++ b/test/integration-tests/data/exceptions/Main.hs @@ -0,0 +1,17 @@ +module Main where + +import Control.Exception + +main :: IO () +main = do + putStrLn "About to throw outer exception" + catch throwOuter handler + putStrLn "unreachable" + +throwOuter :: IO () +throwOuter = error "outer boom" + +handler :: SomeException -> IO () +handler se = do + putStrLn ("Handling exception: " ++ displayException se) + error "inner boom" diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index e572206d..96478d67 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -290,6 +290,82 @@ describe("Debug Adapter Tests", function () { }) + // Note: It is not clear that stopping 5 times is the right thing to happen here, + // but it just tests the existing behaviour. + describe("Exception info", function () { + it("reports nested exceptions and continues after the first break", async () => { + const config = mkConfig({ + projectRoot: "/data/exceptions", + entryFile: "Main.hs", + entryPoint: "main", + entryArgs: [], + extraGhcArgs: [] + }); + + await Promise.all([ + dc.waitForEvent('initialized').then(() => + dc.setExceptionBreakpointsRequest({ + filters: ['break-on-exception'] + }).then(() => dc.configurationDoneRequest()) + ), + dc.launch(config), + ]); + + const firstStopped = await dc.waitForEvent('stopped'); + assert.strictEqual(firstStopped.body.reason, 'exception', "Expected first stop to be an exception"); + const firstThreadId = firstStopped.body.threadId; + + const firstInfo = await dc.exceptionInfoRequest({ threadId: firstThreadId }); + assert.strictEqual(firstInfo.body.exceptionId, 'ErrorCall'); + assert.ok(firstInfo.body.details, "Exception details should be present"); + assert.strictEqual(firstInfo.body.details?.message, 'outer boom'); + assert.ok(!firstInfo.body.details?.innerException || firstInfo.body.details?.innerException?.length === 0, "First exception should not have inner exceptions"); + + await dc.continueRequest({ threadId: firstThreadId }); + + const secondStopped = await dc.waitForEvent('stopped'); + assert.strictEqual(secondStopped.body.reason, 'exception', "Expected second stop to be an exception"); + const secondThreadId = secondStopped.body.threadId; + + const secondInfo = await dc.exceptionInfoRequest({ threadId: secondThreadId }); + assert.ok(secondInfo.body.details, "Second exception details should be present"); + assert.strictEqual(secondInfo.body.details?.message, 'inner boom'); + + await dc.continueRequest({ threadId: secondThreadId }); + const thirdStopped = await dc.waitForEvent('stopped'); + assert.strictEqual(thirdStopped.body.reason, 'exception', "Expected second stop to be an exception"); + const thirdThreadId = thirdStopped.body.threadId; + + const thirdInfo = await dc.exceptionInfoRequest({ threadId: thirdThreadId }); + assert.ok(thirdInfo.body.details, "Third exception details should be present"); + assert.strictEqual(thirdInfo.body.details?.message, 'inner boom'); + + + await dc.continueRequest({ threadId: thirdThreadId }); + const fourthStopped = await dc.waitForEvent('stopped'); + assert.strictEqual(fourthStopped.body.reason, 'exception', "Expected fourth stop to be an exception"); + const fourthThreadId = fourthStopped.body.threadId; + + const fourthInfo = await dc.exceptionInfoRequest({ threadId: fourthThreadId }); + assert.ok(fourthInfo.body.details, "Fourth exception details should be present"); + assert.strictEqual(fourthInfo.body.details?.message, 'inner boom'); + + await dc.continueRequest({ threadId: fourthThreadId }); + + const fifthStopped = await dc.waitForEvent('stopped'); + assert.strictEqual(fifthStopped.body.reason, 'exception', "Expected fifth stop to be an exception"); + const fifthThreadId = fifthStopped.body.threadId; + + const fifthInfo = await dc.exceptionInfoRequest({ threadId: fifthThreadId }); + assert.ok(fifthInfo.body.details, "Fifth exception details should be present"); + assert.strictEqual(fifthInfo.body.details?.message, 'inner boom'); + + await dc.continueRequest({ threadId: fifthThreadId }); + + await dc.waitForEvent('terminated'); + }); + }) + describe("Multiple main function tests", function () { const multiMainConfig = mkConfig({ projectRoot: "/data/multi-mains", From 9dbede400d4a37a19c7110f0f71f5aa0df5b9eab Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Tue, 20 Jan 2026 10:34:43 +0000 Subject: [PATCH 5/5] Move exception helpers to GHC.Debugger.Stopped.Exception module --- haskell-debugger.cabal | 1 + haskell-debugger/GHC/Debugger.hs | 1 + haskell-debugger/GHC/Debugger/Stopped.hs | 177 +------------- .../GHC/Debugger/Stopped/Exception.hs | 219 ++++++++++++++++++ 4 files changed, 222 insertions(+), 176 deletions(-) create mode 100644 haskell-debugger/GHC/Debugger/Stopped/Exception.hs diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index 8fa4afdb..c44cc289 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -61,6 +61,7 @@ library GHC.Debugger.Logger, GHC.Debugger.Run, GHC.Debugger.Stopped, + GHC.Debugger.Stopped.Exception, GHC.Debugger.Stopped.Variables, GHC.Debugger.Runtime, diff --git a/haskell-debugger/GHC/Debugger.hs b/haskell-debugger/GHC/Debugger.hs index 57fe28dc..81bf26cc 100644 --- a/haskell-debugger/GHC/Debugger.hs +++ b/haskell-debugger/GHC/Debugger.hs @@ -9,6 +9,7 @@ import Control.Monad.IO.Class import GHC.Debugger.Breakpoint import GHC.Debugger.Run import GHC.Debugger.Stopped +import GHC.Debugger.Stopped.Exception (getExceptionInfo) import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages import GHC.Debugger.Logger diff --git a/haskell-debugger/GHC/Debugger/Stopped.hs b/haskell-debugger/GHC/Debugger/Stopped.hs index 198ed6e7..6f6c3574 100644 --- a/haskell-debugger/GHC/Debugger/Stopped.hs +++ b/haskell-debugger/GHC/Debugger/Stopped.hs @@ -21,10 +21,10 @@ import GHC.Driver.Env as GHC import GHC.Runtime.Eval import GHC.Types.SrcLoc import GHC.InfoProv -import GHC.Data.FastString (unpackFS) import GHC.Utils.Outputable as Ppr import qualified GHC.Unit.Home.Graph as HUG +import GHC.Debugger.Stopped.Exception import GHC.Debugger.Stopped.Variables import GHC.Debugger.Runtime import GHC.Debugger.Runtime.Thread @@ -35,10 +35,6 @@ import GHC.Debugger.Interface.Messages import qualified GHC.Debugger.Interface.Messages as DbgStackFrame (DbgStackFrame(..)) import GHC.Debugger.Utils import qualified GHC.Debugger.Logger as Logger -import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote -import GHC.Debugger.Runtime.Term.Parser -import GHCi.RemoteTypes (castForeignRef) -import GHC.Builtin.Types (anyTy) {- Note [Don't crash if not stopped] @@ -366,174 +362,3 @@ getTopImported modl = do liftIO $ HUG.lookupHugByModule modl (hsc_HUG hsc_env) >>= \case Nothing -> return emptyGlobalRdrEnv Just hmi -> mkTopLevImportedEnv hsc_env hmi - --------------------------------------------------------------------------------- --- * Exception context helpers --------------------------------------------------------------------------------- - -exceptionSourceSpanFromContext :: Debugger (Maybe SourceSpan) -exceptionSourceSpanFromContext = do - GHC.getResumeContext >>= \case - r:_ | Nothing <- GHC.resumeBreakpointId r -> do - let excRef = resumeApStack r - evalRes <- Remote.eval - (Remote.raw exceptionLocationExpr `Remote.app` Remote.untypedRef excRef) - case evalRes of - Left err -> do - logSDoc Logger.Debug $ - Ppr.text "Failed to evaluate exception context:" Ppr.<+> Ppr.text (show err) - return Nothing - Right fhv -> do - parsed <- obtainParsedTerm "Exception context location" 4 True anyTy (castForeignRef fhv) - (maybeParser exceptionLocationTupleParser) - case parsed of - Left errs -> do - logSDoc Logger.Debug $ - Ppr.text "Failed to parse exception context location:" - Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs) - return Nothing - Right Nothing -> return Nothing - Right (Just (file, srcLine, col)) -> - return $ Just SourceSpan - { file = file - , startLine = srcLine - , startCol = col - , endLine = srcLine - , endCol = col - } - _ -> return Nothing - -exceptionLocationTupleParser :: TermParser (String, Int, Int) -exceptionLocationTupleParser = - (,,) <$> subtermWith 0 stringParser - <*> subtermWith 1 intParser - <*> subtermWith 2 intParser - -exceptionLocationExpr :: String -exceptionLocationExpr = unlines - [ "let" - , " fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of" - , " Just (_, loc) -> Just ( GHC.Exception.srcLocFile loc" - , " , GHC.Exception.srcLocStartLine loc" - , " , GHC.Exception.srcLocStartCol loc)" - , " go exc =" - , " let ctx = Control.Exception.someExceptionContext exc" - , " bts :: [Control.Exception.Backtrace.Backtraces]" - , " bts = Control.Exception.Context.getExceptionAnnotations ctx" - , " in case bts of" - , " bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of" - , " Just cs -> fromCallStack cs" - , " Nothing -> Nothing" - , " [] -> Nothing" - , " in go" - ] - -getExceptionInfo :: RemoteThreadId -> Debugger ExceptionInfo -getExceptionInfo req_tid = GHC.getResumeContext >>= \case - [] -> return defaultExceptionInfo - r:_ -> do - r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r) - case (r_tid == req_tid, GHC.resumeBreakpointId r) of - (True, Nothing) -> do - let excRef = resumeApStack r - fromMaybe defaultExceptionInfo <$> exceptionInfoFromContext excRef - _ -> return defaultExceptionInfo - -exceptionInfoFromContext :: ForeignHValue -> Debugger (Maybe ExceptionInfo) -exceptionInfoFromContext excRef = do - -- 1. Compile the datatype definition we need - _ <- runDecls exceptionInfoData - -- 2. Gather the exception information. - evalRes <- Remote.eval - (Remote.raw exceptionInfoExpr `Remote.app` Remote.untypedRef excRef) - case evalRes of - Left err -> do - logSDoc Logger.Debug $ - Ppr.text "Failed to evaluate exception info:" Ppr.<+> Ppr.text (show err) - return Nothing - Right fhv -> do - parsed <- obtainParsedTerm "Exception info" 4 True anyTy (castForeignRef fhv) - exceptionInfoParser - case parsed of - Left errs -> do - logSDoc Logger.Debug $ - Ppr.text "Failed to parse exception info:" - Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs) - return Nothing - Right info -> return (Just info) - -exceptionInfoParser :: TermParser ExceptionInfo -exceptionInfoParser = do - ExceptionInfo - <$> subtermWith 0 stringParser - <*> subtermWith 1 stringParser - <*> subtermWith 2 stringParser - <*> subtermWith 3 (maybeParser stringParser) - <*> subtermWith 4 (parseList exceptionInfoParser) - --- Need to use a specific datatype since ExceptionInfoNode is recursive -exceptionInfoData :: String -exceptionInfoData = "data ExceptionInfoNode = ExceptionInfoNode String String String (Maybe String) [ExceptionInfoNode]" - -exceptionInfoExpr :: String -exceptionInfoExpr = - unlines - [ "\\se ->" - , " let collectExceptionInfo :: SomeException -> ExceptionInfoNode" - , " collectExceptionInfo se' =" - , " case se' of" - , " SomeException exc ->" - , " let ctx = Control.Exception.someExceptionContext se'" - , " rendered = Control.Exception.Context.displayExceptionContext ctx" - , " whileHandling = Control.Exception.Context.getExceptionAnnotations ctx" - , " innerNodes = map (collectExceptionInfo . unwrap) whileHandling" - , " simpleTypeName = Data.Typeable.tyConName tc" - , " modulePrefix = case Data.Typeable.tyConModule tc of" - , " mdl | null mdl -> \"\"" - , " | otherwise -> mdl ++ \".\"" - , " packagePrefix = case Data.Typeable.tyConPackage tc of" - , " pkg | null pkg -> \"\"" - , " | otherwise -> pkg ++ \":\"" - , " tc = Data.Typeable.typeRepTyCon (Data.Typeable.typeOf exc)" - , " fullTypeName = packagePrefix ++ modulePrefix ++ simpleTypeName" - , " unwrap (Control.Exception.WhileHandling inner) = inner" - , " contextText = if null rendered then Nothing else Just rendered" - , " in ExceptionInfoNode" - , " simpleTypeName" - , " fullTypeName" - , " (Control.Exception.displayException se')" - , " contextText" - , " innerNodes" - , " in collectExceptionInfo se" - ] - -fallbackExceptionSourceSpan :: Maybe SrcSpan -> SourceSpan -fallbackExceptionSourceSpan mspan = - let fileLabel = maybe "" spanLabel mspan - in SourceSpan - { file = fileLabel - , startLine = 0 - , startCol = 0 - , endLine = 0 - , endCol = 0 - } - where - spanLabel (RealSrcSpan rss _) = unpackFS (srcSpanFile rss) - spanLabel (UnhelpfulSpan reason) = unpackFS (unhelpfulSpanFS reason) - -defaultExceptionInfo :: ExceptionInfo -defaultExceptionInfo = ExceptionInfo - { exceptionInfoTypeName = "Exception" - , exceptionInfoFullTypeName = "Exception" - , exceptionInfoMessage = "Exception information not available" - , exceptionInfoContext = Nothing - , exceptionInfoInner = [] - } - -currentlyStoppedOnException :: Debugger Bool -currentlyStoppedOnException = do - resumes <- GHC.getResumeContext - return $ case resumes of - [] -> False - r:_ -> isNothing (GHC.resumeBreakpointId r) - diff --git a/haskell-debugger/GHC/Debugger/Stopped/Exception.hs b/haskell-debugger/GHC/Debugger/Stopped/Exception.hs new file mode 100644 index 00000000..fc789491 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Stopped/Exception.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultilineStrings #-} + +-- | Helpers used when the debugger is stopped due to an exception. +-- These helpers execute code on the remote process which teach us information +-- about the exception we are stopped at. +module GHC.Debugger.Stopped.Exception + ( exceptionSourceSpanFromContext + , getExceptionInfo + , fallbackExceptionSourceSpan + , defaultExceptionInfo + , currentlyStoppedOnException + ) where + +import Data.Maybe (fromMaybe, isNothing) + +import GHC +import GHC.Types.SrcLoc +import GHC.Data.FastString (unpackFS) +import GHC.Utils.Outputable as Ppr + +import GHC.Debugger.Monad +import GHC.Debugger.Interface.Messages + ( SourceSpan(..) + , ExceptionInfo(..) + , RemoteThreadId(..) + ) +import qualified GHC.Debugger.Logger as Logger +import GHC.Debugger.Runtime.Thread +import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote +import GHC.Debugger.Runtime.Term.Parser +import GHCi.RemoteTypes (castForeignRef) +import GHC.Builtin.Types (anyTy) + +-- | Attempt to obtain a more precise 'SourceSpan' for the exception we stopped +-- on by consulting its context, if available. +exceptionSourceSpanFromContext :: Debugger (Maybe SourceSpan) +exceptionSourceSpanFromContext = do + GHC.getResumeContext >>= \case + r:_ | Nothing <- GHC.resumeBreakpointId r -> do + let excRef = resumeApStack r + evalRes <- Remote.eval + (Remote.raw exceptionLocationExpr `Remote.app` Remote.untypedRef excRef) + case evalRes of + Left err -> do + logSDoc Logger.Debug $ + Ppr.text "Failed to evaluate exception context:" Ppr.<+> Ppr.text (show err) + return Nothing + Right fhv -> do + parsed <- obtainParsedTerm "Exception context location" 4 True anyTy (castForeignRef fhv) + (maybeParser exceptionLocationTupleParser) + case parsed of + Left errs -> do + logSDoc Logger.Debug $ + Ppr.text "Failed to parse exception context location:" + Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs) + return Nothing + Right Nothing -> return Nothing + Right (Just (file, srcLine, col)) -> + return $ Just SourceSpan + { file = file + , startLine = srcLine + , startCol = col + , endLine = srcLine + , endCol = col + } + _ -> return Nothing + +exceptionLocationTupleParser :: TermParser (String, Int, Int) +exceptionLocationTupleParser = + (,,) <$> subtermWith 0 stringParser + <*> subtermWith 1 intParser + <*> subtermWith 2 intParser + +-- | This helper looks at the exception context for an exception, and retrieves +-- the last entry of the HasCallStack backtrace. +exceptionLocationExpr :: String +exceptionLocationExpr =""" + let + fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of + Just (_, loc) -> Just ( GHC.Exception.srcLocFile loc + , GHC.Exception.srcLocStartLine loc + , GHC.Exception.srcLocStartCol loc) + go exc = + let ctx = Control.Exception.someExceptionContext exc + bts :: [Control.Exception.Backtrace.Backtraces] + bts = Control.Exception.Context.getExceptionAnnotations ctx + in case bts of + bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of + Just cs -> fromCallStack cs + Nothing -> Nothing + [] -> Nothing + in go +""" + +-- | Retrieve structured exception information for the requested thread when +-- the debugger is currently stopped on an exception. +getExceptionInfo :: RemoteThreadId -> Debugger ExceptionInfo +getExceptionInfo req_tid = GHC.getResumeContext >>= \case + [] -> return defaultExceptionInfo + r:_ -> do + r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r) + case (r_tid == req_tid, GHC.resumeBreakpointId r) of + (True, Nothing) -> do + let excRef = resumeApStack r + fromMaybe defaultExceptionInfo <$> exceptionInfoFromContext excRef + _ -> return defaultExceptionInfo + +-- | Evaluate helper code inside the debuggee that turns the exception context +-- into our 'ExceptionInfo' structure. +exceptionInfoFromContext :: ForeignHValue -> Debugger (Maybe ExceptionInfo) +exceptionInfoFromContext excRef = do + -- 1. Add a "data" declaration for the datatype the expression will return + _ <- runDecls exceptionInfoData + -- 2. Gather information about the exception. + evalRes <- Remote.eval + (Remote.raw exceptionInfoExpr `Remote.app` Remote.untypedRef excRef) + case evalRes of + Left err -> do + logSDoc Logger.Debug $ + Ppr.text "Failed to evaluate exception info:" Ppr.<+> Ppr.text (show err) + return Nothing + Right fhv -> do + parsed <- obtainParsedTerm "Exception info" 4 True anyTy (castForeignRef fhv) + exceptionInfoParser + case parsed of + Left errs -> do + logSDoc Logger.Debug $ + Ppr.text "Failed to parse exception info:" + Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs) + return Nothing + Right info -> return (Just info) + +-- | Parse the helper 'ExceptionInfoNode' structure produced inside the +-- debuggee into our externally facing 'ExceptionInfo'. +exceptionInfoParser :: TermParser ExceptionInfo +exceptionInfoParser = do + ExceptionInfo + <$> subtermWith 0 stringParser + <*> subtermWith 1 stringParser + <*> subtermWith 2 stringParser + <*> subtermWith 3 (maybeParser stringParser) + <*> subtermWith 4 (parseList exceptionInfoParser) + +-- | Definition for the helper 'ExceptionInfoNode' data type compiled into the +-- debuggee to aid in transporting nested exception information. +-- We need a specific datatype because ExceptionInfoNode is recursive. +exceptionInfoData :: String +exceptionInfoData = + "data ExceptionInfoNode = ExceptionInfoNode String String String (Maybe String) [ExceptionInfoNode]" + +-- | Helper expression run in the debuggee that walks the exception context and +-- populates the 'ExceptionInfoNode' structure. +exceptionInfoExpr :: String +exceptionInfoExpr = """ + let collectExceptionInfo :: SomeException -> ExceptionInfoNode + collectExceptionInfo se' = + case se' of + SomeException exc -> + let ctx = Control.Exception.someExceptionContext se' + rendered = Control.Exception.Context.displayExceptionContext ctx + whileHandling = Control.Exception.Context.getExceptionAnnotations ctx + innerNodes = map (collectExceptionInfo . unwrap) whileHandling + simpleTypeName = Data.Typeable.tyConName tc + modulePrefix = case Data.Typeable.tyConModule tc of + mdl | null mdl -> \"\" + | otherwise -> mdl ++ \".\" + packagePrefix = case Data.Typeable.tyConPackage tc of + pkg | null pkg -> \"\" + | otherwise -> pkg ++ \":\" + tc = Data.Typeable.typeRepTyCon (Data.Typeable.typeOf exc) + fullTypeName = packagePrefix ++ modulePrefix ++ simpleTypeName + unwrap (Control.Exception.WhileHandling inner) = inner + contextText = if null rendered then Nothing else Just rendered + in ExceptionInfoNode + simpleTypeName + fullTypeName + (Control.Exception.displayException se') + contextText + innerNodes + in collectExceptionInfo + """ + + +-- | When no precise exception location is available, fall back to displaying a +-- label derived from the provided 'SrcSpan'. +fallbackExceptionSourceSpan :: Maybe SrcSpan -> SourceSpan +fallbackExceptionSourceSpan mspan = + let fileLabel = maybe "" spanLabel mspan + in SourceSpan + { file = fileLabel + , startLine = 0 + , startCol = 0 + , endLine = 0 + , endCol = 0 + } + where + spanLabel (RealSrcSpan rss _) = unpackFS (srcSpanFile rss) + spanLabel (UnhelpfulSpan reason) = unpackFS (unhelpfulSpanFS reason) + +-- | Placeholder exception info returned when the context could not be +-- inspected. +defaultExceptionInfo :: ExceptionInfo +defaultExceptionInfo = ExceptionInfo + { exceptionInfoTypeName = "Exception" + , exceptionInfoFullTypeName = "Exception" + , exceptionInfoMessage = "Exception information not available" + , exceptionInfoContext = Nothing + , exceptionInfoInner = [] + } + +-- | Determine whether the debugger is currently stopped because of an +-- exception (as opposed to a breakpoint). +currentlyStoppedOnException :: Debugger Bool +currentlyStoppedOnException = do + resumes <- GHC.getResumeContext + return $ case resumes of + [] -> False + r:_ -> isNothing (GHC.resumeBreakpointId r)