Improve traceback() for dispatched methods

R/generic.R

@@ -189,10 +189,33 @@ methods_rec <- function(x, signature) {
   unlist(methods, recursive = FALSE)
 }
 
+make_method_name <- function(generic, chr_signature) {
+  name <- sprintf("%s@methods$%s",
+                  generic@name,
+                  paste0(chr_signature, collapse = "$"))
+
+  pkgname <- topNamespaceName(environment(generic))
+  if (is.null(pkgname))
+    return(name)
+
+  for (get in c("::", ":::")) {
+    tryCatch({
+      generic2 <- eval(call(get, as.name(pkgname), as.name(generic@name)), baseenv())
+      if (identical(generic, generic2))
+        return(paste0(c(pkgname, get, name), collapse = ""))
+    }, error = function(e) NULL)
+  }
+
+  name
+}
+
 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(make_method_name(generic, chr_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,15 @@
       Error in `foo_wrapper()`:
       ! argument "xx" is missing, with no default
 
+# errors from dispatched methods have reasonable tracebacks
+
+    Code
+      my_generic(10)
+    Condition
+      Error in `my_generic@methods$double`:
+      ! hi
+    Code
+      traceback()
+    Output
+      No traceback available
+

tests/testthat/test-method-dispatch.R

@@ -226,4 +226,16 @@ test_that("method dispatch works for class_missing", {
     foo_wrapper()
   )
 
+test_that("errors from dispatched methods have reasonable tracebacks", {
+  my_generic <- new_generic("my_generic", "x")
+  method(my_generic, class_numeric) <- function(x) stop("hi")
+  expect_snapshot(error = TRUE, {
+    my_generic(10)
+    traceback()
+  })
+
+  my_generic <- new_generic("my_generic", c("x", "y"))
+  method(my_generic, list(class_numeric, class_numeric)) <- function(x, y) stop("hi")
+
+  my_generic(3, 4)
 })