Tag S7-generated constructors with new_S7_constructor()

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_constructor)
 S3method(print,S7_external_class)
 S3method(print,S7_external_generic)
 S3method(print,S7_generic)
@@ -32,6 +33,7 @@ S3method(str,S7_S3_class)
 S3method(str,S7_any)
 S3method(str,S7_base_class)
 S3method(str,S7_class)
+S3method(str,S7_constructor)
 S3method(str,S7_missing)
 S3method(str,S7_object)
 S3method(str,S7_property)

R/aaa.R → R/AAA.R

@@ -4,6 +4,16 @@ new_function <- function(args = NULL, body = NULL, env = asNamespace("S7")) {
   as.function.default(c(args, body) %||% list(NULL), env)
 }
 
+# Tag a function as an S7-generated constructor (vs a user-supplied one), so
+# `is_default_constructor()` can tell them apart, and re-home it (by default in
+# the S7 namespace). Defined here because the base S3 wrappers in S3.R need it
+# at load time.
+new_S7_constructor <- function(f, env = asNamespace("S7")) {
+  environment(f) <- env
+  class(f) <- "S7_constructor"
+  f
+}
+
 
 `append<-` <- function(x, after, value) {
   if (missing(after)) {

R/S3.R

@@ -97,12 +97,13 @@ new_S3_class <- function(class, constructor = NULL, validator = NULL) {
     check_S3_constructor(constructor)
   } else {
     abstract <- TRUE
-    constructor <- function(.data) {
-      stop2(
-        sprintf("S3 class <%s> doesn't have a constructor.", class[[1]]),
+    constructor <- new_S7_constructor(new_function(
+      args = alist(.data = ),
+      body = bquote(stop2(
+        sprintf("S3 class <%s> doesn't have a constructor.", .(class[[1]])),
         call = NULL
-      )
-    }
+      ))
+    ))
   }
 
   out <- list(
@@ -147,21 +148,6 @@ is_S3_class <- function(x) {
   inherits(x, "S7_S3_class")
 }
 
-# Detect the stub constructor that `new_S3_class()` inserts when no constructor
-# is supplied. Needed as a fallback for `S7_S3_class` objects created by older
-# versions of S7.
-is_S3_stub_constructor <- function(constructor) {
-  if (!is.function(constructor)) {
-    return(FALSE)
-  }
-  call <- find_call(body(constructor), quote(sprintf))
-  if (is.null(call)) {
-    return(FALSE)
-  }
-  fmt <- call[[2]]
-  is.character(fmt) && grepl("doesn't have a constructor", fmt, fixed = TRUE)
-}
-
 # -------------------------------------------------------------------------
 # Pull out validation functions so hit by code coverage
 
@@ -324,10 +310,10 @@ validate_formula <- function(self) {
 #' @order 3
 class_factor <- new_S3_class(
   "factor",
-  constructor = function(.data = integer(), levels = NULL) {
+  constructor = new_S7_constructor(function(.data = integer(), levels = NULL) {
     levels <- levels %||% attr(.data, "levels", TRUE) %||% character()
     structure(.data, levels = levels, class = "factor")
-  },
+  }),
   validator = validate_factor
 )
 
@@ -337,9 +323,9 @@ class_factor <- new_S3_class(
 #' @order 3
 class_Date <- new_S3_class(
   "Date",
-  constructor = function(.data = double()) {
+  constructor = new_S7_constructor(function(.data = double()) {
     .Date(.data)
-  },
+  }),
   validator = validate_date
 )
 
@@ -349,9 +335,9 @@ class_Date <- new_S3_class(
 #' @order 3
 class_POSIXct <- new_S3_class(
   c("POSIXct", "POSIXt"),
-  constructor = function(.data = double(), tz = "") {
+  constructor = new_S7_constructor(function(.data = double(), tz = "") {
     .POSIXct(.data, tz = tz)
-  },
+  }),
   validator = validate_POSIXct
 )
 
@@ -361,9 +347,9 @@ class_POSIXct <- new_S3_class(
 #' @order 3
 class_POSIXlt <- new_S3_class(
   c("POSIXlt", "POSIXt"),
-  constructor = function(.data = NULL, tz = "") {
+  constructor = new_S7_constructor(function(.data = NULL, tz = "") {
     as.POSIXlt(.data, tz = tz)
-  },
+  }),
   validator = validate_POSIXlt
 )
 
@@ -379,15 +365,15 @@ class_POSIXt <- new_S3_class("POSIXt") # abstract class
 #' @order 3
 class_data.frame <- new_S3_class(
   "data.frame",
-  constructor = function(.data = list(), row.names = NULL) {
+  constructor = new_S7_constructor(function(.data = list(), row.names = NULL) {
     if (is.null(row.names)) {
       list2DF(.data)
     } else {
       out <- list2DF(.data, length(row.names))
       attr(out, "row.names") <- row.names
       out
     }
-  },
+  }),
   validator = validate_data.frame
 )
 
@@ -397,7 +383,7 @@ class_data.frame <- new_S3_class(
 #  @order 3
 class_matrix <- new_S3_class(
   "matrix",
-  constructor = function(
+  constructor = new_S7_constructor(function(
     .data = logical(),
     nrow = NULL,
     ncol = NULL,
@@ -412,7 +398,7 @@ class_matrix <- new_S3_class(
       }
     }
     matrix(.data, nrow, ncol, byrow, dimnames)
-  },
+  }),
   validator = validate_matrix
 )
 
@@ -422,13 +408,13 @@ class_matrix <- new_S3_class(
 #  @order 3
 class_array <- new_S3_class(
   "array",
-  constructor = function(
+  constructor = new_S7_constructor(function(
     .data = logical(),
     dim = base::dim(.data) %||% length(.data),
     dimnames = base::dimnames(.data)
   ) {
     array(.data, dim, dimnames)
-  },
+  }),
   validator = validate_array
 )
 
@@ -438,8 +424,10 @@ class_array <- new_S3_class(
 #' @order 3
 class_formula <- new_S3_class(
   "formula",
-  constructor = function(.data = NULL, env = parent.frame()) {
-    stats::formula(.data, env = env)
-  },
+  constructor = new_S7_constructor(
+    function(.data = NULL, env = parent.frame()) {
+      stats::formula(.data, env = env)
+    }
+  ),
   validator = validate_formula
 )

R/class.R

@@ -274,7 +274,7 @@ class_is_abstract <- function(class) {
   if (is_class(class)) {
     class@abstract
   } else if (is_S3_class(class)) {
-    class$abstract %||% is_S3_stub_constructor(class$constructor)
+    class$abstract %||% is_default_constructor(class$constructor)
   } else {
     FALSE
   }

R/constructor.R

@@ -24,15 +24,17 @@ new_constructor <- function(
         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_object_call
-      )),
+    return(new_S7_constructor(
+      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_object_call
+        ))
+      ),
       env = envir
     ))
   }
@@ -94,7 +96,10 @@ new_constructor <- function(
   # And finally the constructor itself
   env <- new.env(parent = envir)
   env[[parent_name]] <- parent_fun
-  new_function(constr_args[constr_nms], child_call, env)
+  new_S7_constructor(
+    new_function(constr_args[constr_nms], child_call),
+    env = env
+  )
 }
 
 constructor_args <- function(
@@ -118,6 +123,22 @@ constructor_args <- function(
 
 # helpers -----------------------------------------------------------------
 
+# Was this constructor generated by S7 or supplied by the user?
+is_default_constructor <- function(constructor) {
+  inherits(constructor, "S7_constructor")
+}
+
+#' @export
+print.S7_constructor <- function(x, ...) {
+  print(unclass(x), ...)
+  invisible(x)
+}
+
+#' @export
+str.S7_constructor <- function(object, ...) {
+  str(unclass(object), ...)
+}
+
 is_property_dynamic <- function(x) is.function(x$getter)
 
 missing_args <- function(names) {

R/utils.R

@@ -136,6 +136,10 @@ str_nest <- function(
 
 str_function <- function(object, ..., nest.lev = 0) {
   attr(object, "srcref") <- NULL
+  # Display S7-generated constructors like any other function
+  if (inherits(object, "S7_constructor")) {
+    class(object) <- NULL
+  }
   if (identical(class(object), "function")) {
     cat(" ")
   }