From d4420ac8bd18f7fbd2491b2c12572a6648cc435f Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Sat, 9 Sep 2023 12:23:41 -0500
Subject: [PATCH 01/14] First stab at a dynamic class

---
 R/class-spec.R    | 31 ++++++++++++++++++++++++++-
 R/class.R         |  6 ++++--
 R/constructor.R   | 14 +++++++++---
 R/dynamic-class.R | 54 +++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 99 insertions(+), 6 deletions(-)
 create mode 100644 R/dynamic-class.R

diff --git a/R/class-spec.R b/R/class-spec.R
index d3237383..3d8f9dc2 100644
--- a/R/class-spec.R
+++ b/R/class-spec.R
@@ -6,6 +6,7 @@
 #'
 #' @param x A class specification. One of the following:
 #'   * An S7 class (created by [new_class()]).
+#'   * A dynamic S7 class (created by [new_dynamic_class()]).
 #'   * An S7 union (created by [new_union()]).
 #'   * An S3 class (created by [new_S3_class()]).
 #'   * An S4 class (created by [methods::getClass()] or [methods::new()]).
@@ -41,7 +42,8 @@ is_foundation_class <- function(x) {
     is_base_class(x) ||
     is_S3_class(x) ||
     is_class_missing(x) ||
-    is_class_any(x)
+    is_class_any(x) ||
+    is_dynamic_class(x)
 }
 
 class_type <- function(x) {
@@ -57,6 +59,8 @@ class_type <- function(x) {
     "S7"
   } else if (is_union(x)) {
     "S7_union"
+  } else if (is_dynamic_class(x)) {
+    "S7_dynamic"
   } else if (is_S3_class(x)) {
     "S7_S3"
   } else if (is_S4_class(x)) {
@@ -75,6 +79,7 @@ class_friendly <- function(x) {
     S7 = "an S7 class",
     S7_base = "a base type",
     S7_union = "an S7 union",
+    S7_dynamic = "a dynamic S7 class",
     S7_S3 = "an S3 class",
   )
 }
@@ -88,6 +93,7 @@ class_constructor <- function(.x, ...) {
     S7_base = .x$constructor,
     S7_union = class_constructor(.x$classes[[1]]),
     S7_S3 = .x$constructor,
+    S7_dynamic = .x$constructor_fun(),
     stop(sprintf("Can't construct %s", class_friendly(.x)), call. = FALSE)
   )
 }
@@ -100,6 +106,7 @@ class_validate <- function(class, object) {
     S4 = methods::validObject,
     S7 = class@validator,
     S7_base = class$validator,
+    S7_dynamic = class$constructor_fun()@validator,
     S7_S3 = class$validator,
     NULL
   )
@@ -120,6 +127,7 @@ class_desc <- function(x) {
     S7 = paste0("<", S7_class_name(x), ">"),
     S7_base = paste0("<", x$class, ">"),
     S7_union = oxford_or(unlist(lapply(x$classes, class_desc))),
+    S7_dynamic = paste0("<dyn:", S7_class_name(x$constructor_fun()), ">"),
     S7_S3 = paste0("S3<", paste0(x$class, collapse = "/"), ">"),
   )
 }
@@ -137,6 +145,7 @@ class_dispatch <- function(x) {
     S4 = S4_class_dispatch(methods::extends(x)),
     S7 = c(S7_class_name(x), class_dispatch(x@parent)),
     S7_base = c(x$class, "S7_object"),
+    S7_dynamic = class_dispatch(x$constructor_fun()),
     S7_S3 = c(x$class, "S7_object"),
     stop("Unsupported")
   )
@@ -189,6 +198,26 @@ class_inherits <- function(x, what) {
   )
 }
 
+# dynamic class -----------------------------------------------------------
+
+class_constructor_args <- function(x) {
+  if (is_dynamic_class(x)) {
+    x$constructor_args
+  } else {
+    names2(formals(class_constructor(x)))
+  }
+}
+
+class_properties <- function(x) {
+  if (is_dynamic_class(x)) {
+    x$properties
+  } else {
+    attr(x, "properties", exact = TRUE) %||% list()
+  }
+}
+
+# object ------------------------------------------------------------------
+
 obj_type <- function(x) {
   if (identical(x, quote(expr = ))) {
     "missing"
diff --git a/R/class.R b/R/class.R
index e0404df8..c3742f1c 100644
--- a/R/class.R
+++ b/R/class.R
@@ -128,7 +128,7 @@ new_class <- function(
   }
 
   # Combine properties from parent, overriding as needed
-  all_props <- attr(parent, "properties", exact = TRUE) %||% list()
+  all_props <- class_properties(parent)
   new_props <- as_properties(properties)
   all_props[names(new_props)] <- new_props
 
@@ -207,7 +207,9 @@ c.S7_class <- function(...) {
   stop(msg, call. = FALSE)
 }
 
-can_inherit <- function(x) is_base_class(x) || is_S3_class(x) || is_class(x)
+can_inherit <- function(x) {
+  is_base_class(x) || is_S3_class(x) || is_class(x) || is_dynamic_class(x)
+}
 
 check_can_inherit <- function(x, arg = deparse(substitute(x))) {
   if (!can_inherit(x)) {
diff --git a/R/constructor.R b/R/constructor.R
index d71f0fd1..33f340bf 100644
--- a/R/constructor.R
+++ b/R/constructor.R
@@ -21,6 +21,10 @@ new_constructor <- function(parent, properties) {
     parent_name <- parent@name
     parent_fun <- parent
     args <- missing_args(union(arg_info$parent, arg_info$self))
+  } else if (is_dynamic_class(parent)) {
+    parent_name <- parent$name
+    parent_fun <- parent$constructor_fun
+    args <- missing_args(union(arg_info$parent, arg_info$self))
   } else if (is_base_class(parent)) {
     parent_name <- parent$constructor_name
     parent_fun <- parent$constructor
@@ -45,13 +49,17 @@ new_constructor <- function(parent, properties) {
   body <- new_call("new_object", c(parent_call, self_args))
 
   env <- new.env(parent = asNamespace("S7"))
-  env[[parent_name]] <- parent_fun
+  if (!is_dynamic_class(parent)) {
+    env[[parent_name]] <- parent_fun
+  } else {
+    makeActiveBinding(parent_name, parent_fun, env)
+  }
 
   new_function(args, body, env)
 }
 
 constructor_args <- function(parent, properties = list()) {
-  parent_args <- names2(formals(class_constructor(parent)))
+  parent_args <- class_constructor_args(parent)
 
   self_args <- names2(properties)
   # Remove dynamic arguments
@@ -59,7 +67,7 @@ constructor_args <- function(parent, properties = list()) {
   if (is_class(parent) && !parent@abstract) {
     # Remove any parent properties; can't use parent_args() since the constructor
     # might automatically set some properties.
-    self_args <- setdiff(self_args, names2(parent@properties))
+    self_args <- setdiff(self_args, names2(class_properties(parent)))
   }
 
   list(
diff --git a/R/dynamic-class.R b/R/dynamic-class.R
new file mode 100644
index 00000000..e5a908de
--- /dev/null
+++ b/R/dynamic-class.R
@@ -0,0 +1,54 @@
+#' @examples
+#' foo <- new_class("foo", properties = list(x = class_integer))
+#' foo_ex <- new_dynamic_class(function() foo)
+#' foo2 <- new_class("foo", parent = foo_ex)
+#' foo2()
+#'
+#' foo <- new_class("foo", properties = list(x = class_integer))
+#' foo_ex <- new_dynamic_class(function() foo)
+#'
+new_dynamic_class <- function(constructor_fun,
+                              name = NULL,
+                              properties = NULL,
+                              constructor_args = NULL) {
+  check_function(constructor_fun, alist())
+
+  if (is.null(name)) {
+    name <- constructor_fun()@name
+  } else {
+    check_name(name)
+  }
+
+  # Must be initialized before properties
+  if (is.null(constructor_args)) {
+    if (is.null(properties)) {
+      constructor_args <- names(properties)
+    } else {
+      constructor_args <- class_constructor_args(constructor_fun())
+    }
+  } else {
+    if (!is.character(constructor_args)) {
+      stop("`constructor_args` must be a character vector")
+    }
+  }
+
+  if (is.null(properties)) {
+    properties <- class_properties(constructor_fun())
+  } else {
+    properties <- as_properties(properties)
+  }
+
+
+  out <- list(
+    name = name,
+    constructor_fun = constructor_fun,
+    constructor_args = constructor_args,
+    properties = properties
+  )
+  class(out) <- "S7_dynamic_class"
+  out
+}
+
+is_dynamic_class <- function(x) {
+  inherits(x, "S7_dynamic_class")
+}

From 99ff6f940f4c5b667633af40191fe8454d9d0b9e Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Sun, 10 Sep 2023 12:36:57 -0500
Subject: [PATCH 02/14] Use a dynamic constructor

---
 R/class.R       |  3 ++-
 R/constructor.R | 22 ++++++++++++++++++----
 2 files changed, 20 insertions(+), 5 deletions(-)

diff --git a/R/class.R b/R/class.R
index c3742f1c..171a0437 100644
--- a/R/class.R
+++ b/R/class.R
@@ -235,7 +235,8 @@ is_class <- function(x) inherits(x, "S7_class")
 #' @rdname new_class
 #' @export
 new_object <- function(.parent, ...) {
-  class <- sys.function(-1)
+  class <- sys.function(sys.parent())
+
   if (!inherits(class, "S7_class")) {
     stop("`new_object()` must be called from within a constructor")
   }
diff --git a/R/constructor.R b/R/constructor.R
index 33f340bf..25dd3847 100644
--- a/R/constructor.R
+++ b/R/constructor.R
@@ -16,15 +16,14 @@ new_constructor <- function(parent, properties) {
       env = asNamespace("S7")
     ))
   }
+  if (is_dynamic_class(parent)) {
+    return(dynamic_constructor(parent$constructor_fun, properties))
+  }
 
   if (is_class(parent)) {
     parent_name <- parent@name
     parent_fun <- parent
     args <- missing_args(union(arg_info$parent, arg_info$self))
-  } else if (is_dynamic_class(parent)) {
-    parent_name <- parent$name
-    parent_fun <- parent$constructor_fun
-    args <- missing_args(union(arg_info$parent, arg_info$self))
   } else if (is_base_class(parent)) {
     parent_name <- parent$constructor_name
     parent_fun <- parent$constructor
@@ -58,6 +57,21 @@ new_constructor <- function(parent, properties) {
   new_function(args, body, env)
 }
 
+dynamic_constructor <- function(constructor_fun, properties) {
+  force(constructor_fun)
+  force(properties)
+
+  function(...) {
+    parent_class <- constructor_fun()
+    args_info <- constructor_args(parent_class, properties)
+
+    args <- as.list(substitute(...()))
+
+    parent_obj <- do.call("parent_class", args[args_info$parent_args])
+    do.call("new_object", c(list(parent_obj), args[args_info$self_args]))
+  }
+}
+
 constructor_args <- function(parent, properties = list()) {
   parent_args <- class_constructor_args(parent)
 

From b64a2c3efb8ee781c6b8648370612c4c28833edf Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Sun, 10 Sep 2023 12:38:50 -0500
Subject: [PATCH 03/14] No longer need to cache constructor args

---
 R/class-spec.R    |  8 --------
 R/constructor.R   |  2 +-
 R/dynamic-class.R | 21 +--------------------
 3 files changed, 2 insertions(+), 29 deletions(-)

diff --git a/R/class-spec.R b/R/class-spec.R
index 3d8f9dc2..1267f4f4 100644
--- a/R/class-spec.R
+++ b/R/class-spec.R
@@ -200,14 +200,6 @@ class_inherits <- function(x, what) {
 
 # dynamic class -----------------------------------------------------------
 
-class_constructor_args <- function(x) {
-  if (is_dynamic_class(x)) {
-    x$constructor_args
-  } else {
-    names2(formals(class_constructor(x)))
-  }
-}
-
 class_properties <- function(x) {
   if (is_dynamic_class(x)) {
     x$properties
diff --git a/R/constructor.R b/R/constructor.R
index 25dd3847..e40d3af8 100644
--- a/R/constructor.R
+++ b/R/constructor.R
@@ -73,7 +73,7 @@ dynamic_constructor <- function(constructor_fun, properties) {
 }
 
 constructor_args <- function(parent, properties = list()) {
-  parent_args <- class_constructor_args(parent)
+  parent_args <- names2(formals(class_constructor(parent)))
 
   self_args <- names2(properties)
   # Remove dynamic arguments
diff --git a/R/dynamic-class.R b/R/dynamic-class.R
index e5a908de..c6d37128 100644
--- a/R/dynamic-class.R
+++ b/R/dynamic-class.R
@@ -4,13 +4,9 @@
 #' foo2 <- new_class("foo", parent = foo_ex)
 #' foo2()
 #'
-#' foo <- new_class("foo", properties = list(x = class_integer))
-#' foo_ex <- new_dynamic_class(function() foo)
-#'
 new_dynamic_class <- function(constructor_fun,
                               name = NULL,
-                              properties = NULL,
-                              constructor_args = NULL) {
+                              properties = NULL) {
   check_function(constructor_fun, alist())
 
   if (is.null(name)) {
@@ -19,30 +15,15 @@ new_dynamic_class <- function(constructor_fun,
     check_name(name)
   }
 
-  # Must be initialized before properties
-  if (is.null(constructor_args)) {
-    if (is.null(properties)) {
-      constructor_args <- names(properties)
-    } else {
-      constructor_args <- class_constructor_args(constructor_fun())
-    }
-  } else {
-    if (!is.character(constructor_args)) {
-      stop("`constructor_args` must be a character vector")
-    }
-  }
-
   if (is.null(properties)) {
     properties <- class_properties(constructor_fun())
   } else {
     properties <- as_properties(properties)
   }
 
-
   out <- list(
     name = name,
     constructor_fun = constructor_fun,
-    constructor_args = constructor_args,
     properties = properties
   )
   class(out) <- "S7_dynamic_class"

From 03618f89f193855628c9d51cbbdb2fc32ea42526 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Sun, 10 Sep 2023 12:41:52 -0500
Subject: [PATCH 04/14] Dynamic -> external

---
 R/class-spec.R                          | 22 +++++++++++-----------
 R/class.R                               |  2 +-
 R/constructor.R                         |  4 ++--
 R/{dynamic-class.R => external-class.R} | 10 +++++-----
 man/as_class.Rd                         |  1 +
 5 files changed, 20 insertions(+), 19 deletions(-)
 rename R/{dynamic-class.R => external-class.R} (75%)

diff --git a/R/class-spec.R b/R/class-spec.R
index 1267f4f4..e6e748c4 100644
--- a/R/class-spec.R
+++ b/R/class-spec.R
@@ -6,7 +6,7 @@
 #'
 #' @param x A class specification. One of the following:
 #'   * An S7 class (created by [new_class()]).
-#'   * A dynamic S7 class (created by [new_dynamic_class()]).
+#'   * An external S7 class (created by [new_external_class()]).
 #'   * An S7 union (created by [new_union()]).
 #'   * An S3 class (created by [new_S3_class()]).
 #'   * An S4 class (created by [methods::getClass()] or [methods::new()]).
@@ -43,7 +43,7 @@ is_foundation_class <- function(x) {
     is_S3_class(x) ||
     is_class_missing(x) ||
     is_class_any(x) ||
-    is_dynamic_class(x)
+    is_external_class(x)
 }
 
 class_type <- function(x) {
@@ -59,8 +59,8 @@ class_type <- function(x) {
     "S7"
   } else if (is_union(x)) {
     "S7_union"
-  } else if (is_dynamic_class(x)) {
-    "S7_dynamic"
+  } else if (is_external_class(x)) {
+    "S7_external"
   } else if (is_S3_class(x)) {
     "S7_S3"
   } else if (is_S4_class(x)) {
@@ -79,7 +79,7 @@ class_friendly <- function(x) {
     S7 = "an S7 class",
     S7_base = "a base type",
     S7_union = "an S7 union",
-    S7_dynamic = "a dynamic S7 class",
+    S7_external = "an external S7 class",
     S7_S3 = "an S3 class",
   )
 }
@@ -93,7 +93,7 @@ class_constructor <- function(.x, ...) {
     S7_base = .x$constructor,
     S7_union = class_constructor(.x$classes[[1]]),
     S7_S3 = .x$constructor,
-    S7_dynamic = .x$constructor_fun(),
+    S7_external = .x$constructor_fun(),
     stop(sprintf("Can't construct %s", class_friendly(.x)), call. = FALSE)
   )
 }
@@ -106,7 +106,7 @@ class_validate <- function(class, object) {
     S4 = methods::validObject,
     S7 = class@validator,
     S7_base = class$validator,
-    S7_dynamic = class$constructor_fun()@validator,
+    S7_external = class$constructor_fun()@validator,
     S7_S3 = class$validator,
     NULL
   )
@@ -127,7 +127,7 @@ class_desc <- function(x) {
     S7 = paste0("<", S7_class_name(x), ">"),
     S7_base = paste0("<", x$class, ">"),
     S7_union = oxford_or(unlist(lapply(x$classes, class_desc))),
-    S7_dynamic = paste0("<dyn:", S7_class_name(x$constructor_fun()), ">"),
+    S7_external = paste0("<ext:", S7_class_name(x$constructor_fun()), ">"),
     S7_S3 = paste0("S3<", paste0(x$class, collapse = "/"), ">"),
   )
 }
@@ -145,7 +145,7 @@ class_dispatch <- function(x) {
     S4 = S4_class_dispatch(methods::extends(x)),
     S7 = c(S7_class_name(x), class_dispatch(x@parent)),
     S7_base = c(x$class, "S7_object"),
-    S7_dynamic = class_dispatch(x$constructor_fun()),
+    S7_external = class_dispatch(x$constructor_fun()),
     S7_S3 = c(x$class, "S7_object"),
     stop("Unsupported")
   )
@@ -198,10 +198,10 @@ class_inherits <- function(x, what) {
   )
 }
 
-# dynamic class -----------------------------------------------------------
+# S7_external class -----------------------------------------------------------
 
 class_properties <- function(x) {
-  if (is_dynamic_class(x)) {
+  if (is_external_class(x)) {
     x$properties
   } else {
     attr(x, "properties", exact = TRUE) %||% list()
diff --git a/R/class.R b/R/class.R
index 171a0437..db708dfb 100644
--- a/R/class.R
+++ b/R/class.R
@@ -208,7 +208,7 @@ c.S7_class <- function(...) {
 }
 
 can_inherit <- function(x) {
-  is_base_class(x) || is_S3_class(x) || is_class(x) || is_dynamic_class(x)
+  is_base_class(x) || is_S3_class(x) || is_class(x) || is_external_class(x)
 }
 
 check_can_inherit <- function(x, arg = deparse(substitute(x))) {
diff --git a/R/constructor.R b/R/constructor.R
index e40d3af8..7db1ed78 100644
--- a/R/constructor.R
+++ b/R/constructor.R
@@ -16,7 +16,7 @@ new_constructor <- function(parent, properties) {
       env = asNamespace("S7")
     ))
   }
-  if (is_dynamic_class(parent)) {
+  if (is_external_class(parent)) {
     return(dynamic_constructor(parent$constructor_fun, properties))
   }
 
@@ -48,7 +48,7 @@ new_constructor <- function(parent, properties) {
   body <- new_call("new_object", c(parent_call, self_args))
 
   env <- new.env(parent = asNamespace("S7"))
-  if (!is_dynamic_class(parent)) {
+  if (!is_external_class(parent)) {
     env[[parent_name]] <- parent_fun
   } else {
     makeActiveBinding(parent_name, parent_fun, env)
diff --git a/R/dynamic-class.R b/R/external-class.R
similarity index 75%
rename from R/dynamic-class.R
rename to R/external-class.R
index c6d37128..9d98c4bb 100644
--- a/R/dynamic-class.R
+++ b/R/external-class.R
@@ -1,10 +1,10 @@
 #' @examples
 #' foo <- new_class("foo", properties = list(x = class_integer))
-#' foo_ex <- new_dynamic_class(function() foo)
+#' foo_ex <- new_external_class(function() foo)
 #' foo2 <- new_class("foo", parent = foo_ex)
 #' foo2()
 #'
-new_dynamic_class <- function(constructor_fun,
+new_external_class <- function(constructor_fun,
                               name = NULL,
                               properties = NULL) {
   check_function(constructor_fun, alist())
@@ -26,10 +26,10 @@ new_dynamic_class <- function(constructor_fun,
     constructor_fun = constructor_fun,
     properties = properties
   )
-  class(out) <- "S7_dynamic_class"
+  class(out) <- "S7_external_class"
   out
 }
 
-is_dynamic_class <- function(x) {
-  inherits(x, "S7_dynamic_class")
+is_external_class <- function(x) {
+  inherits(x, "S7_external_class")
 }
diff --git a/man/as_class.Rd b/man/as_class.Rd
index 0d8d6f1a..89ba121c 100644
--- a/man/as_class.Rd
+++ b/man/as_class.Rd
@@ -10,6 +10,7 @@ as_class(x, arg = deparse(substitute(x)))
 \item{x}{A class specification. One of the following:
 \itemize{
 \item An S7 class (created by \code{\link[=new_class]{new_class()}}).
+\item An external S7 class (created by \code{\link[=new_external_class]{new_external_class()}}).
 \item An S7 union (created by \code{\link[=new_union]{new_union()}}).
 \item An S3 class (created by \code{\link[=new_S3_class]{new_S3_class()}}).
 \item An S4 class (created by \code{\link[methods:getClass]{methods::getClass()}} or \code{\link[methods:new]{methods::new()}}).

From 45d51b82ba6e8e869d75acf25c0f06fcf02853da Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Sun, 10 Sep 2023 12:58:44 -0500
Subject: [PATCH 05/14] Add basic docs & print method

---
 NAMESPACE                               |  2 +
 R/class-spec.R                          |  9 ++--
 R/external-class.R                      | 59 ++++++++++++++++++-------
 _pkgdown.yml                            |  6 ++-
 man/new_external_class.Rd               | 38 ++++++++++++++++
 tests/testthat/_snaps/external-class.md |  7 +++
 tests/testthat/test-external-class.R    |  4 ++
 7 files changed, 104 insertions(+), 21 deletions(-)
 create mode 100644 man/new_external_class.Rd
 create mode 100644 tests/testthat/_snaps/external-class.md
 create mode 100644 tests/testthat/test-external-class.R

diff --git a/NAMESPACE b/NAMESPACE
index 20490a91..b148c152 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -14,6 +14,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)
@@ -68,6 +69,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)
diff --git a/R/class-spec.R b/R/class-spec.R
index e6e748c4..4db8b037 100644
--- a/R/class-spec.R
+++ b/R/class-spec.R
@@ -127,7 +127,7 @@ class_desc <- function(x) {
     S7 = paste0("<", S7_class_name(x), ">"),
     S7_base = paste0("<", x$class, ">"),
     S7_union = oxford_or(unlist(lapply(x$classes, class_desc))),
-    S7_external = paste0("<ext:", S7_class_name(x$constructor_fun()), ">"),
+    S7_external = paste0("<", x$package, "::", x$name, ">"),
     S7_S3 = paste0("S3<", paste0(x$class, collapse = "/"), ">"),
   )
 }
@@ -191,6 +191,7 @@ class_inherits <- function(x, what) {
     S7 = inherits(x, "S7_object") && inherits(x, S7_class_name(what)),
     S7_base = what$class == base_class(x),
     S7_union = any(vlapply(what$classes, class_inherits, x = x)),
+    S7_external = class_inherits(x, what$constructor_fun()),
     # This is slightly too crude as we really want them to be in the same
     # order and contiguous, but it's probably close enough for practical
     # purposes
@@ -202,10 +203,10 @@ class_inherits <- function(x, what) {
 
 class_properties <- function(x) {
   if (is_external_class(x)) {
-    x$properties
-  } else {
-    attr(x, "properties", exact = TRUE) %||% list()
+    x <- x$constructor_fun()
   }
+
+  attr(x, "properties", exact = TRUE) %||% list()
 }
 
 # object ------------------------------------------------------------------
diff --git a/R/external-class.R b/R/external-class.R
index 9d98c4bb..d18e2f05 100644
--- a/R/external-class.R
+++ b/R/external-class.R
@@ -1,35 +1,62 @@
+#' Classes from other packages
+#'
+#' @description
+#' You need an explicit external class when you want extend a class defined in
+#' another package. An external class ensures that the class definition from
+#' the other package is not literally inlined in your package, ensuring that
+#' when the other package changes your package doesn't need to be rebuilt to
+#' get those changes.
+#'
+#' Extending a class creates a hard requirement on the package that defines it;
+#' i.e. you must list the package in the `Imports` field in your package's
+#' `DESCRIPTION`.
+#'
+#' @param package Package the class is defined in.
+#' @param name Name of class, as a string.
+#' @param constructor_fun A zero-argument function that yields the constructor
+#'   of the external class. For expert use only.
+#' @returns An S7 external class, i.e. a list with class
+#'   `S7_external_class`.
+#' @export
 #' @examples
 #' foo <- new_class("foo", properties = list(x = class_integer))
-#' foo_ex <- new_external_class(function() foo)
+#' foo_ex <- new_external_class("S7", "foo", function() foo)
+#'
 #' foo2 <- new_class("foo", parent = foo_ex)
 #' foo2()
-#'
-new_external_class <- function(constructor_fun,
-                              name = NULL,
-                              properties = NULL) {
-  check_function(constructor_fun, alist())
+new_external_class <- function(package,
+                               name,
+                               constructor_fun = NULL) {
 
-  if (is.null(name)) {
-    name <- constructor_fun()@name
-  } else {
-    check_name(name)
-  }
+  check_name(package)
+  check_name(name)
 
-  if (is.null(properties)) {
-    properties <- class_properties(constructor_fun())
+  if (is.null(constructor_fun)) {
+    constructor_fun <- function() getExportedValue(package, name)
   } else {
-    properties <- as_properties(properties)
+    check_function(constructor_fun, alist())
   }
 
   out <- list(
+    package = package,
     name = name,
-    constructor_fun = constructor_fun,
-    properties = properties
+    constructor_fun = constructor_fun
   )
   class(out) <- "S7_external_class"
   out
 }
 
+#' @export
+print.S7_external_class <- function(x, ...) {
+  cat(
+    "<S7_external_class> ",
+    x$package, "::", x$name, "\n",
+    sep = ""
+  )
+  invisible(x)
+}
+
+
 is_external_class <- function(x) {
   inherits(x, "S7_external_class")
 }
diff --git a/_pkgdown.yml b/_pkgdown.yml
index 3a0e795e..73e8bc01 100644
--- a/_pkgdown.yml
+++ b/_pkgdown.yml
@@ -29,13 +29,17 @@ reference:
   - method
   - method_explain
   - methods_register
-  - new_external_generic
   - new_S3_class
   - S4_register
   - S7_class
   - base_classes
   - class_missing
 
+- title: Packages
+  contents:
+  - new_external_class
+  - new_external_generic
+
 articles:
 - title: Learn S7
   navbar: ~
diff --git a/man/new_external_class.Rd b/man/new_external_class.Rd
new file mode 100644
index 00000000..b7cf0b3b
--- /dev/null
+++ b/man/new_external_class.Rd
@@ -0,0 +1,38 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/external-class.R
+\name{new_external_class}
+\alias{new_external_class}
+\title{Classes from other packages}
+\usage{
+new_external_class(package, name, constructor_fun = NULL)
+}
+\arguments{
+\item{package}{Package the class is defined in.}
+
+\item{name}{Name of class, as a string.}
+
+\item{constructor_fun}{A zero-argument function that yields the constructor
+of the external class. For expert use only.}
+}
+\value{
+An S7 external class, i.e. a list with class
+\code{S7_external_class}.
+}
+\description{
+You need an explicit external class when you want extend a class defined in
+another package. An external class ensures that the class definition from
+the other package is not literally inlined in your package, ensuring that
+when the other package changes your package doesn't need to be rebuilt to
+get those changes.
+
+Extending a class creates a hard requirement on the package that defines it;
+i.e. you must list the package in the \code{Imports} field in your package's
+\code{DESCRIPTION}.
+}
+\examples{
+foo <- new_class("foo", properties = list(x = class_integer))
+foo_ex <- new_external_class("S7", "foo", function() foo)
+
+foo2 <- new_class("foo", parent = foo_ex)
+foo2()
+}
diff --git a/tests/testthat/_snaps/external-class.md b/tests/testthat/_snaps/external-class.md
new file mode 100644
index 00000000..261ad5ac
--- /dev/null
+++ b/tests/testthat/_snaps/external-class.md
@@ -0,0 +1,7 @@
+# displays nicely
+
+    Code
+      print(foo)
+    Output
+      <S7_external_class> package::name
+
diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R
new file mode 100644
index 00000000..46b6c319
--- /dev/null
+++ b/tests/testthat/test-external-class.R
@@ -0,0 +1,4 @@
+test_that("displays nicely", {
+  foo <- new_external_class("package", "name", function() NULL)
+  expect_snapshot(print(foo))
+})

From 9417ed763c8877542b60b9dc71c9bca943b2e405 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Sun, 10 Sep 2023 12:58:51 -0500
Subject: [PATCH 06/14] Remove remnant of old approach

---
 R/constructor.R | 6 +-----
 1 file changed, 1 insertion(+), 5 deletions(-)

diff --git a/R/constructor.R b/R/constructor.R
index 7db1ed78..3c309850 100644
--- a/R/constructor.R
+++ b/R/constructor.R
@@ -48,11 +48,7 @@ new_constructor <- function(parent, properties) {
   body <- new_call("new_object", c(parent_call, self_args))
 
   env <- new.env(parent = asNamespace("S7"))
-  if (!is_external_class(parent)) {
-    env[[parent_name]] <- parent_fun
-  } else {
-    makeActiveBinding(parent_name, parent_fun, env)
-  }
+  env[[parent_name]] <- parent_fun
 
   new_function(args, body, env)
 }

From be8611628092f4b29848408426c89b0878fc22f0 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Sun, 10 Sep 2023 13:02:57 -0500
Subject: [PATCH 07/14] Check constructor_fun yields a constructor

---
 R/external-class.R                   | 5 +++++
 tests/testthat/test-external-class.R | 2 +-
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/R/external-class.R b/R/external-class.R
index d18e2f05..6243bcf0 100644
--- a/R/external-class.R
+++ b/R/external-class.R
@@ -37,6 +37,11 @@ new_external_class <- function(package,
     check_function(constructor_fun, alist())
   }
 
+  constructor <- constructor_fun()
+  if (!is_class(constructor)) {
+    stop("`constructor_fun()` must yield an S7 class")
+  }
+
   out <- list(
     package = package,
     name = name,
diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R
index 46b6c319..9c044334 100644
--- a/tests/testthat/test-external-class.R
+++ b/tests/testthat/test-external-class.R
@@ -1,4 +1,4 @@
 test_that("displays nicely", {
-  foo <- new_external_class("package", "name", function() NULL)
+  foo <- new_external_class("package", "name", function() new_class("foo"))
   expect_snapshot(print(foo))
 })

From ec4d621c649aec4daba03ecee0cb1701542bd7fa Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Sun, 10 Sep 2023 13:13:45 -0500
Subject: [PATCH 08/14] Add tests and fix broken code

---
 R/constructor.R                   |  7 +++----
 tests/testthat/test-class.R       |  8 ++++++++
 tests/testthat/test-constructor.R | 10 ++++++++++
 3 files changed, 21 insertions(+), 4 deletions(-)

diff --git a/R/constructor.R b/R/constructor.R
index 3c309850..e0607165 100644
--- a/R/constructor.R
+++ b/R/constructor.R
@@ -61,10 +61,9 @@ dynamic_constructor <- function(constructor_fun, properties) {
     parent_class <- constructor_fun()
     args_info <- constructor_args(parent_class, properties)
 
-    args <- as.list(substitute(...()))
-
-    parent_obj <- do.call("parent_class", args[args_info$parent_args])
-    do.call("new_object", c(list(parent_obj), args[args_info$self_args]))
+    args <- list(...)
+    parent_obj <- do.call("parent_class", args[args_info$parent])
+    do.call("new_object", c(list(parent_obj), args[args_info$self]))
   }
 }
 
diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R
index 0b27de07..b0190a6a 100644
--- a/tests/testthat/test-class.R
+++ b/tests/testthat/test-class.R
@@ -37,6 +37,14 @@ describe("S7 classes", {
     })
   })
 
+  it("can inherit from an external class", {
+    foo <- new_class("foo", package = "pkg", properties = list(x = class_integer))
+    foo_ex <- new_external_class("S7", "foo", function() foo)
+
+    foo2 <- new_class("foo", parent = foo_ex)
+    expect_s3_class(foo2(), c("foo2", "pkg::foo"))
+  })
+
   it("can't inherit from S4 or class unions", {
     parentS4 <- methods::setClass("parentS4", slots = c(x = "numeric"))
     expect_snapshot(error = TRUE, {
diff --git a/tests/testthat/test-constructor.R b/tests/testthat/test-constructor.R
index 6812ed83..5a6889f3 100644
--- a/tests/testthat/test-constructor.R
+++ b/tests/testthat/test-constructor.R
@@ -67,6 +67,16 @@ test_that("can generate constructor for inherited abstract classes", {
   expect_no_error(child())
 })
 
+test_that("dynamic constructor assigns args correctly", {
+  foo <- new_class("foo", properties = list(x = class_double))
+  foo1_ex <- new_external_class("pkg", "foo1", function() foo)
+  foo2 <- new_class("foo2", foo1_ex, properties = list(y = class_double))
+
+  out <- foo2(x = 1, y = 2)
+  expect_equal(out@x, 1)
+  expect_equal(out@y, 2)
+})
+
 test_that("can use `...` in parent constructor", {
   foo <- new_class(
     "foo",

From 2607bc142fe24140c9719ac3a6d131d97a56eb9d Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Sun, 10 Sep 2023 13:17:56 -0500
Subject: [PATCH 09/14] Test property

---
 tests/testthat/_snaps/property.md | 8 ++++++++
 tests/testthat/test-class.R       | 2 +-
 tests/testthat/test-property.R    | 9 +++++++++
 3 files changed, 18 insertions(+), 1 deletion(-)

diff --git a/tests/testthat/_snaps/property.md b/tests/testthat/_snaps/property.md
index 8a61ed13..f7a299f3 100644
--- a/tests/testthat/_snaps/property.md
+++ b/tests/testthat/_snaps/property.md
@@ -133,6 +133,14 @@
     Error <simpleError>
       <my_class>@S7_union must be <integer> or <logical>, not <character>
 
+# a property can be an external class
+
+    Code
+      foo2(y = 1)
+    Error <simpleError>
+      <foo2> object properties are invalid:
+      - @y must be <pkg::foo1>, not <double>
+
 # as_properties() gives useful error messages
 
     Code
diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R
index b0190a6a..f5da6ff6 100644
--- a/tests/testthat/test-class.R
+++ b/tests/testthat/test-class.R
@@ -42,7 +42,7 @@ describe("S7 classes", {
     foo_ex <- new_external_class("S7", "foo", function() foo)
 
     foo2 <- new_class("foo", parent = foo_ex)
-    expect_s3_class(foo2(), c("foo2", "pkg::foo"))
+    expect_s3_class(foo2(x = 1L), c("foo2", "pkg::foo"))
   })
 
   it("can't inherit from S4 or class unions", {
diff --git a/tests/testthat/test-property.R b/tests/testthat/test-property.R
index b27ddda1..f9c1f3ed 100644
--- a/tests/testthat/test-property.R
+++ b/tests/testthat/test-property.R
@@ -277,6 +277,15 @@ test_that("properties can be base, S3, S4, S7, or S7 union", {
   })
 })
 
+test_that("a property can be an external class", {
+  foo1 <- new_class("foo1", properties = list(x = class_double))
+  foo1_ex <- new_external_class("pkg", "foo1", function() foo1)
+  foo2 <- new_class("foo2", properties = list(y = foo1_ex))
+
+  expect_no_error(foo2(y = foo1(x = 1)))
+  expect_snapshot(foo2(y = 1), error = TRUE)
+})
+
 test_that("as_properties normalises properties", {
   expect_equal(as_properties(NULL), list())
   expect_equal(

From 3dea7d84bd55cf031b557f0d000eb271eccf90ca Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Sun, 10 Sep 2023 13:20:12 -0500
Subject: [PATCH 10/14] Union short hand

---
 R/zzz.R                     | 1 +
 tests/testthat/test-union.R | 2 ++
 2 files changed, 3 insertions(+)

diff --git a/R/zzz.R b/R/zzz.R
index a4506390..b0e7f864 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -148,6 +148,7 @@ chooseOpsMethod.S7_object <- function(x, y, mx, my, cl, reverse) TRUE
   registerS3method("|", "S7_union", `|.S7_class`)
   registerS3method("|", "S7_base_class", `|.S7_class`)
   registerS3method("|", "S7_S3_class", `|.S7_class`)
+  registerS3method("|", "S7_external_class", `|.S7_class`)
   registerS3method("|", "classGeneratorFunction", `|.S7_class`)
   registerS3method("|", "ClassUnionRepresentation", `|.S7_class`)
   registerS3method("|", "classRepresentation", `|.S7_class`)
diff --git a/tests/testthat/test-union.R b/tests/testthat/test-union.R
index 96740716..09e60b35 100644
--- a/tests/testthat/test-union.R
+++ b/tests/testthat/test-union.R
@@ -44,6 +44,7 @@ test_that("can construct from S3 and S4 classes", {
 
 test_that("can construct with |", {
   foo <- new_class("foo")
+  foo_ex <- new_external_class("pkg", "foo", function() foo)
   Foo1 <- setClass("Foo1", slots = list("x" = "numeric"))
   Foo2 <- setClass("Foo2", slots = list("x" = "numeric"))
   Foo3 <- setClassUnion("Foo3", c("Foo1", "Foo2"))
@@ -53,6 +54,7 @@ test_that("can construct with |", {
   expect_equal(class_integer | class_numeric, class_numeric)
   expect_equal(class_integer | class_factor, new_union(class_integer, class_factor))
   expect_equal(class_integer | foo, new_union(class_integer, foo))
+  expect_equal(class_integer | foo_ex, new_union(class_integer, foo_ex))
   expect_equal(class_integer | Foo1, new_union(class_integer, Foo1))
   expect_equal(class_integer | getClass("Foo1"), new_union(class_integer, Foo1))
   expect_equal(class_integer | Foo3, new_union(class_integer, Foo3))

From 9bcf57886699edd29413afd3cd1c4f0920c5241e Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Mon, 11 Sep 2023 13:09:24 -0500
Subject: [PATCH 11/14] Automatically use external class when needed

---
 R/class.R                 | 8 ++++++++
 R/external-class.R        | 5 +++++
 man/new_external_class.Rd | 5 +++++
 3 files changed, 18 insertions(+)

diff --git a/R/class.R b/R/class.R
index db708dfb..75e94f51 100644
--- a/R/class.R
+++ b/R/class.R
@@ -113,6 +113,14 @@ new_class <- function(
   # Don't check arguments for S7_object
   if (!is.null(parent)) {
     check_can_inherit(parent)
+
+    # Automatically use an external class if appropriate
+    if (!is.null(package) && is_class(parent)) {
+      if (!is.null(parent@package) && !identical(parent@package, package)) {
+        parent <- new_external_class(parent@package, parent@name)
+      }
+    }
+
     if (!is.null(package)) {
       check_name(package)
     }
diff --git a/R/external-class.R b/R/external-class.R
index 6243bcf0..a6d98fff 100644
--- a/R/external-class.R
+++ b/R/external-class.R
@@ -7,6 +7,11 @@
 #' when the other package changes your package doesn't need to be rebuilt to
 #' get those changes.
 #'
+#' [new_class()] will automatically convert an S7 class to an external class
+#' if its `package` property has been set, and it's different to the `package`
+#' of the subclass. This should ensure that extending a class in another package
+#' just works without you having to do anything extra.
+#'
 #' Extending a class creates a hard requirement on the package that defines it;
 #' i.e. you must list the package in the `Imports` field in your package's
 #' `DESCRIPTION`.
diff --git a/man/new_external_class.Rd b/man/new_external_class.Rd
index b7cf0b3b..98fc9f6b 100644
--- a/man/new_external_class.Rd
+++ b/man/new_external_class.Rd
@@ -25,6 +25,11 @@ the other package is not literally inlined in your package, ensuring that
 when the other package changes your package doesn't need to be rebuilt to
 get those changes.
 
+\code{\link[=new_class]{new_class()}} will automatically convert an S7 class to an external class
+if its \code{package} property has been set, and it's different to the \code{package}
+of the subclass. This should ensure that extending a class in another package
+just works without you having to do anything extra.
+
 Extending a class creates a hard requirement on the package that defines it;
 i.e. you must list the package in the \code{Imports} field in your package's
 \code{DESCRIPTION}.

From 370c6da72eabf7957b7a5469ec801ffbc2db6d2b Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Wed, 13 Sep 2023 07:49:12 -0500
Subject: [PATCH 12/14] Ensure default values computed correctly

---
 R/constructor.R                   | 14 ++++++++++++--
 tests/testthat/test-constructor.R | 11 ++++++++---
 2 files changed, 20 insertions(+), 5 deletions(-)

diff --git a/R/constructor.R b/R/constructor.R
index 69c95376..5fedb3d4 100644
--- a/R/constructor.R
+++ b/R/constructor.R
@@ -55,10 +55,20 @@ dynamic_constructor <- function(constructor_fun, properties) {
     args_info <- constructor_args(parent_class, properties)
 
     args <- list(...)
-    parent_obj <- do.call("parent_class", args[args_info$parent])
-    do.call("new_object", c(list(parent_obj), args[args_info$self]))
+    parent_args <- dynamic_args(args, args_info$parent)
+    self_args <- dynamic_args(args, args_info$self)
+
+    parent_obj <- do.call("parent_class", parent_args)
+    do.call("new_object", c(list(parent_obj), self_args))
   }
 }
+dynamic_args <- function(args, selected) {
+  missing <- setdiff(selected, names(args))
+  args[missing] <- missing_args(missing)
+
+  args[selected]
+}
+
 
 constructor_args <- function(parent, properties = list()) {
   parent_args <- names2(formals(class_constructor(parent)))
diff --git a/tests/testthat/test-constructor.R b/tests/testthat/test-constructor.R
index 738cb7b7..8bf42277 100644
--- a/tests/testthat/test-constructor.R
+++ b/tests/testthat/test-constructor.R
@@ -70,11 +70,16 @@ test_that("can generate constructor for inherited abstract classes", {
 test_that("dynamic constructor assigns args correctly", {
   foo <- new_class("foo", properties = list(x = class_double))
   foo1_ex <- new_external_class("pkg", "foo1", function() foo)
-  foo2 <- new_class("foo2", foo1_ex, properties = list(y = class_double))
+  foo2 <- new_class("foo2", foo1_ex, properties = list(y = class_character))
 
-  out <- foo2(x = 1, y = 2)
+  out <- foo2(x = 1, y = "x")
   expect_equal(out@x, 1)
-  expect_equal(out@y, 2)
+  expect_equal(out@y, "x")
+
+  # including initializing defaults
+  out <- foo2()
+  expect_equal(out@x, double())
+  expect_equal(out@y, character())
 })
 
 test_that("can use `...` in parent constructor", {

From 05246fa65fcca6265dce8261e8f8ca2af1952e67 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Wed, 13 Sep 2023 09:33:12 -0500
Subject: [PATCH 13/14] Make properties dynamic

---
 R/class-spec.R                 | 10 ----------
 R/class.R                      | 33 ++++++++++++++++++++++++---------
 R/constructor.R                | 13 +++++--------
 R/convert.R                    |  4 ++--
 R/property.R                   |  5 +++--
 R/valid.R                      |  2 +-
 tests/testthat/_snaps/class.md | 16 +---------------
 tests/testthat/test-class.R    |  9 +++++----
 8 files changed, 41 insertions(+), 51 deletions(-)

diff --git a/R/class-spec.R b/R/class-spec.R
index 4db8b037..b8a460fd 100644
--- a/R/class-spec.R
+++ b/R/class-spec.R
@@ -199,16 +199,6 @@ class_inherits <- function(x, what) {
   )
 }
 
-# S7_external class -----------------------------------------------------------
-
-class_properties <- function(x) {
-  if (is_external_class(x)) {
-    x <- x$constructor_fun()
-  }
-
-  attr(x, "properties", exact = TRUE) %||% list()
-}
-
 # object ------------------------------------------------------------------
 
 obj_type <- function(x) {
diff --git a/R/class.R b/R/class.R
index 80d9801f..37243377 100644
--- a/R/class.R
+++ b/R/class.R
@@ -136,12 +136,19 @@ new_class <- function(
   }
 
   # Combine properties from parent, overriding as needed
-  all_props <- class_properties(parent)
   new_props <- as_properties(properties)
-  all_props[names(new_props)] <- new_props
-
-  if (is.null(constructor)) {
-    constructor <- new_constructor(parent, all_props)
+  if (is_external_class(parent)) {
+    # TODO: cache this so only computed once per session
+    properties <- function() {
+      inherit_properties(parent$constructor_fun(), new_props)
+    }
+    constructor <- constructor %||% new_dynamic_constructor(parent, properties)
+  } else {
+    my_props <- inherit_properties(parent, new_props)
+    properties <- function() {
+      my_props
+    }
+    constructor <- constructor %||% new_constructor(parent, my_props)
   }
 
   object <- constructor
@@ -149,17 +156,24 @@ new_class <- function(
   attr(object, "name") <- name
   attr(object, "parent") <- parent
   attr(object, "package") <- package
-  attr(object, "properties") <- all_props
+  attr(object, "properties") <- properties
   attr(object, "abstract") <- abstract
   attr(object, "constructor") <- constructor
   attr(object, "validator") <- validator
   class(object) <- c("S7_class", "S7_object")
 
-  global_variables(names(all_props))
+  global_variables(names(properties()))
   object
 }
 globalVariables(c("name", "parent", "package", "properties", "abstract", "constructor", "validator"))
 
+inherit_properties <- function(parent, new) {
+  properties <- attr(parent, "properties", exact = TRUE) %||% function() list()
+  properties <- properties()
+  properties[names(new)] <- new
+  properties
+}
+
 #' @rawNamespace if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name)
 S7_class_name <- function(x) {
   paste(c(x@package, x@name), collapse = "::")
@@ -178,7 +192,7 @@ check_S7_constructor <- function(constructor) {
 
 #' @export
 print.S7_class <- function(x, ...) {
-  props <- x@properties
+  props <- x@properties()
   if (length(props) > 0) {
     prop_names <- format(names(props))
     prop_types <- format(vcapply(props, function(x) class_desc(x$class)))
@@ -269,8 +283,9 @@ new_object <- function(.parent, ...) {
   # We have to fill in missing values after setting the initial properties,
   # because custom setters might set property values
   missing_props <- setdiff(nms, union(supplied_props, names(attributes(object))))
+  properties <- class@properties()
   for (prop in missing_props) {
-    prop(object, prop, check = FALSE) <- prop_default(class@properties[[prop]])
+    prop(object, prop, check = FALSE) <- prop_default(properties[[prop]])
   }
 
   # Don't need to validate if parent class already validated,
diff --git a/R/constructor.R b/R/constructor.R
index 5fedb3d4..1e15c090 100644
--- a/R/constructor.R
+++ b/R/constructor.R
@@ -9,9 +9,6 @@ new_constructor <- function(parent, properties) {
       env = asNamespace("S7")
     ))
   }
-  if (is_external_class(parent)) {
-    return(dynamic_constructor(parent$constructor_fun, properties))
-  }
 
   if (is_class(parent)) {
     parent_name <- parent@name
@@ -46,13 +43,13 @@ new_constructor <- function(parent, properties) {
   new_function(args, body, env)
 }
 
-dynamic_constructor <- function(constructor_fun, properties) {
-  force(constructor_fun)
-  force(properties)
+new_dynamic_constructor <- function(parent, properties_fun) {
+  constructor_fun <- parent$constructor_fun
+  force(properties_fun)
 
   function(...) {
     parent_class <- constructor_fun()
-    args_info <- constructor_args(parent_class, properties)
+    args_info <- constructor_args(parent_class, properties_fun())
 
     args <- list(...)
     parent_args <- dynamic_args(args, args_info$parent)
@@ -79,7 +76,7 @@ constructor_args <- function(parent, properties = list()) {
   if (is_class(parent) && !parent@abstract) {
     # Remove any parent properties; can't use parent_args() since the constructor
     # might automatically set some properties.
-    self_args <- setdiff(self_args, names2(class_properties(parent)))
+    self_args <- setdiff(self_args, names2(parent@properties()))
   }
 
   list(
diff --git a/R/convert.R b/R/convert.R
index f9db8378..814a455f 100644
--- a/R/convert.R
+++ b/R/convert.R
@@ -76,7 +76,7 @@ convert <- function(from, to, ...) {
     if (is.null(from_class)) {
       from_props <- character()
     } else {
-      from_props <- names(from_class@properties)
+      from_props <- names(from_class@properties())
     }
 
     if (is_base_class(to)) {
@@ -85,7 +85,7 @@ convert <- function(from, to, ...) {
       from <- zap_attr(from, c(from_props, "S7_class"))
       class(from) <- to$class
     } else if (is_class(to)) {
-      from <- zap_attr(from, setdiff(from_props, names(to@properties)))
+      from <- zap_attr(from, setdiff(from_props, names(to@properties())))
       attr(from, "S7_class") <- to
       class(from) <- class_dispatch(to)
     } else {
diff --git a/R/property.R b/R/property.R
index d0c0f498..752230b3 100644
--- a/R/property.R
+++ b/R/property.R
@@ -186,7 +186,8 @@ prop_val <- function(object, name) {
 # Get underlying property object from class
 prop_obj <- function(object, name) {
   class <- S7_class(object)
-  attr(class, "properties")[[name]]
+  if (is.null(class)) return()
+  attr(class, "properties")()[[name]]
 }
 
 #' @rdname prop
@@ -316,7 +317,7 @@ prop_names <- function(object) {
     c("name", "parent", "package", "properties", "abstract", "constructor", "validator")
   } else {
     class <- S7_class(object)
-    props <- attr(class, "properties", exact = TRUE)
+    props <- attr(class, "properties", exact = TRUE)()
     if (length(props) == 0) {
       character()
     } else {
diff --git a/R/valid.R b/R/valid.R
index ed2aaf27..31538c1e 100644
--- a/R/valid.R
+++ b/R/valid.R
@@ -103,7 +103,7 @@ validate <- function(object, recursive = TRUE, properties = TRUE) {
 validate_properties <- function(object, class) {
   errors <- character()
 
-  for (prop in class@properties) {
+  for (prop in class@properties()) {
     # Don't validate dynamic properties
     if (!is.null(prop$getter)) {
       next
diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md
index f0fb4921..8cc602c4 100644
--- a/tests/testthat/_snaps/class.md
+++ b/tests/testthat/_snaps/class.md
@@ -16,21 +16,7 @@
        @ name       : chr "foo2"
        @ parent     : <foo1/S7_object> constructor
        @ package    : NULL
-       @ properties :List of 2
-       .. $ x: <S7_property> 
-       ..  ..$ 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
-       ..  ..$ validator: NULL
-       ..  ..$ default  : NULL
+       @ properties : function ()  
        @ abstract   : logi FALSE
        @ constructor: function (x = class_missing, y = class_missing)  
        @ validator  : NULL
diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R
index abcceb83..703c44c5 100644
--- a/tests/testthat/test-class.R
+++ b/tests/testthat/test-class.R
@@ -7,7 +7,8 @@ describe("S7 classes", {
     expect_equal(foo@parent, S7_object)
     expect_type(foo@constructor, "closure")
     expect_type(foo@validator, "closure")
-    expect_type(foo@properties, "list")
+    expect_type(foo@properties, "closure")
+    expect_type(foo@properties(), "list")
   })
 
   it("print nicely", {
@@ -64,13 +65,13 @@ describe("inheritance", {
   it("combines properties for parent classes", {
     foo1 <- new_class("foo1", properties = list(x = class_double))
     foo2 <- new_class("foo2", foo1, properties = list(y = class_double))
-    expect_equal(names(foo2@properties), c("x", "y"))
+    expect_equal(names(foo2@properties()), c("x", "y"))
   })
   it("child properties override parent", {
     foo1 <- new_class("foo1", properties = list(x = class_numeric))
     foo2 <- new_class("foo2", foo1, properties = list(x = class_double))
-    expect_equal(names(foo2@properties), "x")
-    expect_equal(foo2@properties$x$class, class_double)
+    expect_equal(names(foo2@properties()), "x")
+    expect_equal(foo2@properties()$x$class, class_double)
   })
 })
 

From ab30c8e0e6aea07b4931f287fc482d40b64a24ab Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Thu, 14 Sep 2023 08:20:51 -0500
Subject: [PATCH 14/14] Add tests

---
 tests/testthat/_snaps/external-class.md |  7 ++++
 tests/testthat/test-external-class.R    | 51 +++++++++++++++++++++++++
 2 files changed, 58 insertions(+)

diff --git a/tests/testthat/_snaps/external-class.md b/tests/testthat/_snaps/external-class.md
index 261ad5ac..a52588b9 100644
--- a/tests/testthat/_snaps/external-class.md
+++ b/tests/testthat/_snaps/external-class.md
@@ -5,3 +5,10 @@
     Output
       <S7_external_class> package::name
 
+# constructor_fun must yield a class
+
+    Code
+      new_external_class("S7", "foo", function() 1)
+    Error <simpleError>
+      `constructor_fun()` must yield an S7 class
+
diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R
index 9c044334..a2a34da7 100644
--- a/tests/testthat/test-external-class.R
+++ b/tests/testthat/test-external-class.R
@@ -2,3 +2,54 @@ test_that("displays nicely", {
   foo <- new_external_class("package", "name", function() new_class("foo"))
   expect_snapshot(print(foo))
 })
+
+test_that("gets updated constructor", {
+  foo1 <- new_class("foo", properties = list(x = class_double))
+  foo1_ex <- new_external_class("S7", "foo1", function() foo1)
+  foo2 <- new_class("foo2", parent = foo1_ex)
+
+  foo1 <- new_class(
+    "foo",
+    properties = list(x = class_double),
+    constructor = function(x) {
+      new_object(S7_object, x = x + 1)
+    }
+  )
+
+  f <- foo2(x = 1)
+  expect_equal(f@x, 2)
+})
+
+test_that("gets updated validator", {
+  foo1 <- new_class("foo", properties = list(x = class_double))
+  foo1_ex <- new_external_class("S7", "foo1", function() foo1)
+  foo2 <- new_class("foo2", parent = foo1_ex)
+
+  foo1 <- new_class(
+    "foo",
+    properties = list(x = class_double),
+    validator = function(self) {
+      if (self@x < 0) {
+        "@x must be positive"
+      }
+    }
+  )
+  expect_error(foo2(x = -1), "invalid")
+})
+
+test_that("gets updated properties", {
+  foo1 <- new_class("foo", properties = list(x = class_double))
+  foo1_ex <- new_external_class("S7", "foo1", function() foo1)
+  foo2 <- new_class("foo2", parent = foo1_ex)
+
+  foo1 <- new_class("foo", properties = list(x = class_double, y = class_double))
+  f <- foo2()
+  expect_equal(prop_names(f), c("x", "y"))
+})
+
+
+test_that("constructor_fun must yield a class", {
+  expect_snapshot(error = TRUE, {
+    new_external_class("S7", "foo", function() 1)
+  })
+})