Report base error class (#2307)

In #2283 we started entracing snapshots so that we get useful backtraces if snapshot code unexpectedly errors. This had the unfortunate side-effect of changing the reported class for expected errors. We now show the original message if it was an entraced error.

Author: hadley

NEWS.md

@@ -1,5 +1,6 @@
 # testthat 3.3.1
 
+* `expect_snapshot()` now reports the original error class for base errors, rather than `rlang_error` (#2286).
 * `expect_success()` and `expect_failure()` are more clear about what the expectation actually did (#2297).
 * The hint to use `snapshot_download_gh()` is now only emitted when running in a job named "R-CMD-check" (#2300).
 * `expect_snapshot_file()` correctly reports file name if duplicated (@MichaelChirico, #2296).

R/snapshot.R

@@ -185,12 +185,22 @@ snapshot_replay.condition <- function(
   }
 
   if (cnd_class) {
-    type <- paste0(type, " <", class(x)[[1]], ">")
+    type <- paste0(type, " <", error_class(x), ">")
   }
 
   c(snap_header(state, type), snapshot_lines(msg, transform))
 }
 
+error_class <- function(x) {
+  # If error was entraced from base R error, use original error class
+  # This is a little fragile because entrace() does not document this behaviour
+  if (inherits(x, "rlang_error") && !is.null(x$error)) {
+    x <- x$error
+  }
+  class(x)[[1]]
+}
+
+
 snapshot_lines <- function(x, transform = NULL) {
   x <- split_lines(x)
   if (!is.null(transform)) {

tests/testthat/_snaps/snapshot.md

@@ -243,7 +243,7 @@
     Condition <simpleWarning>
       Warning in `f()`:
       bar
-    Condition <rlang_error>
+    Condition <simpleError>
       Error in `f()`:
       ! baz
 

tests/testthat/test-snapshot.R

@@ -169,6 +169,24 @@ test_that("errors and warnings are folded", {
 #   expect_snapshot(1 + 1)
 # })
 
+test_that("extracts original error class", {
+  catch_entraced <- function(code) {
+    tryCatch(
+      withCallingHandlers(code, error = function(cnd) rlang::entrace(cnd)),
+      error = function(cnd) cnd
+    )
+  }
+
+  cnd <- catch_entraced(stop("!", call. = FALSE))
+  expect_equal(error_class(cnd), "simpleError")
+
+  cnd <- catch_entraced(stop(errorCondition("!", class = "badError")))
+  expect_equal(error_class(cnd), "badError")
+
+  cnd <- catch_entraced(abort("!"))
+  expect_equal(error_class(cnd), "rlang_error")
+})
+
 test_that("hint is informative", {
   local_mocked_bindings(in_check_reporter = function() FALSE)
   withr::local_envvar(GITHUB_ACTIONS = "false", TESTTHAT_WD = NA)