Implement wrappers for condition classes

NAMESPACE

@@ -65,9 +65,11 @@ export(class_atomic)
 export(class_call)
 export(class_character)
 export(class_complex)
+export(class_condition)
 export(class_data.frame)
 export(class_double)
 export(class_environment)
+export(class_error)
 export(class_expression)
 export(class_factor)
 export(class_formula)
@@ -81,6 +83,7 @@ export(class_name)
 export(class_numeric)
 export(class_raw)
 export(class_vector)
+export(class_warning)
 export(convert)
 export(method)
 export(method_explain)

NEWS.md

@@ -2,6 +2,7 @@
 
 * New `:=` operator creates and names an object in one step, so `Foo := new_class()` is equivalent to `Foo <- new_class(name = "Foo")` (#658).
 * Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646).
+* New `class_condition`, `class_error`, and `class_warning` wrap the base condition classes, making it easier to use S7 to define custom condition classes (#586).
 * `class_POSIXct` uses the `tzone` attribute (not `tz`), and allows it to be absent (#401).
 * Base type wrappers like `class_integer` now define their constructor and validator in the S7 namespace. (#553).
 * Method dispatch on `class_missing` now correctly handles missing arguments forwarded through a wrapper functions (#595).

R/conditions.R

@@ -0,0 +1,69 @@
+#' S7 wrappers for base condition classes
+#'
+#' @description
+#' S7 bundles [S3 definitions][new_S3_class] for the base condition classes,
+#' making it easier to use S7 to define custom condition classes:
+#'
+#' * `class_condition` for conditions, the parent class of all conditions.
+#' * `class_error` for errors, as signalled by [stop()].
+#' * `class_warning` for warnings, as signalled by [warning()].
+#'
+#' These classes are lists with `message` and `call` elements, since base
+#' accessors like [conditionMessage()] and [conditionCall()] retrieve these
+#' fields from the underlying list. Subclasses inherit these elements, so they
+#' remain compatible with base condition handling.
+#'
+#' @name base_condition_classes
+#' @order 0
+#' @returns S7 classes wrapping around the base condition classes.
+#' @examples
+#' class_error
+NULL
+
+validate_condition <- function(self) {
+  if (!is.list(self)) {
+    return("Underlying data must be a <list>")
+  }
+  if (!is.character(self$message) || length(self$message) != 1) {
+    return("`message` must be a single string")
+  }
+}
+
+new_condition_constructor <- function(class) {
+  function(.data = list(), message = "", call = NULL) {
+    structure(
+      c(list(message = message, call = call), .data),
+      class = class
+    )
+  }
+}
+
+#' @export
+#' @rdname base_condition_classes
+#' @format NULL
+#' @order 1
+class_condition <- new_S3_class(
+  "condition",
+  constructor = new_condition_constructor("condition"),
+  validator = validate_condition
+)
+
+#' @export
+#' @rdname base_condition_classes
+#' @format NULL
+#' @order 1
+class_error <- new_S3_class(
+  c("error", "condition"),
+  constructor = new_condition_constructor(c("error", "condition")),
+  validator = validate_condition
+)
+
+#' @export
+#' @rdname base_condition_classes
+#' @format NULL
+#' @order 1
+class_warning <- new_S3_class(
+  c("warning", "condition"),
+  constructor = new_condition_constructor(c("warning", "condition")),
+  validator = validate_condition
+)

_pkgdown.yml

@@ -54,6 +54,7 @@ reference:
   - base_classes
   - class_environment
   - base_s3_classes
+  - base_condition_classes
   - new_S3_class
   - S4_register
 

tests/testthat/_snaps/conditions.md

@@ -0,0 +1,15 @@
+# catches invalid conditions
+
+    Code
+      validate_condition(1)
+    Output
+      [1] "Underlying data must be a <list>"
+    Code
+      validate_condition(structure(list(), class = "condition"))
+    Output
+      [1] "`message` must be a single string"
+    Code
+      validate_condition(structure(list(message = 1), class = "condition"))
+    Output
+      [1] "`message` must be a single string"
+

tests/testthat/test-conditions.R

@@ -0,0 +1,35 @@
+test_that("base condition classes have the right class vectors", {
+  expect_equal(class(class_construct(class_condition)), "condition")
+  expect_equal(class(class_construct(class_error)), c("error", "condition"))
+  expect_equal(
+    class(class_construct(class_warning)),
+    c("warning", "condition")
+  )
+})
+
+test_that("can construct condition subclasses with S7 properties", {
+  my_error := new_class(
+    parent = class_error,
+    properties = list(data = class_numeric),
+    package = NULL
+  )
+  x <- my_error(message = "boom", data = 1:3)
+
+  expect_equal(class(x), c("my_error", "error", "condition", "S7_object"))
+  expect_equal(conditionMessage(x), "boom")
+  expect_equal(x@data, 1:3)
+  expect_equal(validate(x), x)
+
+  caught <- tryCatch(stop(x), my_error = function(e) e)
+  expect_equal(conditionMessage(caught), "boom")
+  expect_equal(caught@data, 1:3)
+})
+
+test_that("catches invalid conditions", {
+  expect_snapshot({
+    validate_condition(1)
+    validate_condition(structure(list(), class = "condition"))
+    validate_condition(structure(list(message = 1), class = "condition"))
+  })
+  expect_null(validate_condition(simpleError("boom")))
+})