Implement per-property validators

Fixes #275

NEWS.md

@@ -1,13 +1,16 @@
 # S7 (development version)
 
+* `new_property()` gains a `validator` argument that allows you to specify
+  a per-property validator (#275).
+
 * `new_object()` works better when custom property setters modify other 
   properties.
 
 * Properties with a custom setter are now validated _after_ the setter has
   run and are validated when the object is constructed or when you call 
   `validate()`, not just when you modify them after construction.
 
-* In `new_property()` clarify that it's the users responsibility to return
+* In `new_property()` clarify that it's the user's responsibility to return
   the correct class; it is _not_ automatically validated.
 
 * Correctly register S3 methods for S7 objects with a package (#333).

R/property.R

@@ -19,6 +19,17 @@
 #'   If a property has a getter but doesn't have a setter, it is read only.
 #' @param setter An optional function used to set the value. The function
 #'   should take `self` and `value` and return a modified object.
+#' @param validator A function taking a single argument, `value`, the value
+#'   to validate.
+#'
+#'   The job of a validator is to determine whether the property value is valid.
+#'   It should return `NULL` if the object is valid, or if it's not valid,
+#'   a single string describing the problem. The message should not include the
+#'   name of the property as this will be automatically appended to the
+#'   beginning of the message.
+#'
+#'   The validator will be called after the `class` has been verified, so
+#'   your code can assume that `self` has known type.
 #' @param default When an object is created and the property is not supplied,
 #'   what should it default to? If `NULL`, defaults to the "empty" instance
 #'   of `class`.
@@ -69,7 +80,12 @@
 #' hadley@firstName
 #' hadley@firstName <- "John"
 #' hadley@first_name
-new_property <- function(class = class_any, getter = NULL, setter = NULL, default = NULL, name = NULL) {
+new_property <- function(class = class_any,
+                         getter = NULL,
+                         setter = NULL,
+                         validator = NULL,
+                         default = NULL,
+                         name = NULL) {
   class <- as_class(class)
   if (!is.null(default) && !class_inherits(default, class)) {
     msg <- sprintf("`default` must be an instance of %s, not a %s", class_desc(class), obj_desc(default))
@@ -82,12 +98,16 @@ new_property <- function(class = class_any, getter = NULL, setter = NULL, defaul
   if (!is.null(setter)) {
     check_function(setter, alist(self = , value = ))
   }
+  if (!is.null(validator)) {
+    check_function(validator, alist(value = ))
+  }
 
   out <- list(
     name = name,
     class = class,
     getter = getter,
     setter = setter,
+    validator = validator,
     default = default
   )
   class(out) <- "S7_property"
@@ -219,15 +239,25 @@ prop_error_unknown <- function(object, prop_name) {
 
 prop_validate <- function(prop, value, object = NULL) {
   if (!class_inherits(value, prop$class)) {
-    return(sprintf("%s@%s must be %s, not %s",
-      if (!is.null(object)) obj_desc(object) else "",
-      prop$name,
+    sprintf("%s must be %s, not %s",
+      prop_label(object, prop$name),
       class_desc(prop$class),
       obj_desc(value)
-    ))
+    )
+  } else if (!is.null(prop$validator)) {
+    val <- prop$validator(value)
+    if (is.null(val)) {
+      return(NULL)
+    }
+
+    paste0(prop_label(object, prop$name), " ", val)
+  } else {
+    NULL
   }
+}
 
-  NULL
+prop_label <- function(object, name) {
+  sprintf("%s@%s", if (!is.null(object)) obj_desc(object) else "", name)
 }
 
 #' @rdname prop

tests/testthat/_snaps/class.md

@@ -18,17 +18,19 @@
        @ package    : NULL
        @ properties :List of 2
        .. $ x: <S7_property> 
-       ..  ..$ name   : chr "x"
-       ..  ..$ class  : <S7_base_class>: <integer>
-       ..  ..$ getter : NULL
-       ..  ..$ setter : NULL
-       ..  ..$ default: NULL
+       ..  ..$ name     : chr "x"
+       ..  ..$ class    : <S7_base_class>: <integer>
+       ..  ..$ getter   : NULL
+       ..  ..$ setter   : NULL
+       ..  ..$ validator: NULL
+       ..  ..$ default  : NULL
        .. $ y: <S7_property> 
-       ..  ..$ name   : chr "y"
-       ..  ..$ class  : <S7_base_class>: <integer>
-       ..  ..$ getter : NULL
-       ..  ..$ setter : NULL
-       ..  ..$ default: NULL
+       ..  ..$ name     : chr "y"
+       ..  ..$ class    : <S7_base_class>: <integer>
+       ..  ..$ getter   : NULL
+       ..  ..$ setter   : NULL
+       ..  ..$ validator: NULL
+       ..  ..$ default  : NULL
        @ abstract   : logi FALSE
        @ constructor: function (x = class_missing, y = class_missing)  
        @ validator  : NULL

tests/testthat/_snaps/property.md

@@ -73,21 +73,23 @@
       print(x)
     Output
       <S7_property> 
-       $ name   : chr "foo"
-       $ class  : <S7_base_class>: <integer>
-       $ getter : NULL
-       $ setter : NULL
-       $ default: NULL
+       $ name     : chr "foo"
+       $ class    : <S7_base_class>: <integer>
+       $ getter   : NULL
+       $ setter   : NULL
+       $ validator: NULL
+       $ default  : NULL
     Code
       str(list(x))
     Output
       List of 1
        $ : <S7_property> 
-        ..$ name   : chr "foo"
-        ..$ class  : <S7_base_class>: <integer>
-        ..$ getter : NULL
-        ..$ setter : NULL
-        ..$ default: NULL
+        ..$ name     : chr "foo"
+        ..$ class    : <S7_base_class>: <integer>
+        ..$ getter   : NULL
+        ..$ setter   : NULL
+        ..$ validator: NULL
+        ..$ default  : NULL
 
 # properties can be base, S3, S4, S7, or S7 union
 
@@ -156,3 +158,16 @@
     Error <simpleError>
       `properties` names must be unique
 
+# can validate with custom validator
+
+    Code
+      f <- foo(x = 1L)
+      f@x <- 1:2
+    Error <simpleError>
+      <foo>@x must be length 1
+    Code
+      foo(x = 1:2)
+    Error <simpleError>
+      <foo> object properties are invalid:
+      - @x must be length 1
+

tests/testthat/test-property.R

@@ -298,3 +298,19 @@ test_that("as_properties() gives useful error messages", {
     as_properties(list(x = class_character, x = class_character))
   })
 })
+
+test_that("can validate with custom validator", {
+  validate_scalar <- function(value) {
+    if (length(value) != 1) {
+      "must be length 1"
+    }
+  }
+  prop <- new_property(class_integer, validator = validate_scalar)
+  foo <- new_class("foo", properties = list(x = prop))
+  expect_snapshot(error = TRUE, {
+    f <- foo(x = 1L)
+    f@x <- 1:2
+
+    foo(x = 1:2)
+  })
+})