feat: perrmit (most) reserved attributes names as property names

Author: dgkf

R/class.R

@@ -95,14 +95,14 @@
 #' r <- Range(start = 10, end = 20)
 #' try(r@start <- 25)
 new_class <- function(
-    name,
-    parent = S7_object,
-    package = topNamespaceName(parent.frame()),
-    properties = list(),
-    abstract = FALSE,
-    constructor = NULL,
-    validator = NULL) {
-
+  name,
+  parent = S7_object,
+  package = topNamespaceName(parent.frame()),
+  properties = list(),
+  abstract = FALSE,
+  constructor = NULL,
+  validator = NULL
+) {
   check_name(name)
 
   parent <- as_class(parent)
@@ -119,7 +119,10 @@ new_class <- function(
     if (!is.null(validator)) {
       check_function(validator, alist(self = ))
     }
-    if (abstract && (!is_class(parent) || !(parent@abstract || parent@name == "S7_object"))) {
+    if (
+      abstract &&
+        (!is_class(parent) || !(parent@abstract || parent@name == "S7_object"))
+    ) {
       stop("Abstract classes must have abstract parents")
     }
   }
@@ -128,12 +131,16 @@ new_class <- function(
   all_props <- attr(parent, "properties", exact = TRUE) %||% list()
   new_props <- as_properties(properties)
   check_prop_names(new_props)
+
   all_props[names(new_props)] <- new_props
 
   if (is.null(constructor)) {
-    constructor <- new_constructor(parent, all_props,
-                                   envir = parent.frame(),
-                                   package = package)
+    constructor <- new_constructor(
+      parent,
+      all_props,
+      envir = parent.frame(),
+      package = package
+    )
   }
 
   object <- constructor
@@ -150,7 +157,15 @@ new_class <- function(
   global_variables(names(all_props))
   object
 }
-globalVariables(c("name", "parent", "package", "properties", "abstract", "constructor", "validator"))
+globalVariables(c(
+  "name",
+  "parent",
+  "package",
+  "properties",
+  "abstract",
+  "constructor",
+  "validator"
+))
 
 #' @rawNamespace if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name)
 S7_class_name <- function(x) {
@@ -203,7 +218,12 @@ print.S7_class <- function(x, ...) {
 #' @export
 str.S7_class <- function(object, ..., nest.lev = 0) {
   cat(if (nest.lev > 0) " ")
-  cat("<", paste0(class_dispatch(object), collapse = "/"), "> constructor", sep = "")
+  cat(
+    "<",
+    paste0(class_dispatch(object), collapse = "/"),
+    "> constructor",
+    sep = ""
+  )
   cat("\n")
 
   if (nest.lev == 0) {
@@ -248,7 +268,10 @@ new_object <- function(.parent, ...) {
     stop("`new_object()` must be called from within a constructor")
   }
   if (class@abstract) {
-    msg <- sprintf("Can't construct an object from abstract class <%s>", class@name)
+    msg <- sprintf(
+      "Can't construct an object from abstract class <%s>",
+      class@name
+    )
     stop(msg)
   }
 
@@ -265,20 +288,22 @@ new_object <- function(.parent, ...) {
 
   attrs <- c(
     list(class = class_dispatch(class), S7_class = class),
-    args[!has_setter],
+    with_remap_reserved_names(args[!has_setter]),
     attributes(object)
   )
   attrs <- attrs[!duplicated(names(attrs))]
   attributes(object) <- attrs
 
   # invoke custom property setters
   prop_setter_vals <- args[has_setter]
-  for (name in names(prop_setter_vals))
+  for (name in names(prop_setter_vals)) {
     prop(object, name, check = FALSE) <- prop_setter_vals[[name]]
+  }
 
   # Don't need to validate if parent class already validated,
   # i.e. it's a non-abstract S7 class
-  parent_validated <- inherits(class@parent, "S7_object") && !class@parent@abstract
+  parent_validated <- inherits(class@parent, "S7_object") &&
+    !class@parent@abstract
   validate(object, recursive = !parent_validated)
 
   object
@@ -295,8 +320,9 @@ str.S7_object <- function(object, ..., nest.lev = 0) {
   cat(obj_desc(object))
 
   if (!is_S7_type(object)) {
-    if (!typeof(object) %in% c("numeric", "integer", "character", "double"))
+    if (!typeof(object) %in% c("numeric", "integer", "character", "double")) {
       cat(" ")
+    }
 
     attrs <- attributes(object)
     if (is.environment(object)) {
@@ -328,15 +354,38 @@ S7_class <- function(object) {
   attr(object, "S7_class", exact = TRUE)
 }
 
-
 check_prop_names <- function(properties, error_call = sys.call(-1L)) {
-  # these attributes have special C handlers in base R
-  forbidden <- c("names", "dim", "dimnames", "class",
-                 "tsp", "comment", "row.names", "...")
+  forbidden <- c("...")
   forbidden <- intersect(forbidden, names(properties))
   if (length(forbidden)) {
-    msg <- paste0("property can't be named: ",
-                  paste0(forbidden, collapse = ", "))
+    msg <- paste0(
+      "property can't be named: ",
+      paste0("'", forbidden, "'", collapse = ", ")
+    )
     stop(simpleError(msg, error_call))
   }
 }
+
+remap_reserved_names <- function(names) {
+  # these attributes have special C handlers in base R
+  forbidden <- c(
+    "names",
+    "dim",
+    "dimnames",
+    "class",
+    "tsp",
+    "comment",
+    "row.names",
+    "..."
+  )
+
+  is_forbidden <- names %in% forbidden
+  names[is_forbidden] <- paste0(".__S7_prop__", names[is_forbidden], "__")
+
+  names
+}
+
+with_remap_reserved_names <- function(x) {
+  names(x) <- remap_reserved_names(names(x))
+  x
+}

R/property.R

@@ -40,7 +40,7 @@
 #'   function promise in the default constructor, evaluated at the time the
 #'   object is constructed.
 #' @param name Property name, primarily used for error messages. Generally
-#'   don't need to set this here, as it's more convenient to supply as 
+#'   don't need to set this here, as it's more convenient to supply as
 #'   the element name when defining a list of properties. If both `name`
 #'   and a list-name are supplied, the list-name will be used.
 #' @returns An S7 property, i.e. a list with class `S7_property`.
@@ -72,12 +72,14 @@
 #' # argument to the default constructor
 #' try(Clock(now = 10))
 #' args(Clock)
-new_property <- function(class = class_any,
-                         getter = NULL,
-                         setter = NULL,
-                         validator = NULL,
-                         default = NULL,
-                         name = NULL) {
+new_property <- function(
+  class = class_any,
+  getter = NULL,
+  setter = NULL,
+  validator = NULL,
+  default = NULL,
+  name = NULL
+) {
   class <- as_class(class)
   check_prop_default(default, class)
 
@@ -119,7 +121,7 @@ check_prop_default <- function(default, class, error_call = sys.call(-1)) {
       # The meaning of a `...` prop default needs discussion
       stop(simpleError("`default` cannot be `...`", error_call))
     }
-    if (identical(default, quote(expr =))) {
+    if (identical(default, quote(expr = ))) {
       # The meaning of a missing prop default needs discussion
       stop(simpleError("`default` cannot be missing", error_call))
     }
@@ -128,11 +130,15 @@ check_prop_default <- function(default, class, error_call = sys.call(-1)) {
     return()
   }
 
-  if (class_inherits(default, class))
+  if (class_inherits(default, class)) {
     return()
+  }
 
-  msg <- sprintf("`default` must be an instance of %s, not a %s",
-                 class_desc(class), obj_desc(default))
+  msg <- sprintf(
+    "`default` must be an instance of %s, not a %s",
+    class_desc(class),
+    obj_desc(default)
+  )
 
   stop(simpleError(msg, error_call))
 }
@@ -188,7 +194,8 @@ prop_default <- function(prop, envir, package) {
 #' lexington@height <- 14
 #' prop(lexington, "height") <- 15
 prop <- function(object, name) {
-  .Call(prop_, object, name)
+  attr_name <- remap_reserved_names(name)
+  .Call(prop_, object, name, attr_name)
 }
 
 propr <- function(object, name) {
@@ -229,11 +236,12 @@ prop_obj <- function(object, name) {
 #'   [validate()] on the object before returning.
 #' @export
 `prop<-` <- function(object, name, check = TRUE, value) {
-  .Call(prop_set_, object, name, check, value)
+  attr_name <- remap_reserved_names(name)
+  .Call(prop_set_, object, name, attr_name, check, value)
 }
 
 `propr<-` <- local({
-    # reference implementation of `prop<-()` implemented in R
+  # reference implementation of `prop<-()` implemented in R
   # This flag is used to avoid infinite loops if you are assigning a property from a setter function
   setter_property <- NULL
 
@@ -246,7 +254,11 @@ prop_obj <- function(object, name) {
     }
 
     if (!is.null(prop$getter) && is.null(prop$setter)) {
-      msg <- sprintf("Can't set read-only property %s@%s", obj_desc(object), name)
+      msg <- sprintf(
+        "Can't set read-only property %s@%s",
+        obj_desc(object),
+        name
+      )
       stop(msg, call. = FALSE)
     }
 
@@ -293,7 +305,8 @@ prop_error_unknown <- function(object, prop_name) {
 # called from src/prop.c
 prop_validate <- function(prop, value, object = NULL) {
   if (!class_inherits(value, prop$class)) {
-    return(sprintf("%s must be %s, not %s",
+    return(sprintf(
+      "%s must be %s, not %s",
       prop_label(object, prop$name),
       class_desc(prop$class),
       obj_desc(value)
@@ -319,7 +332,8 @@ prop_validate <- function(prop, value, object = NULL) {
 
   stop(sprintf(
     "%s validator must return NULL or a character, not <%s>.",
-    prop_label(object, prop$name), typeof(val)
+    prop_label(object, prop$name),
+    typeof(val)
   ))
 }
 
@@ -363,7 +377,15 @@ prop_names <- function(object) {
 
   if (inherits(object, "S7_class")) {
     # S7_class isn't a S7_class (somewhat obviously) so we fake the property names
-    c("name", "parent", "package", "properties", "abstract", "constructor", "validator")
+    c(
+      "name",
+      "parent",
+      "package",
+      "properties",
+      "abstract",
+      "constructor",
+      "validator"
+    )
   } else {
     class <- S7_class(object)
     props <- attr(class, "properties", exact = TRUE)
@@ -473,7 +495,6 @@ as_properties <- function(x) {
 }
 
 as_property <- function(x, name, i) {
-
   if (is_property(x)) {
     if (name == "") {
       if (is.null(x$name)) {
@@ -502,4 +523,3 @@ prop_is_read_only <- function(prop) {
 prop_has_setter <- function(prop) is.function(prop$setter)
 
 prop_is_dynamic <- function(prop) is.function(prop$getter)
-

src/init.c

@@ -9,16 +9,16 @@ extern SEXP method_call_(SEXP, SEXP, SEXP, SEXP);
 extern SEXP test_call_(SEXP, SEXP, SEXP, SEXP);
 extern SEXP S7_class_(SEXP, SEXP);
 extern SEXP S7_object_(void);
-extern SEXP prop_(SEXP, SEXP);
-extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP);
+extern SEXP prop_(SEXP, SEXP, SEXP);
+extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP, SEXP);
 
 #define CALLDEF(name, n)  {#name, (DL_FUNC) &name, n}
 
 static const R_CallMethodDef CallEntries[] = {
     CALLDEF(method_, 4),
     CALLDEF(S7_object_, 0),
-    CALLDEF(prop_, 2),
-    CALLDEF(prop_set_, 4),
+    CALLDEF(prop_, 3),
+    CALLDEF(prop_set_, 5),
     {NULL, NULL, 0}
 };