Add classes to errors. (#59)

Closes #58.
jonthegeek · Oct 25, 2023 · c2fd9cf · c2fd9cf
1 parent e0239e2
commit c2fd9cf
Show file tree

Hide file tree

Showing 5 changed files with 63 additions and 10 deletions.
diff --git a/R/check.R b/R/check.R
@@ -14,7 +14,8 @@
       msg = "must not contain NA values.",
       x_arg = x_arg,
       additional_msg = c("*" = "NA locations: {locations}"),
-      call = call
+      call = call,
+      class = "stbl_error_bad_na"
     )
   }
   return(invisible(NULL))
@@ -47,15 +48,17 @@
       msg = "must have size >= {min_size}.",
       x_arg = x_arg,
       additional_msg = c(x = "{x_size} is too small."),
-      call = call
+      call = call,
+      class = "stbl_error_size_too_small"
     )
   }
 
   .stop_must(
     msg = "must have size <= {max_size}.",
     x_arg = x_arg,
     additional_msg = c(x = "{x_size} is too big."),
-    call = call
+    call = call,
+    class = "stbl_error_size_too_large"
   )
 }
 
@@ -96,7 +99,8 @@
     "must be a single {.cls {x_class}}.",
     x_arg = x_arg,
     call = call,
-    additional_msg = c(x = "{.arg {x_arg}} has {no(x_size)} values.")
+    additional_msg = c(x = "{.arg {x_arg}} has {no(x_size)} values."),
+    class = "stbl_error_non_scalar"
   )
 }
 
@@ -112,7 +116,8 @@
         "*" = "{.arg {x_arg}} = {x}",
         "*" = "{.arg {y_arg}} = {y}"
       ),
-      call = call
+      call = call,
+      class = "stbl_error_size_x_vs_y"
     )
   }
 }
diff --git a/R/msgs_common.R b/R/msgs_common.R
@@ -6,12 +6,17 @@ rlang::caller_arg
 #' @export
 rlang::caller_env
 
-.stop_must <- function(msg, x_arg, call, additional_msg = NULL) {
+.stop_must <- function(msg,
+                       x_arg,
+                       call,
+                       additional_msg = NULL,
+                       class = "stbl_error_must") {
   main_msg <- .glue2("{.arg [x_arg]} [msg]")
   cli_abort(
     c(main_msg, additional_msg),
     call = call,
-    .envir = caller_env()
+    .envir = caller_env(),
+    class = class
   )
 }
 
@@ -23,15 +28,22 @@ rlang::caller_env
   main_msg <- .glue2(
     "Can't coerce {.arg [x_arg]} {.cls [from_class]} to {.cls [to_class]}."
   )
+  error_class <- paste0("stbl_error_coerce_", to_class)
   cli_abort(
     c(main_msg, additional_msg),
     call = call,
-    .envir = caller_env()
+    .envir = caller_env(),
+    class = error_class
   )
 }
 
 .stop_null <- function(x_arg, call) {
-  .stop_must("must not be {.cls NULL}.", x_arg = x_arg, call = call)
+  .stop_must(
+    "must not be {.cls NULL}.",
+    x_arg = x_arg,
+    call = call,
+    class = "stbl_error_bad_null"
+  )
 }
 
 .stop_incompatible <- function(x_class,

diff --git a/R/stabilize_chr.R b/R/stabilize_chr.R
@@ -77,5 +77,5 @@ stabilize_chr <- function(x,
   if (requireNamespace("stringi", quietly = TRUE)) {
     return(stringi::stri_detect_regex(x, regex))
   }
-  return(grepl(regex, x))
+  return(grepl(regex, x)) # nocov
 }
diff --git a/tests/testthat/test-stabilize_arg.R b/tests/testthat/test-stabilize_arg.R
@@ -23,6 +23,10 @@ test_that("stabilize_arg() rejects NULLs when asked", {
     stabilize_arg(x, ...)
   }
   given <- NULL
+  expect_error(
+    stabilize_arg(given, allow_null = FALSE),
+    class = "stbl_error_bad_null"
+  )
   expect_snapshot(
     stabilize_arg(given, allow_null = FALSE),
     error = TRUE
@@ -41,6 +45,10 @@ test_that("stabilize_arg() checks NAs", {
   expect_identical(stabilize_arg(given, allow_na = FALSE), given)
 
   given[c(4, 7)] <- NA
+  expect_error(
+    stabilize_arg(given, allow_na = FALSE),
+    class = "stbl_error_bad_na"
+  )
   expect_snapshot(
     stabilize_arg(given, allow_na = FALSE),
     error = TRUE
@@ -59,10 +67,18 @@ test_that("stabilize_arg() checks size args", {
   given <- TRUE
   expect_true(stabilize_arg(given, min_size = 1, max_size = 1))
 
+  expect_error(
+    stabilize_arg(given, min_size = 2, max_size = 1),
+    class = "stbl_error_size_x_vs_y"
+  )
   expect_snapshot(
     stabilize_arg(given, min_size = 2, max_size = 1),
     error = TRUE
   )
+  expect_error(
+    wrapper(given, min_size = 2, max_size = 1),
+    class = "stbl_error_size_x_vs_y"
+  )
   expect_snapshot(
     wrapper(given, min_size = 2, max_size = 1),
     error = TRUE
@@ -76,17 +92,29 @@ test_that("stabilize_arg() checks size", {
     given
   )
 
+  expect_error(
+    stabilize_arg(given, min_size = 11),
+    class = "stbl_error_size_too_small"
+  )
   expect_snapshot(
     stabilize_arg(given, min_size = 11),
     error = TRUE
   )
   wrapper <- function(x, ...) {
     stabilize_arg(x, ...)
   }
+  expect_error(
+    wrapper(given, min_size = 11),
+    class = "stbl_error_size_too_small"
+  )
   expect_snapshot(
     wrapper(given, min_size = 11),
     error = TRUE
   )
+  expect_error(
+    stabilize_arg(given, max_size = 2),
+    class = "stbl_error_size_too_large"
+  )
   expect_snapshot(
     stabilize_arg(given, max_size = 2),
     error = TRUE

diff --git a/tests/testthat/test-stabilize_arg_scalar.R b/tests/testthat/test-stabilize_arg_scalar.R
@@ -7,6 +7,10 @@ test_that("stabilize_arg_scalar() allows length-1 args through", {
 
 test_that("stabilize_arg_scalar() provides informative error messages", {
   given <- 1:10
+  expect_error(
+    stabilize_arg_scalar(given),
+    class = "stbl_error_non_scalar"
+  )
   expect_snapshot(
     stabilize_arg_scalar(given),
     error = TRUE
@@ -21,6 +25,10 @@ test_that("stabilize_arg_scalar() provides informative error messages", {
   )
 
   given <- NULL
+  expect_error(
+    stabilize_arg_scalar(given, allow_null = FALSE),
+    class = "stbl_error_non_scalar"
+  )
   expect_snapshot(
     stabilize_arg_scalar(given, allow_null = FALSE),
     error = TRUE