Re-allow environments as parents (#622)

Now forbidding `S7_data()` and `convert()` instead.

Fixes #590

Author: hadley

NEWS.md

@@ -7,6 +7,7 @@
 * `S7_error_method_not_found` now has a correct class vector without a duplicate `"error"` entry (@jjjermiah, #604).
 * `method<-` now gives a clear error when assigning a primitive function (e.g. `log`) as a method (#608).
 * `method<-` and `method()` now accept a length-1 list as `signature` for single-dispatch generics, matching the list-of-classes form required for multi-dispatch (#555).
+* `new_class()` experimentally allows `class_environment` as a parent again, so you can build S7 objects that share R's reference semantics for environments. This support is provisional: because environments are mutated in place, some operations behave differently than for value-typed S7 objects, and the API may change. `S7_data()` and `S7_data<-()` error on environment-based objects, since they would otherwise destroy the object's S7 attributes in place (#590).
 * `new_object()` now gives an informative error when `.parent` is a class specification rather than an instance of the parent class (#409).
 * `S7_inherits()` and `check_is_S7()` now accept any class specification (S7 class, S7 union, S3 class, S4 class, or base type wrapper like `class_integer`), not just S7 classes (#556).
 * Method dispatch on `class_missing` now correctly handles missing arguments forwarded through a wrapper functions (#595).

R/base-environment.R

@@ -0,0 +1,49 @@
+#' Use an environment as the base type of an S7 class
+#'
+#' @description
+#' \ifelse{html}{
+#' {\figure{lifecycle-experimental.svg}{options: alt='\[Experimental\]'}}}{\strong{\[Experimental\]
+#' }}
+#'
+#' `class_environment` is the [base][base_classes] wrapper for environments.
+#' Unlike all other R objects, environments have reference semantics, i.e., they
+#' are modified in place. It's not clear what all the implications of this are
+#' for S7, so we are marking the use of `class_environment` as experimental.
+#'
+#' Its use is subject to the following caveats:
+#'
+#' * [S7_data()] and `S7_data<-()` error, because swapping the underlying data
+#'   would destroy the existing attributes.
+#'
+#' * The default [convert()] method errors when upcasting to an environment
+#'   because stripping the subclass's properties would mutate `from` in place.
+#'
+#' @export
+#' @examples
+#' Counter <- new_class("Counter", class_environment)
+#' counter <- Counter()
+#' counter$n <- 0L
+#'
+#' # Reference semantics: `copy` and `counter` are the same object, so
+#' # mutating one is visible through the other.
+#' copy <- counter
+#' copy$n <- 10L
+#' counter$n
+class_environment <- NULL
+
+check_not_environment <- function(object, fn) {
+  if (!is.environment(object)) {
+    return(invisible())
+  }
+
+  msg <- paste_c(
+    sprintf("Can't call `%s` on an environment.\n", fn),
+    "See ?class_environment for details."
+  )
+  stop(msg, call. = FALSE)
+}
+
+# Define onload to avoid dependencies between files
+on_load_define_environment <- function() {
+  class_environment <<- new_base_class("environment")
+}

R/base.R

@@ -113,7 +113,9 @@ str.S7_base_class <- function(object, ..., nest.lev = 0) {
 #' * `class_name`
 #' * `class_call`
 #' * `class_function`
-#' * `class_environment` (can only be used for properties)
+#'
+#' See also [class_environment] which is documented separately due to the
+#' complexities introduced by their reference semantics.
 #'
 #' We also include three union types to model numerics, atomics, and vectors
 #' respectively:
@@ -201,12 +203,6 @@ class_call <- new_base_class("call")
 #' @order 1
 class_function <- new_base_class("function", "fun")
 
-#' @export
-#' @rdname base_classes
-#' @format NULL
-#' @order 1
-class_environment <- new_base_class("environment")
-
 #' @export
 #' @rdname base_classes
 #' @format NULL

R/class.R

@@ -250,10 +250,6 @@ check_can_inherit <- function(x, arg = deparse(substitute(x))) {
     )
     stop(msg, call. = FALSE)
   }
-
-  if (is_base_class(x) && x$class == "environment") {
-    stop("Can't inherit from an environment.", call. = FALSE)
-  }
 }
 
 is_class <- function(x) inherits(x, "S7_class")
@@ -349,7 +345,10 @@ str.S7_object <- function(object, ..., nest.lev = 0) {
   cat(if (nest.lev > 0) " ")
   cat(obj_desc(object))
 
-  if (!is_S7_type(object)) {
+  if (is.environment(object)) {
+    # Can't use S7_data() with environments
+    cat(" ", format.default(object), "\n", sep = "")
+  } else if (!is_S7_type(object)) {
     if (!typeof(object) %in% c("numeric", "integer", "character", "double")) {
       cat(" ")
     }

R/convert.R

@@ -98,6 +98,8 @@ convert <- function(from, to, ...) {
 }
 
 convert_up <- function(from, to) {
+  check_not_environment(from, "convert()")
+
   from_class <- S7_class(from)
   if (is.null(from_class)) {
     from_props <- character()

R/data.R

@@ -26,6 +26,7 @@
 #' S7_data(MyDF(data.frame(x = 1, y = 2)))
 S7_data <- function(object) {
   check_is_S7(object)
+  check_not_environment(object, "S7_data()")
 
   out <- zap_attr(object, c(prop_names(object), "class", "S7_class"))
 
@@ -47,6 +48,9 @@ base_parent <- function(class) {
 #' @export
 #' @rdname S7_data
 `S7_data<-` <- function(object, check = TRUE, value) {
+  check_is_S7(object)
+  check_not_environment(object, "S7_data<-")
+
   s7_attrs <- c(prop_names(object), "class", "S7_class")
   for (name in s7_attrs) {
     attr(value, name) <- attr(object, name, exact = TRUE)
@@ -57,7 +61,6 @@ base_parent <- function(class) {
   return(invisible(value))
 }
 
-
 zap_attr <- function(x, names) {
   for (name in names) {
     attr(x, name) <- NULL

R/zzz.R

@@ -140,6 +140,7 @@ methods::setOldClass(c("S7_method", "function", "S7_object"))
 .onLoad <- function(...) {
   activate_backward_compatiblility()
 
+  on_load_define_environment()
   on_load_define_S7_generic()
   on_load_define_S7_method()
   on_load_make_convert_generic()

_pkgdown.yml

@@ -49,6 +49,7 @@ reference:
     classes, and base types. See `vignette("compatibility")` for more details.
   contents:
   - base_classes
+  - class_environment
   - base_s3_classes
   - new_S3_class
   - S4_register