Pass ... to parent constructor

NEWS.md

@@ -25,8 +25,9 @@
 * `new_class()` now errors if a child class overrides a parent property with a type that doesn't extend the parent's type, since such a class could never be instantiated. Narrowing the type is still allowed, as are dynamic (getter) properties (#352).
 * `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()` generates a working default constructor for a subclass of a class with a custom constructor: the subclass takes `...` and forwards it to the parent constructor (followed by a named argument for each property the subclass adds), so the parent's argument defaults are matched and evaluated by the parent itself. This is a breaking change: such a subclass constructor no longer exposes the parent's properties as named or positional arguments, only via `...` (#609, #317).
 * `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_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), for creating self-referential or mutually recursive classes (#250), and for extending class from other packages (#317).
 * `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/AAA.R

@@ -14,7 +14,6 @@ new_S7_constructor <- function(f, env = asNamespace("S7")) {
   f
 }
 
-
 `append<-` <- function(x, after, value) {
   if (missing(after)) {
     c(x, value)

R/class.R

@@ -21,6 +21,7 @@
 #'   * An S4 class, like the result of [methods::getClass()].
 #'   * An S3 class wrapped by [new_S3_class()].
 #'   * A base type, like [class_logical], [class_integer], etc.
+#'   * A class from another package, wrapped by [new_external_class()].
 #' @param package Package name. This is automatically resolved if the class is
 #'   defined in a package, and `NULL` otherwise.
 #'
@@ -123,6 +124,15 @@ new_class <- function(
 
   parent <- as_class(parent)
 
+  # We have to resolve at build-time to validate the properties we know.
+  # But we otherwise avoid embedding the resolved parent because its definition
+  # may have changed in between package build time and run time.
+  if (is_external_class(parent)) {
+    parent_resolved <- resolve_external_class_req(parent, package)
+  } else {
+    parent_resolved <- parent
+  }
+
   # Don't check arguments for S7_object
   if (!is.null(parent)) {
     check_can_inherit(parent)
@@ -137,15 +147,15 @@ new_class <- function(
     }
     if (
       abstract &&
-        !((is_class(parent) &&
-          (parent@abstract || parent@name == "S7_object")) ||
-          (is_S4_class(parent) && parent@virtual))
+        !((is_class(parent_resolved) &&
+          (parent_resolved@abstract || parent_resolved@name == "S7_object")) ||
+          (is_S4_class(parent_resolved) && parent_resolved@virtual))
     ) {
       stop2("Abstract classes must have abstract parents.")
     }
   }
 
-  parent_props <- class_properties(parent)
+  parent_props <- class_properties(parent_resolved)
   new_props <- as_properties(properties)
   check_prop_names(new_props)
   check_prop_overrides(new_props, parent_props, name, parent)
@@ -272,7 +282,11 @@ c.S7_class <- function(...) {
 }
 
 can_inherit <- function(x) {
-  is_base_class(x) || is_S3_class(x) || is_class(x) || is_S4_class(x)
+  is_base_class(x) ||
+    is_S3_class(x) ||
+    is_class(x) ||
+    is_S4_class(x) ||
+    is_external_class(x)
 }
 
 check_can_inherit <- function(

R/constructor.R

@@ -53,6 +53,30 @@ new_constructor <- function(
     ))
   }
 
+  # Prefer to inline properties to give better constructor formals, but
+  # that's not always safe
+  if (can_inline(parent)) {
+    constructor_inline(parent, properties, envir, package)
+  } else {
+    constructor_forward(parent, properties, envir, package)
+  }
+}
+
+can_inline <- function(parent) {
+  if (is_external_class(parent)) {
+    # can't inline constructors from external classes
+    FALSE
+  } else if (is_class(parent)) {
+    # can't inline custom constructors (#609)
+    is_default_constructor(parent@constructor)
+  } else if (is_S3_class(parent)) {
+    is_default_constructor(parent$constructor)
+  } else {
+    TRUE
+  }
+}
+
+constructor_inline <- function(parent, properties, envir, package) {
   # We need a name so we get a compact constructor, and the actual function
   # which we'll embed in the constructor's environment
   if (is_class(parent)) {
@@ -97,11 +121,6 @@ new_constructor <- function(
   constr_nms <- setdiff(constr_nms, read_only_override_nms)
   override_nms <- setdiff(override_nms, read_only_override_nms)
 
-  # If parent takes ..., we can't match overrides by name, so pass all args on
-  if ("..." %in% names(arg_info$parent)) {
-    parent_nms <- union(parent_nms, override_nms)
-  }
-
   # Now we can generate the parent and child calls
   parent_call <- new_call(parent_name, as_names(parent_nms))
   new_object <- c(if (!has_S7_symbols(envir, "new_object")) "S7", "new_object")
@@ -116,6 +135,76 @@ new_constructor <- function(
   )
 }
 
+# The forwarding constructor: the child takes `...` and hands it to the parent
+# constructor, so the parent's arguments (and their defaults) are matched and
+# evaluated by the parent itself. Only the child's own properties become named
+# arguments, listed after `...`.
+constructor_forward <- function(parent, properties, envir, package) {
+  # Work out how to refer to and call the parent's constructor:
+  # * `ref`: passed to `new_call()` to build the parent call (a name, or a
+  #   `package`/`name` pair for an external class in another package).
+  # * `name`/`fun`: the constructor to embed in the child's environment (NULL
+  #   for external classes, which are resolved dynamically via `pkg::name`).
+  if (is_external_class(parent)) {
+    resolved <- resolve_external_class_req(parent, package)
+    if (identical(package, parent$package)) {
+      ref <- parent$name
+    } else {
+      ref <- c(parent$package, parent$name)
+    }
+    name <- NULL
+    fun <- NULL
+    parent_props <- attr(resolved, "properties", exact = TRUE) %||% list()
+    parent_formal_nms <- names(formals(resolved))
+  } else if (is_class(parent)) {
+    ref <- name <- parent@name
+    fun <- parent
+    parent_props <- attr(parent, "properties", exact = TRUE) %||% list()
+    parent_formal_nms <- names(formals(parent))
+  } else if (is_S3_class(parent)) {
+    ref <- name <- paste0("new_", parent$class[[1]])
+    fun <- parent$constructor
+    parent_props <- attr(parent, "properties", exact = TRUE) %||% list()
+    parent_formal_nms <- names(formals(fun))
+  } else {
+    # user facing error in S7_class()
+    stop2("Unsupported `parent` type.", call = NULL)
+  }
+
+  # New (non read-only) properties become name-only arguments after `...`.
+  self_props <- properties[!vlapply(properties, prop_is_read_only)]
+  self_nms <- names(self_props)
+  self_args <- as.pairlist(lapply(
+    setNames(, self_nms),
+    function(name) prop_default(self_props[[name]], envir, package)
+  ))
+
+  # Overridden parent properties are passed to *both* the parent (so the child
+  # default wins over the parent default) and new_object() (so the child setter
+  # runs). An override is only forwarded to the parent if it can accept it.
+  override_nms <- intersect(self_nms, names(parent_props))
+  if ("..." %in% parent_formal_nms) {
+    parent_override_nms <- override_nms
+  } else {
+    parent_override_nms <- intersect(override_nms, parent_formal_nms)
+  }
+
+  # Parent(<override = override>, ...)
+  parent_call <- new_call(ref, as_names(c(parent_override_nms, "...")))
+
+  new_object <- c(if (!has_S7_symbols(envir, "new_object")) "S7", "new_object")
+  child_call <- new_call(new_object, c(list(parent_call), as_names(self_nms)))
+
+  # `...` must come first, followed by the child's own properties.
+  constr_args <- as.pairlist(c(alist(... = ), self_args))
+
+  env <- new.env(parent = envir)
+  if (!is.null(name)) {
+    env[[name]] <- fun
+  }
+  new_S7_constructor(new_function(constr_args, child_call), env = env)
+}
+
 constructor_args <- function(
   parent,
   properties = list(),

R/external-class.R

@@ -6,7 +6,7 @@
 #' 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:
+#' External classes are useful in three 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
@@ -25,12 +25,19 @@
 #'   new_class("tree", properties = list(child = NULL | tree_stub))
 #'   ```
 #'
+#' * To use a class from another package as the `parent` of your own class.
+#'   The parent's properties are captured when your class is defined, but its
+#'   constructor is called at run time, so your subclass always builds on the
+#'   installed version of the parent package.
+#'
+#'   ```R
+#'   TheirClass <- new_external_class("theirpkg", "TheirClass")
+#'   new_class("MyClass", parent = TheirClass)
+#'   ```
+#'
 #' 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

tests/testthat/_snaps/class.md

@@ -304,3 +304,4 @@
     Condition
       Error:
       ! No S7 class for base type <pairlist>.
+

tests/testthat/_snaps/constructor.md

@@ -81,3 +81,13 @@
       new_object(foo(...), y = y)
       <environment: 0x0>
 
+# forwarding constructor passes overrides to both parent and object
+
+    Code
+      new_constructor(P, as_properties(list(a = new_property(class_double, default = 99),
+      b = class_double)))
+    Output
+      function (..., a = 99, b = numeric(0)) 
+      new_object(P(a = a, ...), a = a, b = b)
+      <environment: 0x0>
+

tests/testthat/_snaps/external-class.md

@@ -60,3 +60,12 @@
       ! <S7::Holder> object properties are invalid:
       - @child: x must be non-negative
 
+# subclassing errors when the external parent can't be resolved
+
+    Code
+      new_class(name = "Dog", parent = Animal)
+    Condition
+      Error:
+      ! Can't find external class <dep::Animal>:
+      * Package 'dep' needs version 2.0.0, but only 1.0.0 is available.
+

tests/testthat/test-constructor.R

@@ -120,6 +120,72 @@ test_that("can use `...` in parent constructor", {
   expect_equal(bar(y = 2)@x, list())
 })
 
+test_that("subclass forwards `...` to a custom parent constructor (#609)", {
+  # The parent default references a symbol from the parent's own environment,
+  # which the child can't see -- so it must be evaluated by the parent.
+  Parent <- local({
+    secret <- 42L
+    new_class(
+      name = "Parent",
+      properties = list(x = class_integer),
+      constructor = function(x = secret) new_object(S7_object(), x = x)
+    )
+  })
+  Child := new_class(
+    parent = Parent,
+    properties = list(y = class_double)
+  )
+
+  expect_named(formals(Child), c("...", "y"))
+  expect_equal(Child()@x, 42L)
+  expect_equal(Child(10L)@x, 10L) # positional arg forwarded to the parent
+  expect_equal(Child(y = 2)@y, 2) # named child arg is not forwarded
+})
+
+test_that("subclass of a custom S3 parent forwards `...`", {
+  rle2 <- new_S3_class(
+    "rle2",
+    constructor = function(.data = list(), n = integer()) {
+      structure(.data, n = n, class = "rle2")
+    }
+  )
+
+  Child := new_class(parent = rle2, properties = list(z = class_double))
+  expect_named(formals(Child), c("...", "z"))
+  expect_equal(Child(z = 1)@z, 1)
+
+  # S7's own S3 wrappers stay on the inline path
+  Factor := new_class(parent = class_factor)
+  expect_named(formals(Factor), c(".data", "levels"))
+})
+
+test_that("forwarding constructor passes overrides to both parent and object", {
+  P := new_class(
+    package = NULL,
+    properties = list(a = new_property(class_double, default = 1)),
+    constructor = function(a = 1) new_object(S7_object(), a = a)
+  )
+
+  expect_snapshot(
+    new_constructor(
+      P,
+      as_properties(list(
+        a = new_property(class_double, default = 99),
+        b = class_double
+      ))
+    ),
+    transform = scrub_environment
+  )
+
+  C := new_class(
+    parent = P,
+    package = NULL,
+    properties = list(a = new_property(class_double, default = 99))
+  )
+  expect_equal(C()@a, 99) # child default wins over parent default
+  expect_equal(C(a = 5)@a, 5)
+})
+
 test_that("subclass can override simple parent property defaults", {
   foo := new_class(
     properties = list(x = new_property(class_numeric, default = 1))