Make stack trace stripping work across deep stacks

rstudio · Dec 4, 2024 · 16b5b31 · 16b5b31
1 parent 2dbb59a
commit 16b5b31
Show file tree

Hide file tree

Showing 3 changed files with 120 additions and 3 deletions.
diff --git a/R/conditions.R b/R/conditions.R
@@ -359,10 +359,28 @@ printStackTrace <- function(cond,
     list(attr(cond, "stack.trace", exact = TRUE))
   )
 
+  # Stripping of stack traces is the one step where the different stack traces
+  # interact.
+  stripResults <- stripStackTraces(lapply(stackTraces, function(trace) {
+    if (is.integer(trace)) {
+      # This is where deep stacks were elided.
+      # jcheng 2024-12-03: For the purposes of stack trace stripping, it's not
+      # ideal that we're eliding entire stacks before we get here--this actually
+      # potentially screws up our scoring (i.e., an unbalanced ..stacktraceon..
+      # or ..stacktraceoff.. was elided). If this surfaces as an actual problem,
+      # we could maybe maintain a cumulative score of the stacks as we elide
+      # them.
+      character(0)
+    } else {
+      getCallNames(trace)
+    }
+  }))
+
   dfs <- mapply(
     seq_along(stackTraces),
     rev(stackTraces),
-    FUN = function(i, trace) {
+    rev(stripResults),
+    FUN = function(i, trace, stripResult) {
       if (is.integer(trace)) {
         noun <- if (trace > 1L) "traces" else "trace"
         message("[ reached getOption(\"shiny.deepstacktrace\") -- omitted ", trace, " more stack ", noun, " ]")
@@ -372,6 +390,7 @@ printStackTrace <- function(cond,
         }
         printOneStackTrace(
           stackTrace = trace,
+          stripResult = stripResult,
           full = full,
           offset = offset
         )
@@ -383,7 +402,7 @@ printStackTrace <- function(cond,
   invisible()
 }
 
-printOneStackTrace <- function(stackTrace, full, offset) {
+printOneStackTrace <- function(stackTrace, stripResult, full, offset) {
   calls <- offsetSrcrefs(stackTrace, offset = offset)
   callNames <- getCallNames(stackTrace)
   parents <- attr(stackTrace, "parents", exact = TRUE)
@@ -397,14 +416,15 @@ printOneStackTrace <- function(stackTrace, full, offset) {
     calls <- calls[toKeep]
     callNames <- callNames[toKeep]
     parents <- parents[toKeep]
+    stripResult <- stripResult[toKeep]
   }
 
   toShow <- rep(TRUE, length(callNames))
   if (should_prune) {
     toShow <- toShow & pruneStackTrace(parents)
   }
   if (should_strip) {
-    toShow <- toShow & stripStackTraces(list(callNames))[[1]]
+    toShow <- toShow & stripResult
   }
 
   # If we're running in testthat, hide the parts of

diff --git a/tests/testthat/_snaps/stacks-deep.md b/tests/testthat/_snaps/stacks-deep.md
@@ -474,3 +474,80 @@
           : test_files_serial
           : test_files
 
+# stack trace stripping works
+
+    Code
+      cat(sep = "\n", formatError(strperr))
+    Output
+      Error in onFulfilled: boom
+          : stop
+          : onFulfilled [test-stacks-deep.R#XXX]
+          : callback [conditions.R#XXX]
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it [mock-session.R#XXX]
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : E__ [test-stacks-deep.R#XXX]
+      From earlier call:
+        [No stack trace available]
+      From earlier call:
+          : onFulfilled [test-stacks-deep.R#XXX]
+          : callback [conditions.R#XXX]
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it [mock-session.R#XXX]
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : B__ [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : callback [conditions.R#XXX]
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it [mock-session.R#XXX]
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : A__ [test-stacks-deep.R#XXX]
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+
diff --git a/tests/testthat/test-stacks-deep.R b/tests/testthat/test-stacks-deep.R
@@ -235,3 +235,23 @@ test_that("unlimited deep stacks can be opted into", {
   expect_s3_class(uerr, "error", exact = FALSE)
   expect_identical(length(attr(uerr, "deep.stack.trace", exact = TRUE)), 100L)
 })
+
+test_that("stack trace stripping works", {
+  A__ <- function() promise_resolve(TRUE) %...>% B__()
+  B__ <- function(x) promise_resolve(TRUE) %...>% { ..stacktraceoff..(C__()) }
+  C__ <- function(x) promise_resolve(TRUE) %...>% D__()
+  D__ <- function(x) promise_resolve(TRUE) %...>% { ..stacktraceon..(E__()) }
+  E__ <- function(x) promise_resolve(TRUE) %...>% { stop("boom") }
+
+  strperr <- NULL
+  captureStackTraces(A__()) %...!% (function(err) {
+    strperr <<- err
+  })
+
+  ..stacktracefloor..(
+    wait_for_it()
+  )
+
+  expect_s3_class(strperr, "error", exact = FALSE)
+  expect_snapshot(cat(sep="\n", formatError(strperr)))
+})