diff --git a/R/generic.R b/R/generic.R index bdea8145..6cdcb926 100644 --- a/R/generic.R +++ b/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)) { 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..b224138e 100644 --- a/tests/testthat/_snaps/method-dispatch.md +++ b/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 + diff --git a/tests/testthat/test-method-dispatch.R b/tests/testthat/test-method-dispatch.R index 01a1afe0..31cddf2e 100644 --- a/tests/testthat/test-method-dispatch.R +++ b/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) })