Skip to content

Check that overriden properties narrow the type specification #691

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
hadley merged 10 commits into from
Jun 15, 2026
Merged

Check that overriden properties narrow the type specification #691

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
10 commits
Select commit Hold shift + click to select a range
634c2fe
Check that overriden properties narrow the type specification
hadley Jun 9, 2026
4d6fbc0
Allow `NULL` to narrow optional union properties
t-kalinowski Jun 15, 2026
804dcb4
Allow bundled S3 property narrowing
t-kalinowski Jun 15, 2026
0954c70
Allow S4 property subclasses to narrow base types
t-kalinowski Jun 15, 2026
102c378
Reject unsafe S4 property narrowing
t-kalinowski Jun 15, 2026
cd561d4
Reject invalid property narrowing
t-kalinowski Jun 15, 2026
5bd2b12
Reject implicit base property narrowing
t-kalinowski Jun 15, 2026
3d23dc1
Remove undefined narrowing tests
t-kalinowski Jun 15, 2026
776ec6a
Back out conditional S4 extension handling
t-kalinowski Jun 15, 2026
8b14997
Test S4 property narrowing happy path
t-kalinowski Jun 15, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions NEWS.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,7 @@
* `method<-` now gives a clear error when assigning a primitive function (e.g. `log`) as a method (#608).
* `method<-` and `method()` now accept a length-1 list as `signature` for single-dispatch generics, matching the list-of-classes form required for multi-dispatch (#555).
* `method<-` can now register methods on S3 and S4 generics with base types (e.g. `class_character`), S3 classes (`new_S3_class()`, `class_factor`, etc.), S7 unions (expanded to one registration per class), `class_any` (registered as the `default` method), and `NULL` (registered as the `NULL` method) (#455).
* `new_class()` now errors if a child class overrides a parent property with a type that doesn't extend the parent's type, since such a class could never be instantiated. Narrowing the type is still allowed, as are dynamic (getter) properties (#352).
* `new_class()` now allows properties named `names`, `dim`, `dimnames`, `class`, `comment`, `tsp`, and `row.names`. But property names beginning with `_` are now reserved for internal use (#579).
* `new_class()` experimentally allows `class_environment` as a parent again, so you can build S7 objects that share R's reference semantics for environments. This support is provisional: because environments are mutated in place, some operations behave differently than for value-typed S7 objects, and the API may change. `S7_data()` and `S7_data<-()` error on environment-based objects, since they would otherwise destroy the object's S7 attributes in place (#590).
* `new_object()` now gives an informative error when `.parent` is a class specification rather than an instance of the parent class (#409).
Expand Down
37 changes: 37 additions & 0 deletions R/class-spec.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -307,6 +307,39 @@ class_inherits <- function(x, what) {
)
}

# Is every instance of `child` guaranteed to also be an instance of `parent`?
# Used to check that a child class only narrows the type of a property
class_extends <- function(child, parent) {
if (is_class_any(parent) || union_contains_any(parent)) {
# as a parent, `class_any` accepts every child class
TRUE
} else if (is_class_any(child)) {
# as a child, `class_any` only allows `class_any` as a parent
FALSE
} else if (is_union(child)) {
# A union child extends `parent` only if every one of its members does.
all(vlapply(child$classes, class_extends, parent = parent))
} else if (is_union(parent)) {
# A non-union child extends a union parent if it extends any of its members.
any(vlapply(parent$classes, class_extends, child = child))
} else if (is.null(child) && !is.null(parent)) {
# as a child, NULL can only extend NULL
FALSE
} else if (is.null(parent)) {
# as a parent, NULL only accepts NULL
is.null(child)
} else if (is_S4_class(child) || is_S4_class(parent)) {
is_S4_class(child) &&
is_S4_class(parent) &&
methods::extends(child@className, parent@className)
} else if (is_class(parent) && parent@name == "S7_object") {
is_class(child)
} else {
# handle S7, S3, and base types.
class_dispatch_extends(class_dispatch(parent), class_dispatch(child))
}
}

obj_type <- function(x) {
if (identical(x, quote(expr = ))) {
"missing"
Expand Down Expand Up @@ -358,5 +391,9 @@ drop_S7_object <- function(x) {
if (n > 0 && x[[n]] == "S7_object") x[-n] else x
}

union_contains_any <- function(x) {
is_union(x) && any(vlapply(x$classes, is_class_any))
}

# Suppress @className false positive
globalVariables("className")
45 changes: 44 additions & 1 deletion R/class.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -131,9 +131,12 @@ new_class <- function(
}

# Combine properties from parent, overriding as needed
all_props <- attr(parent, "properties", exact = TRUE) %||% list()
parent_props <- attr(parent, "properties", exact = TRUE) %||% list()
new_props <- as_properties(properties)
check_prop_names(new_props)
check_prop_overrides(new_props, parent_props, name, parent)

all_props <- parent_props
all_props[names(new_props)] <- new_props

if (is.null(constructor)) {
Expand Down Expand Up @@ -425,3 +428,43 @@ check_prop_names <- function(properties, call = sys.call(-1L)) {
stop2("Properties can't be named \"...\".", call = call)
}
}

check_prop_overrides <- function(
child_props,
parent_props,
name,
parent,
call = sys.call(-1L)
) {
overridden <- intersect(names(child_props), names(parent_props))

for (prop in overridden) {
child_prop <- child_props[[prop]]

# Dynamic properties are computed, not stored, so they're never validated
# against the parent's type
if (prop_is_dynamic(child_prop)) {
next
}

child_class <- child_prop$class
parent_class <- parent_props[[prop]]$class

if (!class_extends(child_class, parent_class)) {
child_desc <- paste0("<", name, ">")
parent_desc <- class_desc(parent)
msg <- c(
sprintf(
"%s@%s must narrow %s@%s.",
child_desc,
prop,
parent_desc,
prop
),
sprintf("- %s@%s is %s.", parent_desc, prop, class_desc(parent_class)),
sprintf("- %s@%s is %s.", child_desc, prop, class_desc(child_class))
)
stop2(msg, call = call)
}
}
}
24 changes: 24 additions & 0 deletions tests/testthat/_snaps/class.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -125,6 +125,30 @@
* An S4 class object
* A base class

# inheritance / child properties can't widen or change the parent's type

Code
new_class("foo2", foo1, properties = list(x = class_character))
Condition
Error in `new_class()`:
! <foo2>@x must narrow <foo1>@x.
- <foo1>@x is <integer>.
- <foo2>@x is <character>.
Code
new_class("foo3", foo1, properties = list(x = class_numeric))
Condition
Error in `new_class()`:
! <foo3>@x must narrow <foo1>@x.
- <foo1>@x is <integer>.
- <foo3>@x is <integer> or <double>.
Code
new_class("foo4", foo1, properties = list(x = class_any))
Condition
Error in `new_class()`:
! <foo4>@x must narrow <foo1>@x.
- <foo1>@x is <integer>.
- <foo4>@x is <ANY>.

# abstract classes / can't be instantiated

Code
Expand Down
30 changes: 30 additions & 0 deletions tests/testthat/test-class-spec.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -102,6 +102,36 @@ test_that("class_inherits handles variation in class names", {
expect_false(class_inherits("x", class_function))
})

test_that("class_extends checks subclass relationship between classes", {
Parent <- new_class("Parent", package = NULL)
Child <- new_class("Child", parent = Parent, package = NULL)

expect_true(class_extends(Child, Parent))
expect_true(class_extends(Child, Child))
expect_false(class_extends(Parent, Child))

# base types
expect_true(class_extends(class_integer, class_integer))
expect_false(class_extends(class_integer, class_character))
})

test_that("class_extends handles unions, any, and NULL", {
# union parent accepts any member; union child must have all members extend
expect_true(class_extends(class_double, class_numeric))
expect_false(class_extends(class_numeric, class_double))
expect_true(class_extends(class_numeric, class_numeric))

# class_any is the top type
expect_true(class_extends(class_integer, class_any))
expect_false(class_extends(class_any, class_integer))
expect_true(class_extends(class_any, class_any))

# NULL only extends NULL
expect_true(class_extends(NULL, NULL))
expect_false(class_extends(NULL, class_integer))
expect_false(class_extends(class_integer, NULL))
})

test_that("dispatch for base objects use underlying type", {
expect_equal(obj_dispatch(1), "double")
expect_equal(obj_dispatch(1L), "integer")
Expand Down
118 changes: 118 additions & 0 deletions tests/testthat/test-class.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -84,6 +84,124 @@ describe("inheritance", {
expect_equal(names(foo2@properties), "x")
expect_equal(foo2@properties$x$class, class_double)
})
it("child properties can narrow the parent's type", {
Parent <- new_class("Parent", package = NULL)
Child <- new_class("Child", parent = Parent, package = NULL)
foo1 <- new_class("foo1", properties = list(x = Parent))
expect_no_error(new_class("foo2", foo1, properties = list(x = Child)))
expect_no_error(new_class(
"foo3",
foo1,
properties = list(x = new_property(Child, default = quote(Child())))
))
})
it("child properties can narrow with S4 inheritance", {
on.exit(S4_remove_classes(c("S4PropertyParent", "S4PropertyChild")))
S4PropertyParent <- methods::setClass(
"S4PropertyParent",
slots = c(x = "numeric")
)
S4PropertyChild <- methods::setClass(
"S4PropertyChild",
contains = "S4PropertyParent"
)

Parent <- new_class(
"Parent",
properties = list(x = S4PropertyParent),
package = NULL
)
Child <- new_class(
"Child",
Parent,
properties = list(x = S4PropertyChild),
package = NULL
)

x <- methods::new("S4PropertyChild", x = 1)
expect_s4_class(Child(x = x)@x, "S4PropertyChild")
})
it("child properties can't narrow S7_object with base or S3 classes", {
Parent <- new_class(
"Parent",
properties = list(x = S7_object),
package = NULL,
abstract = TRUE
)

expect_error(
new_class(
"IntegerChild",
Parent,
properties = list(x = class_integer),
package = NULL
),
"must narrow"
)
expect_error(
new_class(
"FormulaChild",
Parent,
properties = list(x = class_formula),
package = NULL
),
"must narrow"
)
})
it("child properties can narrow parent unions that include any", {
Parent <- new_class(
"Parent",
properties = list(x = class_any | class_integer),
package = NULL
)
expect_no_error(new_class(
"Child",
Parent,
properties = list(x = class_any),
package = NULL
))
})
it("child properties can narrow optional union properties with NULL", {
Parent <- new_class(
"Parent",
properties = list(x = NULL | class_numeric),
package = NULL
)

NullChild <- new_class(
"NullChild",
Parent,
properties = list(x = NULL),
package = NULL
)
expect_equal(NullChild()@x, NULL)

OptionalIntegerChild <- new_class(
"OptionalIntegerChild",
Parent,
properties = list(x = NULL | class_integer),
package = NULL
)
expect_equal(OptionalIntegerChild()@x, NULL)
expect_equal(OptionalIntegerChild(x = 1L)@x, 1L)
})
it("child properties can't widen or change the parent's type", {
foo1 <- new_class(
"foo1",
properties = list(x = class_integer),
package = NULL
)
expect_snapshot(error = TRUE, {
new_class("foo2", foo1, properties = list(x = class_character))
new_class("foo3", foo1, properties = list(x = class_numeric))
new_class("foo4", foo1, properties = list(x = class_any))
})
})
it("dynamic child properties can override any parent type", {
foo1 <- new_class("foo1", properties = list(x = class_integer))
readonly <- new_property(class_character, getter = function(self) "x")
expect_no_error(new_class("foo2", foo1, properties = list(x = readonly)))
})
})

describe("abstract classes", {
Expand Down
Loading