Implement external classes

NAMESPACE

@@ -17,6 +17,7 @@ S3method(print,S7_S3_class)
 S3method(print,S7_any)
 S3method(print,S7_base_class)
 S3method(print,S7_class)
+S3method(print,S7_external_class)
 S3method(print,S7_external_generic)
 S3method(print,S7_generic)
 S3method(print,S7_method)
@@ -87,6 +88,7 @@ export(method_explain)
 export(methods_register)
 export(new_S3_class)
 export(new_class)
+export(new_external_class)
 export(new_external_generic)
 export(new_generic)
 export(new_object)

NEWS.md

@@ -1,5 +1,6 @@
 # S7 (development version)
 
+* Internal changes to support R-devel (4.6) (#592, #593, #598, #600).
 * 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).
 * `class_POSIXct` uses the `tzone` attribute (not `tz`), and allows it to be absent (#401).
@@ -23,6 +24,7 @@
 * `new_class()` now allows properties named `names`, `dim`, `dimnames`, `class`, `comment`, `tsp`, and `row.names`. But property names beginning with `_` are now reserved for internal use (#579).
 * `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_class()`'s default constructor now respects properties overridden in a subclass: the subclass's default is used (#467) and its setter is run during construction (#585). Values for overridden properties are passed to both the parent constructor and the new object, so a subclass can override a parent property whose default is mandatory.
+* `new_external_class()` creates a delayed reference to an S7 class in another package (or your own package, but not yet defined). It is useful for registering methods on classes from suggested packages (#573) and for creating self-referential or mutually recursive classes (#250).
 * `new_object()` now gives an informative error when `.parent` is a class specification rather than an instance of the parent class (#409).
 * `new_object()` no longer materialises ALTREP parent values (e.g. `seq_len()`), so constructing an S7 object that wraps a large compact integer sequence is now O(1) in memory instead of O(n) (@kschaubroeck, #607).
 * `new_object()` no longer re-runs property validators for properties inherited unchanged from an already-validated parent class, so constructing an instance of a deeply nested class hierarchy validates each property exactly once (#539).

R/class-spec.R

@@ -53,6 +53,7 @@ is_foundation_class <- function(x) {
     is_union(x) ||
     is_base_class(x) ||
     is_S3_class(x) ||
+    is_external_class(x) ||
     is_class_missing(x) ||
     is_class_any(x)
 }
@@ -72,6 +73,8 @@ class_type <- function(x) {
     "S7_union"
   } else if (is_S3_class(x)) {
     "S7_S3"
+  } else if (is_external_class(x)) {
+    "S7_external"
   } else if (is_S4_class(x)) {
     "S4"
   } else {
@@ -90,6 +93,7 @@ class_friendly <- function(x) {
     S7_base = "a base type",
     S7_union = "an S7 union",
     S7_S3 = "an S3 class",
+    S7_external = "an external S7 class",
   )
 }
 
@@ -185,6 +189,7 @@ class_constructor <- function(.x) {
     S7_base = .x$constructor,
     S7_union = class_constructor(.x$classes[[1]]),
     S7_S3 = .x$constructor,
+    S7_external = class_constructor(resolve_external_class_req(.x)),
     stop2(sprintf("Can't construct %s.", class_friendly(.x)), call = NULL)
   )
 }
@@ -199,6 +204,7 @@ class_validate <- function(class, object) {
     S7 = class@validator,
     S7_base = class$validator,
     S7_S3 = class$validator,
+    S7_external = class_validate(resolve_external_class_req(class), object),
     NULL
   )
 
@@ -238,6 +244,7 @@ class_desc <- function(x) {
     S7_base = paste0("<", x$class, ">"),
     S7_union = oxford_or(unlist(lapply(x$classes, class_desc))),
     S7_S3 = paste0("S3<", paste0(x$class, collapse = "/"), ">"),
+    S7_external = paste0("<", x$class_name, ">"),
   )
 }
 
@@ -256,6 +263,7 @@ class_dispatch <- function(x) {
     S7 = c(S7_class_name(x), class_dispatch(x@parent)),
     S7_base = c(x$class, "S7_object"),
     S7_S3 = c(x$class, "S7_object"),
+    S7_external = class_dispatch(resolve_external_class_req(x)),
     stop2("Unsupported class type.", call = NULL)
   )
 }
@@ -271,6 +279,7 @@ class_register <- function(x) {
     S7 = S7_class_name(x),
     S7_base = x$class,
     S7_S3 = x$class[[1]],
+    S7_external = x$class_name,
     stop2("Unsupported class type.", call = NULL)
   )
 }
@@ -290,6 +299,7 @@ class_deparse <- function(x) {
       paste0("new_union(", paste(classes, collapse = ", "), ")")
     },
     S7_S3 = paste0("new_S3_class(", deparse1(x$class), ")"),
+    S7_external = sprintf("new_external_class(%s, %s)", x$package, x$name),
   )
 }
 
@@ -304,6 +314,7 @@ class_inherits <- function(x, what) {
     S7_base = what$class == base_class(x),
     S7_union = any(vlapply(what$classes, class_inherits, x = x)),
     S7_S3 = !isS4(x) && class_dispatch_extends(what$class, class(x)),
+    S7_external = inherits(x, "S7_object") && inherits(x, what$class_name),
   )
 }
 
@@ -334,6 +345,12 @@ class_extends <- function(child, parent) {
       methods::extends(child@className, parent@className)
   } else if (is_class(parent) && parent@name == "S7_object") {
     is_class(child)
+  } else if (is_external_class(child)) {
+    child <- resolve_external_class_req(child)
+    class_extends(child, parent)
+  } else if (is_external_class(parent)) {
+    parent <- resolve_external_class_req(parent)
+    class_extends(child, parent)
   } else {
     # handle S7, S3, and base types.
     class_dispatch_extends(class_dispatch(parent), class_dispatch(child))

R/external-class.R

@@ -0,0 +1,209 @@
+#' Classes in other packages
+#'
+#' @description
+#' An external class is a lightweight placeholder for an S7 class defined in
+#' another package (or in your own package and needed before it's fully
+#' defined). It carries only the package and class name, and is resolved to
+#' the real S7 class when needed.
+#'
+#' External classes are useful in two situations:
+#'
+#' * To register a method for a generic in your package, dispatching on a class
+#'   from a soft dependency. The method will be registered when `pkg` is loaded
+#'   (using the same machinery as [new_external_generic()]).
+#'
+#'   ```R
+#'   SomeClass <- new_external_class("pkg", "SomeClass")
+#'   method(my_generic, SomeClass) <- ...
+#'   ```
+#'
+#' * To refer to a class that hasn't been defined yet, such as a
+#'   self-referential or mutually recursive class.
+#'
+#'   ```R
+#'   tree_stub <- new_external_class("mypkg", "tree")
+#'   new_class("tree", properties = list(child = NULL | tree_stub))
+#'   ```
+#'
+#' Make sure to call [S7_on_load()] in your package's `.onLoad()` so that
+#' deferred method registrations fire when the relevant package is loaded.
+#'
+#' External classes can not currently be used as parents in [new_class()].
+#' We hope to relax that restriction in the near future.
+#'
+#' @param package Package the class is defined in.
+#' @param name Name of the class, as a string.
+#' @inheritParams new_external_generic version
+#' @returns An S7 external class, i.e. a list with S3 class `S7_external_class`.
+#' @export
+#' @examples
+#' # Refer to a class in another package without taking a hard dependency:
+#' Tibble <- new_external_class("tibble", "tbl_df")
+#' Tibble
+#'
+#' # Self-referential class: the `child` property can be another `tree`,
+#' # or `NULL` to terminate the chain.
+#' tree_stub <- new_external_class("mypkg", "tree")
+#' tree <- new_class(
+#'   name = "tree",
+#'   package = "mypkg",
+#'   properties = list(child = NULL | tree_stub)
+#' )
+new_external_class <- function(package, name, version = NULL) {
+  if (!is_string(package)) {
+    stop2("`package` must be a string.")
+  }
+  if (!is_string(name)) {
+    stop2("`name` must be a string.")
+  }
+
+  out <- list(
+    package = package,
+    name = name,
+    class_name = paste0(package, "::", name),
+    version = version
+  )
+  class(out) <- "S7_external_class"
+  out
+}
+
+is_external_class <- function(x) {
+  inherits(x, "S7_external_class")
+}
+
+class_has_external_class <- function(x) {
+  if (is_external_class(x)) {
+    TRUE
+  } else if (is_union(x)) {
+    any(vlapply(x$classes, class_has_external_class))
+  } else {
+    FALSE
+  }
+}
+
+signature_has_external_class <- function(signature) {
+  any(vlapply(signature, class_has_external_class))
+}
+
+class_external_deps <- function(x) {
+  if (is_external_class(x)) {
+    list(x)
+  } else if (is_union(x)) {
+    flatten_external_deps(lapply(x$classes, class_external_deps))
+  } else {
+    list()
+  }
+}
+
+signature_external_deps <- function(signature) {
+  flatten_external_deps(lapply(signature, class_external_deps))
+}
+
+flatten_external_deps <- function(x) {
+  unlist(x, recursive = FALSE, use.names = FALSE)
+}
+
+#' @export
+print.S7_external_class <- function(x, ...) {
+  cat(
+    "<S7_external_class> ",
+    x$class_name,
+    if (!is.null(x$version)) paste0(" (>= ", x$version, ")"),
+    "\n",
+    sep = ""
+  )
+  invisible(x)
+}
+
+dep_available <- function(dep) {
+  isNamespaceLoaded(dep$package) &&
+    (is.null(dep$version) || getNamespaceVersion(dep$package) >= dep$version)
+}
+
+# Make it mockable
+getNamespaceVersion <- NULL
+
+resolve_signature <- function(signature) {
+  for (i in seq_along(signature)) {
+    signature[[i]] <- resolve_class_req(signature[[i]])
+  }
+  signature
+}
+
+resolve_class_req <- function(x) {
+  if (is_external_class(x)) {
+    resolve_external_class_req(x)
+  } else if (is_union(x)) {
+    do.call(new_union, lapply(x$classes, resolve_class_req))
+  } else {
+    x
+  }
+}
+
+find_external_class <- function(x) {
+  ns <- asNamespace(x$package)
+  if (exists(x$name, envir = ns, inherits = FALSE)) {
+    obj <- get(x$name, envir = ns, inherits = FALSE)
+    if (is_external_class_match(obj, x)) {
+      return(obj)
+    }
+  }
+
+  # Also consider cases where the constructor isn't named the same as the class
+  for (name in ls(ns, all.names = TRUE)) {
+    obj <- get(name, envir = ns, inherits = FALSE)
+    if (is_external_class_match(obj, x)) {
+      return(obj)
+    }
+  }
+
+  NULL
+}
+
+is_external_class_match <- function(obj, x) {
+  is_class(obj) &&
+    (identical(S7_class_name(obj), x$class_name) ||
+      (identical(obj@name, x$name) &&
+        (is.null(obj@package) || identical(obj@package, x$package))))
+}
+
+# Required resolution: errors if the external class can't be resolved (e.g.
+# its package isn't loaded). Used wherever we need the real class: registering
+# or looking up methods, checking property overrides in a subclass, and
+# constructing or validating an instance.
+resolve_external_class_req <- function(x) {
+  prefix <- sprintf("Can't find external class <%s>:\n", x$class_name)
+  if (!requireNamespace(x$package, quietly = TRUE)) {
+    stop2(
+      paste0(prefix, sprintf("* Package '%s' is not installed.", x$package)),
+      call = NULL
+    )
+  }
+
+  if (!is.null(x$version) && getNamespaceVersion(x$package) < x$version) {
+    stop2(
+      paste0(
+        prefix,
+        sprintf(
+          "* Package '%s' needs version %s, but only %s is available.",
+          x$package,
+          x$version,
+          getNamespaceVersion(x$package)
+        )
+      ),
+      call = NULL
+    )
+  }
+
+  class <- find_external_class(x)
+  if (is.null(class)) {
+    stop2(
+      paste0(
+        prefix,
+        sprintf("* Packages '%s' doesn't contain '%s'.", x$package, x$name)
+      ),
+      call = NULL
+    )
+  }
+  class
+}