diff --git a/NEWS.md b/NEWS.md index b1f3853f..c7ee666b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -38,6 +38,7 @@ * `S7_on_load()` is the new name for `methods_register()`, giving it a nicer symmetry with `S7_on_build()`; `methods_register()` remains available for backward compatibility (#615). * `str()` on S7 objects that inherit from data.frame (or other S3 classes whose underlying data has a `dim` attribute incompatible with the bare base type) no longer errors (#494). * `super()` now works with S3 and S4 objects, not just S7 objects (#500). +* `trace()` and `untrace()` now work with S7 generics and methods, e.g. `trace("myclass", browser, where = my_generic@methods)` sets a breakpoint in the method for `myclass` (#584). * `validate()` now signals validation errors with class `S7_error_validation_failed`, so they can be caught with `tryCatch()` (#602, #605). # S7 0.2.2 diff --git a/R/zzz.R b/R/zzz.R index 5b9bc2fe..c8a17d1b 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -128,6 +128,44 @@ on_load_define_S7_method <- function() { } methods::setOldClass(c("S7_method", "function", "S7_object")) +# trace() builds a "WithTrace" S4 class for the traced function on +# the fly, but the machinery it uses assumes that class() returns a single +# string, which isn't true for S7 generics and methods. So we register the +# traceable classes in advance, along with an initialize method that works +# around the same assumption in methods:::.initTraceable() by giving it a +# classless copy of the function (#584). +make_traceable <- function(class, props) { + slots <- rep(list("ANY"), length(props)) + names(slots) <- props + + methods::setClass( + paste0(class, "WithTrace"), + contains = c(class, "traceable"), + slots = slots + ) + methods::setMethod( + "initialize", + paste0(class, "WithTrace"), + function(.Object, def, ...) { + if (missing(def)) { + return(methods::callNextMethod(.Object, ...)) + } + original <- def + class(def) <- NULL + .Object <- methods::callNextMethod(.Object, def = def, ...) + .Object@original <- original + # Mirror the S7 properties so introspection (e.g. print methods that + # access x@generic) keeps working on the traced object + for (prop in props) { + methods::slot(.Object, prop) <- attr(original, prop, exact = TRUE) + } + .Object + } + ) +} +make_traceable("S7_generic", c("name", "methods", "dispatch_args")) +make_traceable("S7_method", c("generic", "signature")) + # hooks ------------------------------------------------------------------- .onAttach <- function(libname, pkgname) { diff --git a/src/method-dispatch.c b/src/method-dispatch.c index 51dd19b3..6383e458 100644 --- a/src/method-dispatch.c +++ b/src/method-dispatch.c @@ -165,9 +165,16 @@ SEXP method_call_(SEXP call_, SEXP op_, SEXP args_, SEXP env_) { SEXP envir = CAR(args_); args_ = CDR(args_); if (!Rf_inherits(generic, "S7_generic")) { - SEXP err_call = PROTECT(Rf_lang1(Rf_install("dispatch_not_generic_error"))); - Rf_eval(err_call, ns_S7); - UNPROTECT(1); // never reached + // A generic modified by trace() is an S4 object that wraps the real + // generic in its "original" attribute + SEXP original = Rf_getAttrib(generic, Rf_install("original")); + if (Rf_inherits(original, "S7_generic")) { + generic = original; + } else { + SEXP err_call = PROTECT(Rf_lang1(Rf_install("dispatch_not_generic_error"))); + Rf_eval(err_call, ns_S7); + UNPROTECT(1); // never reached + } } // Get the number of arguments to the generic diff --git a/tests/testthat/test-zzz.R b/tests/testthat/test-zzz.R index a204ad28..5fb139fb 100644 --- a/tests/testthat/test-zzz.R +++ b/tests/testthat/test-zzz.R @@ -49,3 +49,54 @@ test_that("register S4 classes for key components", { expect_s4_class(getClass("S7_method"), "classRepresentation") expect_s4_class(getClass("S7_generic"), "classRepresentation") }) + +test_that("S7 methods can be traced", { + my_generic <- new_generic("my_generic", "x") + my_class <- new_class("my_class", package = NULL) + method(my_generic, my_class) <- function(x) "result" + original <- method(my_generic, my_class) + obj <- my_class() + + calls <- new.env() + calls$n <- 0 + tracer <- function() calls$n <- calls$n + 1 + + suppressMessages( + trace("my_class", tracer, print = FALSE, where = my_generic@methods) + ) + expect_equal(my_generic(obj), "result") + expect_equal(calls$n, 1) + expect_output( + print(method(my_generic, my_class)), + "", + fixed = TRUE + ) + + suppressMessages(untrace("my_class", where = my_generic@methods)) + expect_identical(method(my_generic, my_class), original) + expect_equal(my_generic(obj), "result") + expect_equal(calls$n, 1) +}) + +test_that("S7 generics can be traced", { + my_generic <- new_generic("my_generic", "x") + my_class <- new_class("my_class", package = NULL) + method(my_generic, my_class) <- function(x) "result" + obj <- my_class() + + calls <- new.env() + calls$n <- 0 + tracer <- function() calls$n <- calls$n + 1 + + suppressMessages( + trace("my_generic", tracer, print = FALSE, where = environment()) + ) + expect_equal(my_generic(obj), "result") + expect_equal(calls$n, 1) + expect_output(print(my_generic), "", fixed = TRUE) + + suppressMessages(untrace("my_generic", where = environment())) + expect_s3_class(my_generic, "S7_generic") + expect_equal(my_generic(obj), "result") + expect_equal(calls$n, 1) +})