Improve traceback() for dispatched methods (#486)

* Improve `traceback()` for dispatched methods

* fix typo, malformed test

* Update R/generic.R

Co-authored-by: Hadley Wickham <h.wickham@gmail.com>

* better snapshot tests

* delete unused helper

* whitespace

* `zap_srcref` before printing callstack in snapshot.

* use `utils::removeSource` instead of `rlang::zap_srcref`

* Add NEWS

---------

Co-authored-by: Hadley Wickham <h.wickham@gmail.com>

NEWS.md

@@ -1,5 +1,11 @@
 # S7 (development version)
 
+* The call context of a dispatched method (as visible in `sys.calls()` and
+  `traceback()`) no longer includes the inlined method and generic, resulting in
+  more compact and readable tracebacks. The dispatched method call now contains
+  only the method name, which serves as a hint for retrieving the method. For
+  example: `method(my_generic, class_double)`(x=10, ...). (#486)
+
 * `new_class()` now automatically infers the package name when called from 
   within an R package (#459).
 

R/generic.R

@@ -193,6 +193,9 @@ generic_add_method <- function(generic, signature, method) {
   p_tbl <- generic@methods
   chr_signature <- vcapply(signature, class_register)
 
+  if (is.null(attr(method, "name", TRUE)))
+    attr(method, "name") <- as.name(method_signature(generic, signature))
+
   for (i in seq_along(chr_signature)) {
     class_name <- chr_signature[[i]]
     if (i != length(chr_signature)) {

src/init.c

@@ -45,6 +45,8 @@ SEXP sym_dot_setting_prop;
 SEXP sym_obj_dispatch;
 SEXP sym_dispatch_args;
 SEXP sym_methods;
+SEXP sym_S7_dispatch;
+SEXP sym_name;
 
 SEXP fn_base_quote;
 SEXP fn_base_missing;
@@ -75,6 +77,8 @@ void R_init_S7(DllInfo *dll)
     sym_obj_dispatch = Rf_install("obj_dispatch");
     sym_dispatch_args = Rf_install("dispatch_args");
     sym_methods = Rf_install("methods");
+    sym_S7_dispatch = Rf_install("S7_dispatch");
+    sym_name = Rf_install("name");
 
     fn_base_quote = Rf_eval(Rf_install("quote"), R_BaseEnv);
     fn_base_missing = Rf_eval(Rf_install("missing"), R_BaseEnv);

src/method-dispatch.c

@@ -8,6 +8,9 @@ extern SEXP ns_S7;
 extern SEXP sym_obj_dispatch;
 extern SEXP sym_dispatch_args;
 extern SEXP sym_methods;
+extern SEXP sym_S7_dispatch;
+extern SEXP sym_name;
+
 extern SEXP fn_base_quote;
 extern SEXP fn_base_missing;
 
@@ -181,8 +184,8 @@ SEXP method_call_(SEXP call_, SEXP op_, SEXP args_, SEXP env_) {
   SEXP mcall_tail = mcall;
 
   PROTECT_INDEX arg_pi, val_pi;
-  PROTECT_WITH_INDEX(R_NilValue, &arg_pi);
-  PROTECT_WITH_INDEX(R_NilValue, &val_pi);
+  PROTECT_WITH_INDEX(R_NilValue, &arg_pi); // unnecessary, for rchk only
+  PROTECT_WITH_INDEX(R_NilValue, &val_pi); // unnecessary, for rchk only
 
   // For each of the arguments to the generic
   for (R_xlen_t i = 0; i < n_args; ++i) {
@@ -205,9 +208,9 @@ SEXP method_call_(SEXP call_, SEXP op_, SEXP args_, SEXP env_) {
         // Instead of Rf_eval(arg, R_EmptyEnv), we do Rf_eval(name, envir), so that
         // - if TYPEOF(arg) == LANGSXP or SYMSXP, arg doesn't need to be enquoted and
         // - if TYPEOF(arg) == PROMSXP, arg is updated in place.
-        REPROTECT(arg, arg_pi); // not really necessary, but rchk flags spuriously
+        REPROTECT(arg, arg_pi); // unnecessary, for rchk only
         SEXP val = Rf_eval(name, envir);
-        REPROTECT(val, val_pi);
+        REPROTECT(val, val_pi); // unnecessary, for rchk only
 
         if (Rf_inherits(val, "S7_super")) {
 
@@ -250,7 +253,20 @@ SEXP method_call_(SEXP call_, SEXP op_, SEXP args_, SEXP env_) {
 
   // Now that we have all the classes, we can look up what method to call
   SEXP m = method_(generic, dispatch_classes, envir, R_TRUE);
-  SETCAR(mcall, m);
+  REPROTECT(m, val_pi); // unnecessary, for rchk only
+
+  /// Inlining the method closure in the call like `SETCAR(mcall, m);`
+  /// leads to extremely verbose (unreadable) traceback()s. So,
+  /// for nicer tracebacks, we set a SYMSXP at the head.
+  SEXP method_name = Rf_getAttrib(m, sym_name);
+  if (TYPEOF(method_name) != SYMSXP) {
+    // if name is missing, fallback to masking the `S7_dispatch` symbol.
+    // we could alternatively fallback to inlining m: SETCAR(mcall, m)
+    method_name = sym_S7_dispatch;
+  }
+
+  Rf_defineVar(method_name, m, envir);
+  SETCAR(mcall, method_name);
 
   SEXP out = Rf_eval(mcall, envir);
   UNPROTECT(4);

tests/testthat/_snaps/method-dispatch.md

@@ -57,3 +57,34 @@
       Error in `foo_wrapper()`:
       ! argument "xx" is missing, with no default
 
+# errors from dispatched methods have reasonable tracebacks
+
+    Code
+      my_generic(10)
+    Output
+      [[1]]
+      my_generic(10)
+      
+      [[2]]
+      S7::S7_dispatch()
+      
+      [[3]]
+      `method(my_generic, class_double)`(x = 10, ...)
+      
+
+---
+
+    Code
+      my_generic(3, 4)
+    Output
+      [[1]]
+      my_generic(3, 4)
+      
+      [[2]]
+      S7::S7_dispatch()
+      
+      [[3]]
+      `method(my_generic, list(class_double, class_double))`(x = 3, 
+          y = 4, ...)
+      
+

tests/testthat/test-method-dispatch.R

@@ -225,5 +225,23 @@ test_that("method dispatch works for class_missing", {
     variant = if (getRversion() < "4.3") "R-lt-4-3",
     foo_wrapper()
   )
+})
+
+test_that("errors from dispatched methods have reasonable tracebacks", {
+
+  get_call_stack <- function(n = 3) {
+    x <- sys.calls()
+    x <- x[-length(x)] # remove get_call_stack()
+    x <- tail(x, n)
+    lapply(x, utils::removeSource)
+  }
+
+  my_generic <- new_generic("my_generic", "x")
+  method(my_generic, class_numeric) <- function(x) get_call_stack()
+  expect_snapshot(my_generic(10))
 
+  my_generic <- new_generic("my_generic", c("x", "y"))
+  method(my_generic, list(class_numeric, class_numeric)) <-
+    function(x, y) get_call_stack()
+  expect_snapshot(my_generic(3, 4))
 })