Validation improvements

NAMESPACE

@@ -13,6 +13,7 @@ S3method(str,R7_union)
 export("@")
 export("method<-")
 export("prop<-")
+export("props<-")
 export("r7_data<-")
 export(R7_object)
 export(as_class)
@@ -37,6 +38,7 @@ export(r7_data)
 export(s3_class)
 export(valid_eventually)
 export(valid_implicitly)
+export(validate)
 importFrom(stats,setNames)
 importFrom(utils,getFromNamespace)
 importFrom(utils,getS3method)

NEWS.md

@@ -2,6 +2,10 @@
 
 ## Jan 2020
 
+* New `props<-` for setting multiple properties simultaneously and validating
+  afterwards (#149).
+* Validation now happens recursively, and validates types before validating 
+  the object (#149)
 * Classes (base types, S3, S4, and R7) are handled consistently wherever they
   are used. Strings now only refer to base types. New explicit `s3_class()` for 
   referring to S3 classes (#134).

R/data.R

@@ -5,6 +5,7 @@
 #' and all properties.
 #'
 #' @inheritParams prop
+#' @param value Object used to replace the underlying data.
 #' @export
 #' @examples
 #' text <- new_class("text", parent = "character")

R/object.R

@@ -26,38 +26,16 @@ new_object <- function(.data = NULL, ...) {
   }
 
   if (!is.null(.data)) {
-    # TODO eliminate this special case
-    if (obj_cls@name %in% names(base_types)) {
-      if (!inherits(.data, obj_cls@name)) {
-        stop(sprintf(
-          "`.data` must be %s not %s",
-          class_desc(as_class(obj_cls@name)),
-          obj_desc(.data)
-        ))
-      }
-    } else {
-      if (!class_inherits(.data, obj_cls@parent)) {
-        stop(sprintf(
-          "`.data` must be %s not %s",
-          class_desc(obj_cls@parent),
-          obj_desc(.data)
-        ))
-      }
-    }
-
     object <- .data
   } else {
     object <- obj_cls@parent@constructor()
   }
-  attr(object, ".should_validate") <- FALSE
 
   class(object) <- "R7_object"
   object_class(object) <- obj_cls
   for (nme in nms) {
-    prop(object, nme) <- args[[nme]]
+    prop(object, nme, check = FALSE) <- args[[nme]]
   }
-
-  attr(object, ".should_validate") <- NULL
   validate(object)
 
   object

R/property.R

@@ -80,14 +80,16 @@ str.R7_property <- function(object, ..., nest.lev = 0) {
 #'   rather than throwing an error.
 #' - `prop<-` and `@<-` set a new value for the given property.
 #' - `props()` returns a list of all properties
+#' - `props<-` sets multiple properties at once, validating after all are set
 #' - `prop_names()` returns the names of the properties
 #' - `prop_exists(x, "prop")` returns `TRUE` iif `x` has property `prop`.
 #'
 #' @param object An object from a R7 class
 #' @param name The name of the parameter as a character. Partial matching
 #'   is not performed.
-#' @param value A replacement value for the parameter. The object is
-#'   automatically checked for validity after the replacement is done.
+#' @param value For `prop<-`, a replacement value for the property;
+#'   for `props<-`, a named list of values. The object is automatically
+#'   checked for validity after the replacement is done.
 #' @export
 #' @examples
 #' horse <- new_class("horse", properties = list(
@@ -108,7 +110,7 @@ prop <- function(object, name) {
   if (!inherits(object, "R7_object")) {
     stop("`object` is not an <R7_object>")
   } else if (!prop_exists(object, name)) {
-    stop(sprintf("Can't find property %s@%s", obj_desc(object), name))
+    stop(prop_error_unknown(object, name))
   } else {
     prop_val(object, name)
   }
@@ -172,6 +174,19 @@ props <- function(object) {
   }
 }
 
+#' @rdname prop
+#' @export
+`props<-` <- function(object, value) {
+  stopifnot(is.list(value))
+
+  for (name in names(value)) {
+    prop(object, name, check = FALSE) <- value[[name]]
+  }
+  validate(object)
+
+  object
+}
+
 #' @rdname prop
 #' @export
 prop_exists <- function(object, name) {
@@ -188,29 +203,42 @@ prop_exists <- function(object, name) {
 
   function(object, name, check = TRUE, value) {
     prop <- prop_obj(object, name)
+    if (is.null(prop)) {
+      stop(prop_error_unknown(object, name))
+    }
+
     if (!is.null(prop$setter) && !identical(setter_property, name)) {
       setter_property <<- name
       on.exit(setter_property <<- NULL, add = TRUE)
       object <- prop$setter(object, value)
     } else {
       if (isTRUE(check) && !class_inherits(value, prop$class)) {
-        stop(sprintf("%s@%s must be of class %s, not %s",
-          obj_desc(object), name,
-          class_desc(prop$class),
-          obj_desc(value)
-        ), call. = FALSE)
+        stop(prop_error_type(object, name, prop$class, value), call. = FALSE)
       }
       attr(object, name) <- value
     }
 
     if (isTRUE(check)) {
-      validate(object)
+      validate(object, properties = FALSE)
     }
 
     invisible(object)
   }
 })
 
+prop_error_unknown <- function(object, prop_name) {
+  sprintf("Can't find property %s@%s", obj_desc(object), prop_name)
+}
+
+prop_error_type <- function(object, prop_name, expected, actual) {
+  sprintf("%s@%s must be of class %s, not %s",
+    obj_desc(object),
+    prop_name,
+    class_desc(expected),
+    obj_desc(actual)
+  )
+}
+
 #' @rdname prop
 #' @usage object@name
 #' @export

R/valid.R

@@ -1,41 +1,114 @@
-#' Validation of R7 objects
+#' Validate an R7 object
 #'
-#' [validate()] calls the validation of an R7 object. This is done
-#' automatically when creating new objects (at the end of [new_object]) and
-#' when setting any property.
+#' @description
+#' `validate()` calls the validator of an R7 object. This is done automatically
+#' when creating new objects (at the end of [new_object()]) and when setting
+#' any property with [prop<-].
 #'
-#' [valid_eventually()] disables validation of properties, runs a function on
-#' the object, then validates the object.
+#' `valid_eventually()` disables validation, modifies the object, then
+#' revalidates. This is useful when a sequence of operations would otherwise
+#' lead an object to be temporarily invalid.
 #'
-#' [valid_implicitly()] does the same but does not validate the object at the end.
-#'
-#' [valid_implicitly()] should only be used rarely in performance critical code
-#' where you are certain a sequence of operations cannot produce an invalid
-#' object.
+#' `valid_implicitly()` does the same but does not validate the object at the
+#' end. It should only be used rarely, and in performance critical code where
+#' you are certain a sequence of operations cannot produce an invalid object.
 #' @param object An R7 object
 #' @param fun A function to call on the object before validation.
-validate <- function(object) {
+#' @param properties If `TRUE`, the default, checks property types before
+#'   executing the validator.
+#' @export
+#' @examples
+#' # A range class might validate that the start is less than the end
+#' Range <- new_class("Range",
+#'   properties = list(start = "double", end = "double"),
+#'   validator = function(object) {
+#'     if (object@start >= object@end) "start must be smaller than end"
+#'   }
+#' )
+#' # You can't construct an invalid object:
+#' try(Range(1, 1))
+#'
+#' # And you can't create an invalid object with @<-
+#' r <- Range(1, 2)
+#' try(r@end <- 1)
+#'
+#' # But what if you want to move a range to the right?
+#' rightwards <- function(r, x) {
+#'   r@start <- r@start + x
+#'   r@end <- r@end + x
+#'   r
+#' }
+#' # This function doesn't work because it creates a temporarily invalid state
+#' try(rightwards(r, 10))
+#'
+#' # This is the perfect use case for valid_eventually():
+#' rightwards <- function(r, x) {
+#'   valid_eventually(r, function(object) {
+#'     object@start <- object@start + x
+#'     object@end <- object@end + x
+#'     object
+#'   })
+#' }
+#' rightwards(r, 10)
+#'
+#' # Alternatively, you can set multiple properties at once using props<-
+#' rightwards <- function(r, x) {
+#'   props(r) <- list(start = r@start + x, end = r@end + x)
+#'   r
+#' }
+#' rightwards(r, 20)
+validate <- function(object, properties = TRUE) {
   if (!is.null(attr(object, ".should_validate"))) {
     return(invisible(object))
   }
 
-  obj_class <- object_class(object)
+  class <- object_class(object)
 
-  validator <- prop_safely(obj_class, "validator")
-  if (is.null(validator)) {
-    return(invisible(object))
+  # First, check property types - if these are incorrect, the validator
+  # is likely to return spurious errors
+  if (properties) {
+    errors <- validate_properties(object, class)
+  } else {
+    errors <- character()
   }
 
-  errors <- validator(object)
+  # Next, recursively validate the object
+  if (length(errors) == 0) {
+    while(!is.null(class) && is_class(class)) {
+      errors <- c(errors, class@validator(object))
+      class <- prop_safely(class, "parent")
+    }
+  }
 
+  # If needed, report errors
   if (length(errors) > 0) {
-    msg <- sprintf("Invalid <%s> object:\n%s", obj_class@name, paste0("- ", errors, collapse = "\n"))
+    bullets <- paste0("- ", errors, collapse = "\n")
+    msg <- sprintf("Invalid %s object:\n%s", obj_desc(object), bullets)
     stop(msg, call. = FALSE)
   }
 
   invisible(object)
 }
 
+validate_properties <- function(object, class) {
+  errors <- character()
+
+  for (prop in class@properties) {
+    # Only validate static properties
+    if (!is.null(prop$getter) || !is.null(prop$setter)) {
+      next
+    }
+
+    value <- prop(object, prop$name)
+    if (!class_inherits(value, prop$class)) {
+      errors <- c(errors, prop_error_type(object, prop$name, prop$class, value))
+    }
+    prop
+  }
+
+  errors
+}
+
 #' @rdname validate
 #' @export
 valid_eventually <- function(object, fun) {
@@ -44,6 +117,8 @@ valid_eventually <- function(object, fun) {
   out <- fun(object)
   attr(out, ".should_validate") <- old
   validate(out)
+
+  out
 }
 
 #' @rdname validate

R/zzz.R

@@ -13,7 +13,16 @@ R7_object <- new_class(
 )
 
 new_base_class <- function(name) {
-  R7_class(name = name, constructor = function(.data) new_object(.data))
+  new_class(
+    name = name,
+    constructor = function(.data) new_object(.data),
+    validator = function(object) {
+      data <- unclass(object)
+      if (!name %in% .class2(data)) {
+        sprintf("`.data` must be <%s> not %s", name, obj_desc(data))
+      }
+    }
+  )
 }
 
 # Define simple base types with constructors. See .onLoad() for more
@@ -47,7 +56,7 @@ R7_generic <- new_class(
 
 R7_method <- new_class(
   name = "R7_method",
-  properties = list(generic = R7_generic, signature = "list", fun = "function"),
+  properties = list(generic = R7_generic, signature = "list"),
   parent = "function",
   constructor = function(generic, signature, fun) {
     if (is.character(signature)) {