From bcedb64df4da3ddf55c145b21677d471fcc106b8 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 5 Nov 2024 08:40:04 -0500 Subject: [PATCH] Improve `traceback()` for dispatched methods (#486) * Improve `traceback()` for dispatched methods * fix typo, malformed test * Update R/generic.R Co-authored-by: Hadley Wickham * 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 --- NEWS.md | 6 +++++ R/generic.R | 3 +++ src/init.c | 4 +++ src/method-dispatch.c | 26 ++++++++++++++++---- tests/testthat/_snaps/method-dispatch.md | 31 ++++++++++++++++++++++++ tests/testthat/test-method-dispatch.R | 18 ++++++++++++++ 6 files changed, 83 insertions(+), 5 deletions(-) diff --git a/NEWS.md b/NEWS.md index 6b39bf90..1a2848ef 100644 --- a/NEWS.md +++ b/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). diff --git a/R/generic.R b/R/generic.R index bdea8145..d4b68c2e 100644 --- a/R/generic.R +++ b/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)) { diff --git a/src/init.c b/src/init.c index 796d4f49..cf48b9ff 100644 --- a/src/init.c +++ b/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); diff --git a/src/method-dispatch.c b/src/method-dispatch.c index f026ba83..5b1affdd 100644 --- a/src/method-dispatch.c +++ b/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); diff --git a/tests/testthat/_snaps/method-dispatch.md b/tests/testthat/_snaps/method-dispatch.md index da9ea870..c760d4d7 100644 --- a/tests/testthat/_snaps/method-dispatch.md +++ b/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, ...) + + diff --git a/tests/testthat/test-method-dispatch.R b/tests/testthat/test-method-dispatch.R index 01a1afe0..e88c58c4 100644 --- a/tests/testthat/test-method-dispatch.R +++ b/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)) })