Don't inline classes in constructor if possible

R/class-spec.R

@@ -100,6 +100,17 @@
     } else {
       # namespace the pkgname::classname() call
       cl <- as.call(list(quote(`::`), as.name(f@package), as.name(f@name)))
+
+      # check the call evaluates to f.
+      # This will error if package is not installed or object is not exported.
+      f2 <- eval(cl, baseenv())
+      if (!identical(f, f2)) {
+        msg <- sprintf(
+          "`%s::%s` is not identical to the class with the same @package and @name properties",
+          f@package, f@name
+        )
+        stop(msg, call. = FALSE)
+      }
       return(as.call(list(cl)))
     }
   }
@@ -123,7 +134,7 @@
   # `new_object()` must be called from the class constructor, can't
   # be safely unwrapped
   if ("new_object" %in% all.names(fb)) {
     return(as.call(list(f)))
   }
 
   # maybe unwrap body if it is a single expression wrapped in `{`
@@ -144,7 +155,7 @@
   }
 
   #else, return a call to the constructor
   as.call(list(f))
 }
 
 class_constructor <- function(.x) {

tests/testthat/_snaps/constructor.md

@@ -79,12 +79,3 @@
       new_object(foo(...), y = y)
       <environment: 0x0>
 
-# package exported classes are not inlined in constructor formals
-
-    Code
-      formals(Bar)
-    Output
-      $foo
-      pkgname::Foo()
-
-

tests/testthat/_snaps/external-generic.md

@@ -5,3 +5,41 @@
     Output
       <S7_external_generic> foo::bar(x)
 
+# new_method works with both hard and soft dependencies
+
+    Code
+      args(Foo)
+    Output
+      function (bar = t0::AnS7Class()) 
+      NULL
+    Code
+      args(t2::AnS7Class2)
+    Output
+      function (bar = t0::AnS7Class()) 
+      NULL
+    Code
+      args(t2:::AnInternalClass)
+    Output
+      function (foo = t0::AnS7Class(), bar = AnS7Class2()) 
+      NULL
+
+---
+
+    Code
+      new_class("Foo", properties = list(bar = new_class("MadeUpClass", package = "t0")))
+    Condition
+      Error:
+      ! 'MadeUpClass' is not an exported object from 'namespace:t0'
+    Code
+      new_class("Foo", properties = list(bar = new_class("MadeUpClass", package = "MadeUpPackage")))
+    Condition
+      Error in `loadNamespace()`:
+      ! there is no package called 'MadeUpPackage'
+    Code
+      modified_class <- t0::AnS7Class
+      attr(modified_class, "xyz") <- "abc"
+      new_class("Foo", properties = list(bar = modified_class))
+    Condition
+      Error:
+      ! `t0::AnS7Class` is not identical to the class with the same @package and @name properties
+

tests/testthat/t0/NAMESPACE

@@ -1,4 +1,5 @@
 # Generated by roxygen2: do not edit by hand
 
+export(AnS7Class)
 export(an_s3_generic)
 export(an_s7_generic)

tests/testthat/t0/R/t0.R

@@ -3,3 +3,6 @@ an_s7_generic <- S7::new_generic("an_s7_generic", "x")
 
 #' @export
 an_s3_generic <- function(x) UseMethod("an_s3_generic")
+
+#' @export
+AnS7Class <- S7::new_class("AnS7Class")

tests/testthat/t2/NAMESPACE

@@ -1,5 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
+export(AnS7Class2)
 export(an_s7_class)
+importFrom(t0,AnS7Class)
 importFrom(t0,an_s3_generic)
 importFrom(t0,an_s7_generic)

tests/testthat/t2/R/t2.R

@@ -10,13 +10,24 @@ S7::method(an_s7_generic, an_s7_class) <- function(x) "foo"
 S7::method(an_s3_generic, an_s7_class) <- function(x) "foo"
 
 
+#' @importFrom t0 AnS7Class
+#' @export
+AnS7Class2 <- S7::new_class("AnS7Class2", properties = list(bar = AnS7Class))
+
+AnInternalClass <- S7::new_class("AnInternalClass", properties = list(
+  foo = AnS7Class,
+  bar = AnS7Class2
+))
+
+
 another_s7_generic <- S7::new_external_generic("t1", "another_s7_generic", "x")
 S7::method(another_s7_generic, S7::class_character) <- function(x) "foo"
 S7::method(another_s7_generic, an_s7_class) <- function(x) "foo"
 
 another_s3_generic <- S7::new_external_generic("t1", "another_s3_generic", "x")
 S7::method(another_s3_generic, an_s7_class) <- function(x) "foo"
 
+
 .onLoad <- function(libname, pkgname) {
   S7::methods_register()
 }

tests/testthat/test-constructor.R

@@ -191,16 +191,3 @@ test_that("Dynamic settable properties are included in constructor", {
   expect_equal(foo@dynamic_settable, 1)
 
 })
-
-test_that("package exported classes are not inlined in constructor formals", {
-  # https://github.com/RConsortium/S7/issues/477
-  Foo := new_class(package = "pkgname")
-  Bar := new_class(properties = list(foo = Foo))
-
-  expect_identical(
-    formals(Bar)$foo,
-    quote(pkgname::Foo())
-  )
-
-  expect_snapshot(formals(Bar))
-})

tests/testthat/test-external-generic.R

@@ -86,6 +86,39 @@ test_that("new_method works with both hard and soft dependencies", {
   expect_equal(an_s3_generic(t2::an_s7_class()), "foo")
   expect_equal(an_s7_generic("x"), "foo")
 
+  # test that new_class() will construct a property default as a namespaced call
+  # to t0::AnS7Class() (and not inline the full class object).
+  # As these tests grow, consider splitting this into a separate context like:
+  #   test_that("package exported classes are not inlined in constructor formals", {...})
+  Foo <- new_class("Foo", properties = list(bar = t0::AnS7Class))
+  expect_identical(formals(Foo)           , as.pairlist(alist(bar = t0::AnS7Class())))
+  expect_identical(formals(t2::AnS7Class2), as.pairlist(alist(bar = t0::AnS7Class())))
+  expect_identical(formals(t2:::AnInternalClass), as.pairlist(alist(
+    foo = t0::AnS7Class(), bar = AnS7Class2()
+  )))
+
+  expect_snapshot({
+    args(Foo)
+    args(t2::AnS7Class2)
+    args(t2:::AnInternalClass)
+  })
+
+  # test we emit informative error messages if a new_class() call with an
+  # external class dependency is malformed.
+  # https://github.com/RConsortium/S7/issues/477
+  expect_snapshot(error = TRUE, {
+    new_class("Foo", properties = list(
+      bar = new_class("MadeUpClass", package = "t0")
+    ))
+    new_class("Foo", properties = list(
+      bar = new_class("MadeUpClass", package = "MadeUpPackage")
+    ))
+
+    modified_class <- t0::AnS7Class
+    attr(modified_class, "xyz") <- "abc"
+    new_class("Foo", properties = list(bar = modified_class))
+  })
+
   # Now install the soft dependency
   quick_install(test_path("t1"), tmp_lib)