diff --git a/NEWS.md b/NEWS.md index a437adbb..ee673c2c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # S7 (development version) +* Base type wrappers like `class_integer` now define their constructor and validator in the S7 namespace. (#553). * `method<-` now accepts `NULL` to unregister an existing method, e.g. `method(foo, class_character) <- NULL` (#613). * `new_object()` no longer materialises ALTREP parent values (e.g. `seq_len()`), so constructing an S7 object that wraps a large compact integer sequence is now O(1) in memory instead of O(n) (@kschaubroeck, #607). * Internal changes to support R-devel (4.6) (#592, #593, #598, #600). diff --git a/R/base.R b/R/base.R index 54f67c88..aabf0037 100644 --- a/R/base.R +++ b/R/base.R @@ -3,17 +3,21 @@ new_base_class <- function(name, constructor_name = name) { constructor <- new_function( args = list(.data = base_default(name)), - body = quote(.data), - env = baseenv() + body = quote(.data) ) - validator <- function(object) { - if (base_class(object) != name) { - sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) - } - } - - validator <- utils::removeSource(validator) + validator <- new_function( + args = alist(object = ), + body = bquote( + if (base_class(object) != .(name)) { + sprintf( + "Underlying data must be <%s> not <%s>", + .(name), + base_class(object) + ) + } + ) + ) out <- list( class = name, diff --git a/R/class-spec.R b/R/class-spec.R index 03fb7fe4..180908d8 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -132,9 +132,8 @@ class_construct_expr <- function(.x, envir = NULL, package = NULL) { # (mostly for nicer printing and introspection.) # 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())) { + if (!identical(fe, baseenv()) && !identical(fe, asNamespace("S7"))) { return(as.call(list(f))) } diff --git a/tests/testthat/test-base.R b/tests/testthat/test-base.R index a25ee1f2..9c73c8df 100644 --- a/tests/testthat/test-base.R +++ b/tests/testthat/test-base.R @@ -8,6 +8,11 @@ test_that("validation uses typeof", { expect_equal(class_function$validator(mean), NULL) }) +test_that("constructor and validator live in the S7 namespace (#553)", { + expect_identical(environment(class_integer$constructor), asNamespace("S7")) + expect_identical(environment(class_integer$validator), asNamespace("S7")) +}) + test_that("base class display as expected", { expect_snapshot({ class_integer