Updates to default constructor

.Rbuildignore

@@ -15,3 +15,5 @@
 ^pkgdown$
 ^cran-comments\.md$
 ^CRAN-SUBMISSION$
+^compile_commands\.json$
+^\.cache$

.gitignore

@@ -3,3 +3,7 @@ script.R
 inst/doc
 docs
 .Rhistory
+compile_commands.json
+.cache
+fetch_github_issue.py
+.Rbuildignore

DESCRIPTION

@@ -45,4 +45,5 @@ Config/testthat/parallel: TRUE
 Config/testthat/start-first: external-generic
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
+Config/build/compilation-database: true

R/base.R

@@ -1,12 +1,8 @@
 new_base_class <- function(name, constructor_name = name) {
   force(name)
 
-  constructor <- function(.data = class_missing) {
-    if (is_class_missing(.data)) {
-      .data <- base_default(name)
-    }
-    .data
-  }
+  constructor <- as.function.default(list(.data = base_default(name), quote(.data)),
+                                     baseenv())
 
   validator <- function(object) {
     if (base_class(object) != name) {
@@ -35,8 +31,8 @@ base_default <- function(type) {
     list = list(),
     expression = expression(),
 
-    `function` = function() {},
-    environment = new.env(parent = emptyenv())
+    `function` = quote(function() {}),
+    environment = quote(new.env(parent = emptyenv()))
 )}
 
 

R/class-spec.R

@@ -80,7 +80,7 @@ class_friendly <- function(x) {
   )
 }
 
-class_constructor <- function(.x, ...) {
+class_constructor <- function(.x) {
   switch(class_type(.x),
     NULL = function() NULL,
     any = function() NULL,
@@ -92,8 +92,45 @@ class_constructor <- function(.x, ...) {
     stop(sprintf("Can't construct %s", class_friendly(.x)), call. = FALSE)
   )
 }
+
+class_construct_expr <- function(.x, ...) {
+  f <- class_constructor(.x)
+  # If the constructor is a closure wrapping a simple expression, try to extract the expression
+  # (mostly for nicer printing and introspection.)
+  fb <- body(f)
+  ff <- formals(f)
+  fe <- environment(f)
+
+  # early return if not safe to unwrap
+  if(length(list(...)))
+    return(as.call(list(f, ...)))
+
+  if(!identical(fe, baseenv()))
+    return(as.call(list(f, ...)))
+
+  if("new_object" %in% all.names(fb))
+    return(as.call(list(f, ...)))
+
+  # maybe unwrap if body is a single expression wrapped in `{`
+  if (length(fb) == 2L && identical(fb[[1L]], quote(`{`)))
+    fb <- fb[[2L]]
+
+  # If all the all the work happens in the promise to the `.data` arg,
+  # return the `.data` expression.
+  if ((identical(fb, quote(.data))) &&
+      identical(names(ff), ".data"))
+    return(ff$.data)
+
+  # if all the work happens in the function body, return the body.
+  if (is.null(ff))
+    return(fb)
+
+  #else, return a call to the constructor
+  as.call(list(f, ...))
+}
+
 class_construct <- function(.x, ...) {
-  class_constructor(.x)(...)
+  eval(class_construct_expr(.x, ...))
 }
 
 class_validate <- function(class, object) {

R/class.R

@@ -260,17 +260,9 @@ new_object <- function(.parent, ...) {
   attr(object, "S7_class") <- class
   class(object) <- class_dispatch(class)
 
-  supplied_props <- nms[!vlapply(args, is_class_missing)]
-  for (prop in supplied_props) {
-    prop(object, prop, check = FALSE) <- args[[prop]]
-  }
-
-  # 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))))
-  for (prop in missing_props) {
-    prop(object, prop, check = FALSE) <- prop_default(class@properties[[prop]])
-  }
+  # Set properties. This will potentially invoke custom property setters
+  for (name in names(args))
+    prop(object, name, check = FALSE) <- args[[name]]
 
   # Don't need to validate if parent class already validated,
   # i.e. it's a non-abstract S7 class

R/constructor.R

@@ -1,10 +1,11 @@
 new_constructor <- function(parent, properties) {
+  properties <- as_properties(properties)
   arg_info <- constructor_args(parent, properties)
-  self_args <- as_names(arg_info$self, named = TRUE)
+  self_args <- as_names(names(arg_info$self), named = TRUE)
 
   if (identical(parent, S7_object) || (is_class(parent) && parent@abstract)) {
     return(new_function(
-      args = missing_args(arg_info$self),
+      args = arg_info$self,
       body = new_call("new_object", c(list(quote(S7_object())), self_args)),
       env = asNamespace("S7")
     ))
@@ -13,16 +14,16 @@ new_constructor <- function(parent, properties) {
   if (is_class(parent)) {
     parent_name <- parent@name
     parent_fun <- parent
-    args <- missing_args(union(arg_info$parent, arg_info$self))
+    args <- modify_list(arg_info$parent, arg_info$self)
   } else if (is_base_class(parent)) {
     parent_name <- parent$constructor_name
     parent_fun <- parent$constructor
-    args <- missing_args(union(arg_info$parent, arg_info$self))
+    args <- modify_list(arg_info$parent, arg_info$self)
   } else if (is_S3_class(parent)) {
     parent_name <- paste0("new_", parent$class[[1]])
     parent_fun <- parent$constructor
     args <- formals(parent$constructor)
-    args[arg_info$self] <- missing_args(arg_info$self)
+    args[names(arg_info$self)] <- arg_info$self
   } else {
     # user facing error in S7_class()
     stop("Unsupported `parent` type", call. = FALSE)
@@ -33,7 +34,8 @@ new_constructor <- function(parent, properties) {
     args[names(args) == "..."] <- list(quote(expr = ))
   }
 
-  parent_args <- as_names(arg_info$parent, named = TRUE)
+  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))
 
@@ -44,7 +46,8 @@ new_constructor <- function(parent, properties) {
 }
 
 constructor_args <- function(parent, properties = list()) {
-  parent_args <- names2(formals(class_constructor(parent)))
+  parent_constructor_formals <- formals(class_constructor(parent))
+  parent_args <- names2(parent_constructor_formals)
 
   self_args <- names2(properties)
   # Remove dynamic arguments
@@ -55,22 +58,21 @@ constructor_args <- function(parent, properties = list()) {
     self_args <- setdiff(self_args, names2(parent@properties))
   }
 
-  list(
-    parent = parent_args,
-    self = self_args
-  )
+  self_args <- lapply(setNames(nm = self_args),
+                      function(name) prop_default(properties[[name]]))
+  parent_args <- parent_constructor_formals %||%
+    structure(list(), names = character())
+
+  list(parent = as.list(parent_args),
+       self = as.list(self_args))
 }
 
+is_property_dynamic <- function(prop) is.function(x$getter)
+
 # helpers -----------------------------------------------------------------
 
 new_function <- function(args, body, env) {
-  f <- function() {}
-  formals(f) <- args
-  body(f) <- body
-  environment(f) <- env
-  attr(f, "srcref") <- NULL
-
-  f
+  as.function.default(c(args, body), env)
 }
 missing_args <- function(names) {
   lapply(setNames(, names), function(i) quote(class_missing))

R/property.R

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

R/special.R

@@ -10,10 +10,12 @@
 #' @examples
 #' foo <- new_generic("foo", "x")
 #' method(foo, class_numeric) <- function(x) "number"
+#' method(foo, class_missing) <- function(x) "missing"
 #' method(foo, class_any) <- function(x) "fallback"
 #'
 #' foo(1)
 #' foo()
+#' foo("")
 class_missing <- structure(list(), class = "S7_missing")
 
 is_class_missing <- function(x) inherits(x, "S7_missing")

R/utils.R

@@ -113,13 +113,9 @@ show_function <- function(x, constructor = FALSE) {
   args <- formals(x)
 
   if (constructor) {
-    args <- lapply(args, function(x) {
-      if (identical(x, quote(class_missing))) {
-        quote(expr = )
-      } else {
-        x
-      }
-    })
+    # don't show the defaults arg values in the constructor, keep it compact
+    # TODO: do show the default values next to properties in class printouts.
+    args <- lapply(args, function(q) quote(expr =))
   }
 
   show_args(args, suffix = " {...}")
@@ -136,6 +132,16 @@ show_args <- function(x, name = "function", suffix = "") {
   paste0(name, "(", args, ")", suffix)
 }
 
+modify_list <- function (x, new_vals) {
+  stopifnot(is.list(x))
+
+  for (name in names(new_vals))
+    x[name] <- new_vals[name]
+
+  x
+}
+
+
 # For older versions of R ----------------------------------------------------
 deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) {
   paste(deparse(expr, width.cutoff, ...), collapse = collapse)

R/valid.R

@@ -103,14 +103,14 @@ validate <- function(object, recursive = TRUE, properties = TRUE) {
 validate_properties <- function(object, class) {
   errors <- character()
 
-  for (prop in class@properties) {
+  for (prop_obj in class@properties) {
     # Don't validate dynamic properties
-    if (!is.null(prop$getter)) {
+    if (!is.null(prop_obj$getter)) {
       next
     }
 
-    value <- prop(object, prop$name)
-    errors <- c(errors, prop_validate(prop, value))
+    value <- prop(object, prop_obj$name)
+    errors <- c(errors, prop_validate(prop_obj, value))
   }
 
   errors

R/zzz.R

@@ -88,25 +88,36 @@ check_subsettable <- function(x, allow_env = FALSE) {
   invisible(TRUE)
 }
 
-S7_generic <- new_class(
-  name = "S7_generic",
-  properties = list(
-    name = class_character,
-    methods = class_environment,
-    dispatch_args = class_character
-  ),
-  parent = class_function
-)
+S7_generic <- NULL
+
+on_load_define_S7_generic <- function() {
+  # we do this in .onLoad() because dynlib `prop_` symbol
+  # is not available at pkg build time, and new_class()
+  # errors if `@` is not usable.
+  S7_generic <<- new_class(
+    name = "S7_generic",
+    properties = list(
+      name = class_character,
+      methods = class_environment,
+      dispatch_args = class_character
+    ),
+    parent = class_function
+  )
+}
+
 methods::setOldClass(c("S7_generic", "function", "S7_object"))
 is_S7_generic <- function(x) inherits(x, "S7_generic")
 
-S7_method <- new_class("S7_method",
-  parent = class_function,
-  properties = list(
-    generic = S7_generic,
-    signature = class_list
+
+S7_method <- NULL
+
+on_load_define_S7_method <- function() {
+  S7_method <<- new_class(
+    "S7_method",
+    parent = class_function,
+    properties = list(generic = S7_generic, signature = class_list)
   )
-)
+}
 methods::setOldClass(c("S7_method", "function", "S7_object"))
 
 # hooks -------------------------------------------------------------------
@@ -121,6 +132,8 @@ methods::setOldClass(c("S7_method", "function", "S7_object"))
 .onLoad <- function(...) {
   activate_backward_compatiblility()
 
+  on_load_define_S7_generic()
+  on_load_define_S7_method()
   on_load_make_convert_generic()
   on_load_define_ops()
   on_load_define_or_methods()

tests/testthat/_snaps/class.md

@@ -33,7 +33,7 @@
        ..  ..$ validator: NULL
        ..  ..$ default  : NULL
        @ abstract   : logi FALSE
-       @ constructor: function (x = class_missing, y = class_missing)  
+       @ constructor: function (x = integer(0), y = integer(0))  
        @ validator  : NULL
     Code
       str(list(foo2))