Don't inline classes in constructor if possible

R/aaa.R

@@ -26,10 +26,10 @@ new_function <- function(args = NULL,
 topNamespaceName <- function(env = parent.frame()) {
   env <- topenv(env)
   if (!isNamespace(env)) {
-    return()
+    return() # print visible
   }
 
-  getNamespaceName(env)
+  as.character(getNamespaceName(env)) # unname
 }
 
 is_string <- function(x) {

R/base.R

@@ -44,7 +44,7 @@
     name = quote(quote(x)),
     call = quote(quote({})),
 
-    `function` = quote(function() {}),
+    `function` = quote(function() NULL),
     environment = quote(new.env(parent = emptyenv()))
 )}
 

R/class-spec.R

@@ -81,27 +81,36 @@
 }
 
 class_construct <- function(.x, ...) {
-  eval(class_construct_expr(.x, ...))
+  class_constructor(.x)(...)
 }
 
 
-class_construct_expr <- function(.x, ...) {
+class_construct_expr <- function(.x, envir = NULL, package = NULL) {
   f <- class_constructor(.x)
+
+  # If the constructor is an S7 class that is exported from a package, avoid
+  # inlining the full class def instead, inline an expression like
+  # `pkgname::classname()` or `classname()`
+  if (is_class(f) && !is.null(f@package)) {
+    # Check if the class can be resolved as a bare symbol without pkgname::
+    if (identical(package, f@package)) {
+      return(call(f@name))
+    } else {
+      # namespace the pkgname::classname() call
+      cl <- as.call(list(quote(`::`), as.name(f@package), as.name(f@name)))
+      return(as.call(list(cl)))
+    }
+  }
+
   # If the constructor is a closure wrapping a simple expression, try
   # to extract the expression
   # (mostly for nicer printing and introspection.)
 
-  ## early return if not safe to unwrap
-  # can't unwrap if we're passing on ...
-  if(...length()) {
-    return(as.call(list(f, ...)))
-  }
-
   # can't unwrap if the closure is potentially important
   # (this can probably be relaxed to allow additional environments)
   fe <- environment(f)
-  if(!identical(fe, baseenv())) {
-    return(as.call(list(f, ...)))
+  if (!identical(fe, baseenv())) {
+    return(as.call(list(f)))
   }
 
   # special case for `class_missing`
@@ -111,8 +120,8 @@
 
   # `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, ...)))
+  if ("new_object" %in% all.names(fb)) {
+    return(as.call(list(f)))
   }
 
   # maybe unwrap body if it is a single expression wrapped in `{`
@@ -133,7 +142,7 @@
   }
 
   #else, return a call to the constructor
-  as.call(list(f, ...))
+  as.call(list(f))
 }
 
 class_constructor <- function(.x) {

R/class.R

@@ -134,7 +134,9 @@ new_class <- function(
   all_props[names(new_props)] <- new_props
 
   if (is.null(constructor)) {
-    constructor <- new_constructor(parent, all_props)
+    constructor <- new_constructor(parent, all_props,
+                                   envir = parent.frame(),
+                                   package = package)
   }
 
   object <- constructor

R/constructor.R

@@ -1,18 +1,26 @@
-new_constructor <- function(parent, properties) {
+new_constructor <- function(parent, properties,
+                            envir = asNamespace("S7"), package = NULL) {
   properties <- as_properties(properties)
-  arg_info <- constructor_args(parent, properties)
+  arg_info <- constructor_args(parent, properties, envir, package)
   self_args <- as_names(names(arg_info$self), named = TRUE)
 
   if (identical(parent, S7_object) || (is_class(parent) && parent@abstract)) {
+    new_object_call <-
+      if (has_S7_symbols(envir, "new_object", "S7_object")) {
+        bquote(new_object(S7_object(), ..(self_args)), splice = TRUE)
+      } else {
+        bquote(S7::new_object(S7::S7_object(), ..(self_args)), splice = TRUE)
+      }
+
     return(new_function(
       args = arg_info$self,
       body = as.call(c(quote(`{`),
         # Force all promises here so that any errors are signaled from
         # the constructor() call instead of the new_object() call.
         unname(self_args),
-        new_call("new_object", c(list(quote(S7_object())), self_args))
+        new_object_call
       )),
-      env = asNamespace("S7")
+      env = envir
     ))
   }
 
@@ -42,15 +50,19 @@ new_constructor <- function(parent, properties) {
   parent_args <- as_names(names(arg_info$parent), named = TRUE)
   names(parent_args)[names(parent_args) == "..."] <- ""
   parent_call <- new_call(parent_name, parent_args)
-  body <- new_call("new_object", c(parent_call, self_args))
+  body <- new_call(
+    if (has_S7_symbols(envir, "new_object")) "new_object" else c("S7", "new_object"),
+    c(parent_call, self_args)
+  )
 
-  env <- new.env(parent = asNamespace("S7"))
+  env <- new.env(parent = envir)
   env[[parent_name]] <- parent_fun
 
   new_function(args, body, env)
 }
 
-constructor_args <- function(parent, properties = list()) {
+constructor_args <- function(parent, properties = list(),
+                             envir = asNamespace("S7"), package = NULL) {
   parent_args <- formals(class_constructor(parent))
 
   # Remove read-only properties
@@ -66,7 +78,7 @@ constructor_args <- function(parent, properties = list()) {
 
   self_args <- as.pairlist(lapply(
     setNames(, self_arg_nms),
-    function(name) prop_default(properties[[name]]))
+    function(name) prop_default(properties[[name]], envir, package))
   )
 
   list(parent = parent_args,
@@ -81,8 +93,14 @@ is_property_dynamic <- function(x) is.function(x$getter)
 missing_args <- function(names) {
   lapply(setNames(, names), function(i) quote(class_missing))
 }
+
 new_call <- function(call, args) {
-  as.call(c(list(as.name(call)), args))
+  if (is.character(call)) {
+    call <- switch(length(call),
+                   as.name(call),
+                   as.call(c(quote(`::`), lapply(call, as.name))))
+  }
+  as.call(c(list(call), args))
 }
 
 as_names <- function(x, named = FALSE) {
@@ -91,3 +109,14 @@ as_names <- function(x, named = FALSE) {
   }
   lapply(x, as.name)
 }
+
+has_S7_symbols <- function(env, ...) {
+  env <- topenv(env)
+  if (identical(env, asNamespace("S7")))
+    return (TRUE)
+  if (!isNamespace(env))
+    return (FALSE)
+  imports <- getNamespaceImports(env)[["S7"]]
+  symbols <- c(...) %||% getNamespaceExports("S7")
+  all(symbols %in% imports)
+}

R/property.R

@@ -155,8 +155,8 @@ str.S7_property <- function(object, ..., nest.lev = 0) {
   print(object, ..., nest.lev = nest.lev)
 }
 
-prop_default <- function(prop) {
-  prop$default %||% class_construct_expr(prop$class)
+prop_default <- function(prop, envir, package) {
+  prop$default %||% class_construct_expr(prop$class, envir, package)
 }
 
 #' Get/set a property

tests/testthat/_snaps/class.md

@@ -112,7 +112,7 @@
       foo <- new_class("foo", abstract = TRUE)
       foo()
     Condition
-      Error in `new_object()`:
+      Error in `S7::new_object()`:
       ! Can't construct an object from abstract class <foo>
 
 # abstract classes: can't inherit from concrete class

tests/testthat/_snaps/constructor.md

@@ -79,3 +79,12 @@
       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/test-class.R

@@ -232,16 +232,19 @@ test_that("c(<S7_class>, ...) gives error", {
 })
 
 test_that("can round trip to disk and back", {
-  foo1 <- new_class("foo1", properties = list(y = class_integer))
-  foo2 <- new_class("foo2", properties = list(x = foo1))
-
-  f <- foo2(x = foo1(y = 1L))
+  eval(quote({
+    foo1 <- new_class("foo1", properties = list(y = class_integer))
+    foo2 <- new_class("foo2", properties = list(x = foo1))
+    f <- foo2(x = foo1(y = 1L))
+  }), globalenv())
 
+  f <- globalenv()[["f"]]
   path <- tempfile()
   saveRDS(f, path)
   f2 <- readRDS(path)
 
-  expect_equal(f2, f)
+  expect_equal(f, f2)
+  rm(foo1, foo2, f, envir = globalenv())
 })
 
 

tests/testthat/test-constructor.R

@@ -160,8 +160,6 @@ test_that("can create constructors with missing or lazy defaults", {
                "Can\'t set read-only property Person@birthdate")
 })
 
-
-
 test_that("Dynamic settable properties are included in constructor", {
   Foo <- new_class(
     name = "Foo", package = NULL,
@@ -193,3 +191,16 @@ 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))
+})