diff --git a/R/class.R b/R/class.R index 4b639e53..2c98e05b 100644 --- a/R/class.R +++ b/R/class.R @@ -90,6 +90,7 @@ new_class <- function( parent = R7_object, package = NULL, properties = list(), + methods = list(), constructor = NULL, validator = NULL) { @@ -120,6 +121,10 @@ new_class <- function( new_props <- as_properties(properties) all_props[names(new_props)] <- new_props + # Combine methods from parent, overriding as needed + all_methods <- attr(parent, "methods", exact = TRUE) %||% list() + all_methods[names(methods)] <- methods + if (is.null(constructor)) { constructor <- new_constructor(parent, all_props) } @@ -130,6 +135,7 @@ new_class <- function( attr(object, "parent") <- parent attr(object, "package") <- package attr(object, "properties") <- all_props + attr(object, "methods") <- all_methods attr(object, "constructor") <- constructor attr(object, "validator") <- validator class(object) <- c("R7_class", "R7_object") @@ -137,7 +143,7 @@ new_class <- function( global_variables(names(all_props)) object } -globalVariables(c("name", "parent", "package", "properties", "constructor", "validator")) +globalVariables(c("name", "parent", "package", "properties", "methods", "constructor", "validator")) R7_class_name <- function(x) { paste(c(x@package, x@name), collapse = "::") diff --git a/R/method.R b/R/method.R new file mode 100644 index 00000000..f7e2c7ac --- /dev/null +++ b/R/method.R @@ -0,0 +1,15 @@ +method_exists <- function(object, name) { + if (!inherits(object, "R7_object")) return(FALSE) + name %in% names(attr(R7_class(object), "methods")) +} + +method_val <- function(object, name) { + class <- R7_class(object) + method <- class@methods[[name]] + + # TODO: clone arguments + # TODO: think about performance? + function(...) { + method(object, ...) + } +} diff --git a/R/property.R b/R/property.R index a58eadce..494b24cb 100644 --- a/R/property.R +++ b/R/property.R @@ -152,10 +152,12 @@ prop_default <- function(prop) { prop <- function(object, name) { check_R7(object) - if (!prop_exists(object, name)) { - stop(prop_error_unknown(object, name)) - } else { + if (prop_exists(object, name)) { prop_val(object, name) + } else if (method_exists(object, name)) { + method_val(object, name) + } else { + stop(prop_error_unknown(object, name)) } } @@ -264,7 +266,7 @@ prop_names <- function(object) { if (inherits(object, "R7_class")) { # R7_class isn't a R7_class (somewhat obviously) so we fake the property names - c("name", "parent", "package", "properties", "constructor", "validator") + c("name", "parent", "package", "properties", "methods", "constructor", "validator") } else { class <- R7_class(object) props <- attr(class, "properties", exact = TRUE) diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index f60260f4..6673a3d6 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -29,6 +29,7 @@ .. ..$ getter : NULL .. ..$ setter : NULL .. ..$ default: NULL + @ methods : list() @ constructor: function (x = missing_class, y = missing_class) @ validator : NULL Code