diff --git a/R/class-spec.R b/R/class-spec.R index d4cee692..59abc4cb 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -59,30 +59,15 @@ is_foundation_class <- function(x) { } class_type <- function(x) { - if (is.null(x)) { - "NULL" - } else if (is_class_missing(x)) { - "missing" - } else if (is_class_any(x)) { - "any" - } else if (is_base_class(x)) { - "S7_base" - } else if (is_class(x)) { - "S7" - } else if (is_union(x)) { - "S7_union" - } else if (is_S3_class(x)) { - "S7_S3" - } else if (is_external_class(x)) { - "S7_external" - } else if (is_S4_class(x)) { - "S4" - } else { - stop2("`x` is not a standard S7 class.", call = NULL) - } + .Call(class_type_, x) } class_properties <- function(x) { + # Needed to bootstrap S7 before DLL registered + if (is.null(x)) { + return(list()) + } + switch( class_type(x), S7 = attr(x, "properties", exact = TRUE) %||% list(), @@ -288,11 +273,12 @@ class_dispatch <- function(x) { missing = "MISSING", any = character(), S4 = S4_class_dispatch(methods::extends(x)), - S7 = c( - S7_class_name(x), - class_dispatch(x@parent), - if (is_S4_class(x@parent)) "S7_object" - ), + S7 = attr(x, "_S7_dispatch", exact = TRUE) %||% + c( + S7_class_name(x), + class_dispatch(x@parent), + if (is_S4_class(x@parent)) "S7_object" + ), S7_base = c(x$class, "S7_object"), S7_S3 = c(x$class, "S7_object"), S7_external = class_dispatch(resolve_external_class_req(x)), @@ -342,13 +328,26 @@ class_deparse <- function(x) { } class_inherits <- function(x, what) { + if (is_class(what)) { + if (!has_S7_class(x)) { + return(FALSE) + } else { + dispatch <- attr(what, "_S7_dispatch", exact = TRUE) + class_name <- if (is.null(dispatch)) { + S7_class_name(what) + } else { + dispatch[[1]] + } + return(inherits(x, class_name)) + } + } + switch( class_type(what), "NULL" = is.null(x), missing = FALSE, any = TRUE, S4 = methods::is(x, what), - S7 = has_S7_class(x) && inherits(x, S7_class_name(what)), S7_base = what$class == base_class(x), S7_union = some(what$classes, class_inherits, x = x), S7_S3 = !isS4(x) && class_dispatch_extends(what$class, class(x)), diff --git a/R/class.R b/R/class.R index 371e90f6..a246d579 100644 --- a/R/class.R +++ b/R/class.R @@ -174,6 +174,16 @@ new_class <- function( attr(object, "constructor") <- constructor attr(object, "validator") <- validator class(object) <- c("S7_class", "S7_object") + if (identical(name, "S7_object")) { + dispatch <- "S7_object" + } else { + dispatch <- c( + paste(c(package, name), collapse = "::"), + class_dispatch(parent), + if (is_S4_class(parent)) "S7_object" + ) + } + attr(object, "_S7_dispatch") <- dispatch if (S7_extends_S4(object)) { S4_register_subclass(object, env = parent.frame()) diff --git a/src/class-type.c b/src/class-type.c new file mode 100644 index 00000000..208cbe8e --- /dev/null +++ b/src/class-type.c @@ -0,0 +1,91 @@ +#include "compat.h" + +static SEXP type_NULL; +static SEXP type_missing; +static SEXP type_any; +static SEXP type_S7_base; +static SEXP type_S7; +static SEXP type_S7_union; +static SEXP type_S7_S3; +static SEXP type_S7_external; +static SEXP type_S4; + +static SEXP class_missing; +static SEXP class_any; +static SEXP class_S7_base; +static SEXP class_S7; +static SEXP class_S7_union; +static SEXP class_S7_S3; +static SEXP class_S7_external; +static SEXP class_S4; + +static SEXP preserve_string(const char* x) { + SEXP out = Rf_mkString(x); + R_PreserveObject(out); + return out; +} + +void class_type_init(void) { + type_NULL = preserve_string("NULL"); + type_missing = preserve_string("missing"); + type_any = preserve_string("any"); + type_S7_base = preserve_string("S7_base"); + type_S7 = preserve_string("S7"); + type_S7_union = preserve_string("S7_union"); + type_S7_S3 = preserve_string("S7_S3"); + type_S7_external = preserve_string("S7_external"); + type_S4 = preserve_string("S4"); + + class_missing = PRINTNAME(Rf_install("S7_missing")); + class_any = PRINTNAME(Rf_install("S7_any")); + class_S7_base = PRINTNAME(Rf_install("S7_base_class")); + class_S7 = PRINTNAME(Rf_install("S7_class")); + class_S7_union = PRINTNAME(Rf_install("S7_union")); + class_S7_S3 = PRINTNAME(Rf_install("S7_S3_class")); + class_S7_external = PRINTNAME(Rf_install("S7_external_class")); + class_S4 = PRINTNAME(Rf_install("classRepresentation")); +} + +SEXP class_type_(SEXP x) { + if (x == R_NilValue) + return type_NULL; + + SEXP classes = Rf_getAttrib(x, R_ClassSymbol); + int type = 9; + + if (TYPEOF(classes) == STRSXP) { + for (R_xlen_t i = 0; i < Rf_xlength(classes); ++i) { + SEXP cls = STRING_ELT(classes, i); + + if (type > 1 && cls == class_missing) + type = 1; + else if (type > 2 && cls == class_any) + type = 2; + else if (type > 3 && cls == class_S7_base) + type = 3; + else if (type > 4 && cls == class_S7) + type = 4; + else if (type > 5 && cls == class_S7_union) + type = 5; + else if (type > 6 && cls == class_S7_S3) + type = 6; + else if (type > 7 && cls == class_S7_external) + type = 7; + else if (type > 8 && cls == class_S4) + type = 8; + } + } + + switch (type) { + case 1: return type_missing; + case 2: return type_any; + case 3: return type_S7_base; + case 4: return type_S7; + case 5: return type_S7_union; + case 6: return type_S7_S3; + case 7: return type_S7_external; + case 8: return type_S4; + } + + Rf_error("`x` is not a standard S7 class."); +} diff --git a/src/init.c b/src/init.c index cf8f28ac..4a880f96 100644 --- a/src/init.c +++ b/src/init.c @@ -12,7 +12,9 @@ extern SEXP prop_(SEXP, SEXP); extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP); extern SEXP prop_storage_rename_(SEXP); extern SEXP S7_eval_bare_(SEXP, SEXP); +extern SEXP class_type_(SEXP); extern void prop_init(void); +extern void class_type_init(void); #define CALLDEF(name, n) {#name, (DL_FUNC) &name, n} @@ -24,6 +26,7 @@ static const R_CallMethodDef CallEntries[] = { CALLDEF(prop_set_, 4), CALLDEF(prop_storage_rename_, 1), CALLDEF(S7_eval_bare_, 2), + CALLDEF(class_type_, 1), {NULL, NULL, 0} }; @@ -133,6 +136,7 @@ void R_init_S7(DllInfo *dll) R_PreserveObject(R_TRUE = Rf_ScalarLogical(1)); R_PreserveObject(R_FALSE = Rf_ScalarLogical(0)); prop_init(); + class_type_init(); R_PreserveObject(s7_proto_object = make_s7_proto_object()); R_PreserveObject(missing_call = Rf_lang2(fn_base_missing, R_NilValue)); } diff --git a/tests/testthat/_snaps/class-spec.md b/tests/testthat/_snaps/class-spec.md index 6afcb46e..d994d737 100644 --- a/tests/testthat/_snaps/class-spec.md +++ b/tests/testthat/_snaps/class-spec.md @@ -1,3 +1,11 @@ +# class_type() recognizes special class specifications + + Code + class_type(1) + Condition + Error in `class_type()`: + ! `x` is not a standard S7 class. + # S7_class_desc() formats every supported class spec Code diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 2879f3b7..83e411ca 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -304,3 +304,4 @@ Condition Error: ! No S7 class for base type . + diff --git a/tests/testthat/test-class-spec.R b/tests/testthat/test-class-spec.R index d1cb05c4..503178d2 100644 --- a/tests/testthat/test-class-spec.R +++ b/tests/testthat/test-class-spec.R @@ -34,6 +34,54 @@ test_that("can work with S7 classes in packages", { expect_equal(class_inherits(obj, klass), TRUE) }) +test_that("S7 class dispatch is cached", { + parent := new_class(package = "pkg") + child := new_class(parent = parent, package = "pkg") + obj <- child() + + expect_identical( + attr(child, "_S7_dispatch", exact = TRUE), + c("pkg::child", "pkg::parent", "S7_object") + ) + + local_mocked_bindings( + S7_class_name = function(...) stop("Recomputed class name") + ) + expect_equal(class_inherits(obj, parent), TRUE) +}) + +test_that("S7 class dispatch supports classes without a cache", { + parent := new_class(package = "pkg") + child := new_class(parent = parent, package = "pkg") + obj <- child() + + # Classes created by older versions of S7 don't have a cache + attr(child, "_S7_dispatch") <- NULL + expect_identical( + class_dispatch(child), + c("pkg::child", "pkg::parent", "S7_object") + ) + expect_equal(class_inherits(obj, child), TRUE) +}) + +test_that("class_inherits() handles special S7 objects", { + Child := new_class(package = NULL) + + expect_equal(class_inherits(S7_object(), S7_object), TRUE) + expect_equal(class_inherits(Child, S7_object), TRUE) + expect_equal(class_inherits(structure(1, class = "Child"), Child), FALSE) +}) + +test_that("class_type() recognizes special class specifications", { + expect_identical(class_type(class_missing), "missing") + expect_identical(class_type(class_any), "any") + expect_identical( + class_type(structure(list(), class = c("S7_external_class", "S7_any"))), + "any" + ) + expect_snapshot(class_type(1), error = TRUE) +}) + test_that("can work with unions", { text := new_class(class_character, package = NULL) number := new_class(class_double, package = NULL) diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index bc63d0d0..4d10e736 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -1,7 +1,10 @@ test_that("S7 classes possess expected properties", { foo := new_class(package = "S7", validator = function(self) NULL) - expect_equal(prop_names(foo), setdiff(names(attributes(foo)), "class")) + expect_equal( + prop_names(foo), + setdiff(names(attributes(foo)), c("class", "_S7_dispatch")) + ) expect_type(foo@name, "character") expect_equal(foo@parent, S7_object) expect_type(foo@constructor, "closure") @@ -369,6 +372,18 @@ test_that("new_object() errors if `_parent` doesn't inherit from the parent clas }) }) +test_that("new_object() accepts an instance of a subclass of the parent", { + Parent := new_class(package = NULL) + Sibling := new_class(parent = Parent, package = NULL) + Child := new_class( + parent = Parent, + package = NULL, + constructor = function(parent) new_object(parent) + ) + + expect_identical(S7_class(Child(Sibling())), Child) +}) + test_that("new_object() allows S7_object placeholder for abstract parents", { Abstract := new_class( package = NULL,