Infrastructure

R/compat-lifecycle.R

@@ -48,4 +48,28 @@ foreign_caller_env <- function(my_env = ns_env()) {
   caller
 }
 
+my_caller_env <- function(my_env = ns_env()) {
+  for (n in 2:10) {
+    caller <- caller_env(n)
+    if (!is_reference(env_parent(caller), my_env)) {
+      return(caller_env(n - 1))
+    }
+  }
+
+  # Safety net
+  caller
+}
+
+my_caller_call <- function(my_env = ns_env()) {
+  for (n in 2:10) {
+    caller <- caller_env(n)
+    if (!is_reference(env_parent(caller), my_env)) {
+      return(caller_call(n - 1))
+    }
+  }
+
+  # Safety net
+  caller
+}
+
 # nocov end

R/error.R

@@ -18,6 +18,16 @@ tibble_error_class <- function(class) {
 }
 
 # Errors get a class name derived from the name of the calling function
+tibble_abort <- function(x, ..., parent = NULL) {
+  abort_call <- sys.call(-1)
+  fn_name <- as_name(abort_call[[1]])
+  class <- tibble_error_class(gsub("^abort_", "", fn_name))
+
+  call <- my_caller_call()
+
+  abort(x, class, ..., call = call, parent = parent)
+}
+
 tibble_error <- function(x, ..., parent = NULL) {
   call <- sys.call(-1)
   fn_name <- as_name(call[[1]])

tests/testthat/helper-error.R

@@ -4,3 +4,7 @@ get_defunct_error_class <- function() {
 
 # Dummy to remind us to keep tests and verifications in sync
 verify_errors <- identity
+
+print_error <- function(expr) {
+  print(expect_error(expr), backtrace = FALSE)
+}

tests/testthat/helper-expectations.R

@@ -1,3 +1,8 @@
+expect_tibble_abort <- function(object, error, fixed = NULL) {
+  cnd <- tryCatch(error, error = identity)
+  expect_tibble_error(object, cnd, fixed = fixed)
+}
+
 expect_tibble_error <- function(object, cnd, fixed = NULL) {
   cnd_actual <- expect_error(object, class = class(cnd)[[1]])
   expect_cnd_equivalent(cnd_actual, cnd)
@@ -8,9 +13,11 @@ expect_cnd_equivalent <- function(actual, expected) {
   actual$trace <- NULL
   actual$parent <- NULL
   actual$body <- NULL
+  actual$call <- NULL
   expected$trace <- NULL
   expected$parent <- NULL
   expected$body <- NULL
+  expected$call <- NULL
   expect_equal(actual, expected)
 }