Impement S7_user_frame() and S7_generic_call()

NAMESPACE

@@ -41,10 +41,13 @@ export(S7_class)
 export(S7_class_desc)
 export(S7_data)
 export(S7_dispatch)
+export(S7_generic_call)
+export(S7_generic_fun)
 export(S7_inherits)
 export(S7_object)
 export(S7_on_build)
 export(S7_on_load)
+export(S7_user_frame)
 export(as_class)
 export(check_is_S7)
 export(class_Date)

NEWS.md

@@ -34,6 +34,7 @@
 * `S7_data()` now preserves the S3 class when the S7 class inherits from an S3 class, so e.g. `S7_data()` on a data.frame subclass now returns a data.frame (#380).
 * `S7_data<-()` now preserves attributes (like `names` or `dim`) from the replacement data instead of carrying over the originals, so resizing the underlying data works correctly (#478).
 * `S7_error_method_not_found` now has a correct class vector without a duplicate `"error"` entry (@jjjermiah, #604).
+* `S7_generic_call()`, `S7_user_frame()`, and `S7_generic_fun()` are new helpers that give a method stable access to the originating call to the generic, the caller's frame, and the generic function itself, even in the presence of `super()` (#596).
 * `S7_inherits()` and `check_is_S7()` now accept any class specification (S7 class, S7 union, S3 class, S4 class, or base type wrapper like `class_integer`), not just S7 classes (#556).
 * `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).

R/method-call.R

@@ -0,0 +1,146 @@
+#' Access the generic call and user frame from within a method
+#'
+#' @description
+#' These helpers give a method stable access to two pieces of context that are
+#' otherwise obscured by S7's dispatch machinery:
+#'
+#' * `S7_generic_call()` returns the originating call to the generic. This is
+#'   useful as the `call` for an error message, so that the user sees the
+#'   generic call (e.g. `foo(1)`) rather than S7's internal dispatch.
+#'
+#' * `S7_user_frame()` returns the frame from which the generic was called.
+#'   This is the equivalent of [parent.frame()] in an S3 method, and is
+#'   useful if you need non-standard evaluation.
+#'
+#' * `S7_generic_fun()` returns the generic function itself. This is the
+#'   equivalent of [sys.function()] in an S3 method, and is useful if you need
+#'   to inspect the generic, e.g. to retrieve its name or dispatch arguments.
+#'
+#' All three helpers skip intermediate frames when a method re-dispatches the
+#' same generic to a superclass with [super()], reporting the outermost
+#' user-facing call, its caller, and the originating generic.
+#'
+#' @param match Set to `TRUE` to process with [match.call()] and name all
+#'   arguments.
+#' @returns `S7_generic_call()` returns a call; `S7_user_frame()` returns an
+#'   environment; `S7_generic_fun()` returns the generic function. All error if
+#'   called outside of a method.
+#' @seealso [S7_dispatch()] for how methods are called, and [super()] for
+#'   superclass dispatch.
+#' @export
+#' @examples
+#' # S7_generic_call() reports the call to the generic, skipping super():
+#' foo <- new_generic("foo", "x")
+#' method(foo, class_double) <- function(x) {
+#'   S7_generic_call()
+#' }
+#'
+#' Number <- new_class("Number", parent = class_double)
+#' method(foo, Number) <- function(x) {
+#'   foo(super(x, class_double))
+#' }
+#'
+#' foo(Number(1))
+#'
+#' # S7_user_frame() supplies the enclosing environment for non-standard
+#' # evaluation, so an expression can mix columns of the data with variables
+#' # from where the generic was called, like subset():
+#' keep_rows <- new_generic("keep_rows", "data")
+#' method(keep_rows, class_data.frame) <- function(data, condition) {
+#'   rows <- eval(substitute(condition), data, S7_user_frame())
+#'   data[rows, , drop = FALSE]
+#' }
+#'
+#' threshold <- 4
+#' df <- data.frame(x = 1:3, y = c(2, 5, 8))
+#' # `x` and `y` come from the data frame; `threshold` from this frame
+#' keep_rows(df, x + y > threshold)
+#'
+#' # S7_generic_fun() returns the generic itself, e.g. to use its name in a
+#' # message:
+#' bar <- new_generic("bar", "x")
+#' method(bar, class_double) <- function(x) {
+#'   generic <- S7_generic_fun()
+#'   paste0("Called ", generic@name, "()")
+#' }
+#' bar(1)
+S7_generic_call <- function(match = FALSE) {
+  idx <- generic_call_frame()
+  call <- sys.call(idx)
+  if (isTRUE(match)) {
+    call <- match.call(sys.function(idx), call, envir = sys.frame(idx))
+  }
+  call
+}
+
+#' @rdname S7_generic_call
+#' @export
+S7_user_frame <- function() {
+  frame <- generic_call_frame()
+  sys.frame(sys.parents()[frame])
+}
+
+#' @rdname S7_generic_call
+#' @export
+S7_generic_fun <- function() {
+  frame <- generic_call_frame()
+  sys.function(frame)
+}
+
+generic_call_frame <- function(call = sys.call(-1L)) {
+  parents <- sys.parents()
+
+  method_frame <- active_method_frame(call)
+  frame <- parent_generic_frame(method_frame, parents)
+  if (is.na(frame)) {
+    stop2("Must be called from within a method.", call = call)
+  }
+
+  # Walk past same-generic super() re-dispatches.
+  repeat {
+    if (!is_super_dispatch(frame)) {
+      break
+    }
+
+    parent <- parent_generic_frame(frame, parents)
+    if (
+      is.na(parent) || !identical(sys.function(parent), sys.function(frame))
+    ) {
+      break
+    }
+    frame <- parent
+  }
+
+  frame
+}
+
+active_method_frame <- function(call) {
+  for (i in rev(seq_len(sys.nframe() - 1L))) {
+    if (inherits(sys.function(i), "S7_method")) {
+      return(i)
+    }
+    if (inherits(sys.function(i), "S7_generic")) {
+      break
+    }
+  }
+
+  stop2("Must be called from within a method.", call = call)
+}
+
+parent_generic_frame <- function(frame, parents) {
+  parent <- parents[[frame]]
+  while (parent > 0L) {
+    if (inherits(sys.function(parent), "S7_generic")) {
+      return(parent)
+    }
+    parent <- parents[[parent]]
+  }
+
+  NA_integer_
+}
+
+# S7_dispatch() marks the generic's frame with `_dispatched_super` when it
+# unwraps a super() object.
+is_super_dispatch <- function(i) {
+  exists("_dispatched_super", envir = sys.frame(i), inherits = FALSE)
+}

_pkgdown.yml

@@ -34,6 +34,7 @@ reference:
   - method_explain
   - S7_class
   - S7_class_desc
+  - S7_generic_call
 
 - title: Packages
   desc: >

src/init.c

@@ -44,6 +44,7 @@ SEXP sym_getter;
 SEXP sym_dot_should_validate;
 SEXP sym_dot_getting_prop;
 SEXP sym_dot_setting_prop;
+SEXP sym_u_dispatched_super;
 
 // `comment` lacks a predefined R_*Symbol, unlike the other special names.
 SEXP sym_comment;
@@ -104,6 +105,7 @@ void R_init_S7(DllInfo *dll)
     sym_dot_should_validate = Rf_install(".should_validate");
     sym_dot_getting_prop = Rf_install(".getting_prop");
     sym_dot_setting_prop = Rf_install(".setting_prop");
+    sym_u_dispatched_super = Rf_install("_dispatched_super");
 
     sym_comment = Rf_install("comment");
 

src/method-dispatch.c

@@ -8,6 +8,7 @@ extern SEXP sym_dispatch_args;
 extern SEXP sym_methods;
 extern SEXP sym_S7_dispatch;
 extern SEXP sym_name;
+extern SEXP sym_u_dispatched_super;
 
 extern SEXP fn_base_quote;
 extern SEXP fn_base_missing;
@@ -219,6 +220,9 @@ SEXP method_call_(SEXP call_, SEXP op_, SEXP args_, SEXP env_) {
 
         if (Rf_inherits(val, "S7_super")) {
 
+          // Mark the generic's frame so S7_generic_call()/S7_user_frame() can
+          // tell this is a super() re-dispatch and walk out to the user call.
+          Rf_defineVar(sym_u_dispatched_super, R_TRUE, envir);
 
           // Put the super() stored value into the method call.
           // Note: This means we don't pass along the arg PROMSXP, meaning that

tests/testthat/_snaps/method-call.md

@@ -0,0 +1,18 @@
+# helpers error when called outside a method
+
+    Code
+      S7_generic_call()
+    Condition
+      Error in `S7_generic_call()`:
+      ! Must be called from within a method.
+    Code
+      S7_user_frame()
+    Condition
+      Error in `S7_user_frame()`:
+      ! Must be called from within a method.
+    Code
+      S7_generic_fun()
+    Condition
+      Error in `S7_generic_fun()`:
+      ! Must be called from within a method.
+