Make methods traceable

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

R/zzz.R

@@ -128,6 +128,44 @@ on_load_define_S7_method <- function() {
 }
 methods::setOldClass(c("S7_method", "function", "S7_object"))
 
+# trace() builds a "<class>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) {

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

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)),
+    "<S7_method>",
+    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), "<S7_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)
+})