Improve traceback() for dispatched methods

[t-kalinowski]

Currently, printing traceback() on an error signaled from a generic dispatched method is extremely verbose, bordering on unreadable. This is because the generic method closure is inlined into the constructed call, which is then deparsed in the traceback.

With this PR, we now construct the method call with a symbol at the head. The name is intentionally non-syntatic to avoid potential clashes with the generic's arguments.

Example evaluating the following at the console:

library(S7)
my_generic <- new_generic("my_generic", "x")
method(my_generic, class_numeric) <- function(x) stop("hi")
my_generic(10)
traceback()

After this PR, it prints:

> library(S7)
my_generic <- new_generic("my_generic", "x")
method(my_generic, class_numeric) <- function(x) stop("hi")
my_generic(10)
Error in `my_generic@methods$double`(x = 10, ...) : hi
> traceback()
4: stop("hi") at #1
3: `my_generic@methods$double`(x = 10, ...) at method-dispatch.R#23
2: S7::S7_dispatch()
1: my_generic(10)

Presently prints:

> library(S7)
my_generic <- new_generic("my_generic", "x")
method(my_generic, class_numeric) <- function(x) stop("hi")
my_generic(10)
Error in (function (x)  : hi

> traceback()
4: stop("hi") at #1
3: (structure(function (x) 
   stop("hi"), class = c("S7_method", "function", "S7_object"), S7_class = structure(function (.data = function() NULL, 
       generic = (function (.data = function() NULL, name = character(0), 
           methods = new.env(parent = emptyenv()), dispatch_args = character(0)) 
       new_object(fun(.data = .data), name = name, methods = methods, 
           dispatch_args = dispatch_args))(), signature = list()) 
   new_object(fun(.data = .data), generic = generic, signature = signature), name = "S7_method", parent = structure(list(
       class = "function", constructor_name = "fun", constructor = function (.data = function() NULL) 
       .data, validator = function (object) 
       {
           if (base_class(object) != name) {
               sprintf("Underlying data must be <%s> not <%s>", 
                   name, base_class(object))
           }
       }), class = "S7_base_class"), properties = list(generic = structure(list(
       name = "generic", class = structure(function (.data = function() NULL, 
           name = character(0), methods = new.env(parent = emptyenv()), 
           dispatch_args = character(0)) 
       new_object(fun(.data = .data), name = name, methods = methods, 
           dispatch_args = dispatch_args), name = "S7_generic", parent = structure(list(
           class = "function", constructor_name = "fun", constructor = function (.data = function() NULL) 
           .data, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"), properties = list(name = structure(list(
           name = "name", class = structure(list(class = "character", 
               constructor_name = "character", constructor = function (.data = character(0)) 
               .data, validator = function (object) 
               {
                   if (base_class(object) != name) {
                     sprintf("Underlying data must be <%s> not <%s>", 
                       name, base_class(object))
                   }
               }), class = "S7_base_class"), getter = NULL, setter = NULL, 
           validator = NULL, default = NULL), class = "S7_property"), 
           methods = structure(list(name = "methods", class = structure(list(
               class = "environment", constructor_name = "environment", 
               constructor = function (.data = new.env(parent = emptyenv())) 
               .data, validator = function (object) 
               {
                   if (base_class(object) != name) {
                     sprintf("Underlying data must be <%s> not <%s>", 
                       name, base_class(object))
                   }
               }), class = "S7_base_class"), getter = NULL, setter = NULL, 
               validator = NULL, default = NULL), class = "S7_property"), 
           dispatch_args = structure(list(name = "dispatch_args", 
               class = structure(list(class = "character", constructor_name = "character", 
                   constructor = function (.data = character(0)) 
                   .data, validator = function (object) 
                   {
                     if (base_class(object) != name) {
                       sprintf("Underlying data must be <%s> not <%s>", 
                         name, base_class(object))
                     }
                   }), class = "S7_base_class"), getter = NULL, 
               setter = NULL, validator = NULL, default = NULL), class = "S7_property")), abstract = FALSE, constructor = function (.data = function() NULL, 
           name = character(0), methods = new.env(parent = emptyenv()), 
           dispatch_args = character(0)) 
       new_object(fun(.data = .data), name = name, methods = methods, 
           dispatch_args = dispatch_args), class = c("S7_class", 
       "S7_object")), getter = NULL, setter = NULL, validator = NULL, 
       default = NULL), class = "S7_property"), signature = structure(list(
       name = "signature", class = structure(list(class = "list", 
           constructor_name = "list", constructor = function (.data = list()) 
           .data, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"), getter = NULL, setter = NULL, 
       validator = NULL, default = NULL), class = "S7_property")), abstract = FALSE, constructor = function (.data = function() NULL, 
       generic = (function (.data = function() NULL, name = character(0), 
           methods = new.env(parent = emptyenv()), dispatch_args = character(0)) 
       new_object(fun(.data = .data), name = name, methods = methods, 
           dispatch_args = dispatch_args))(), signature = list()) 
   new_object(fun(.data = .data), generic = generic, signature = signature), class = c("S7_class", 
   "S7_object")), generic = structure(function (x, ...) 
   S7::S7_dispatch(), class = c("S7_generic", "function", "S7_object"
   ), S7_class = structure(function (.data = function() NULL, name = character(0), 
       methods = new.env(parent = emptyenv()), dispatch_args = character(0)) 
   new_object(fun(.data = .data), name = name, methods = methods, 
       dispatch_args = dispatch_args), name = "S7_generic", parent = structure(list(
       class = "function", constructor_name = "fun", constructor = function (.data = function() NULL) 
       .data, validator = function (object) 
       {
           if (base_class(object) != name) {
               sprintf("Underlying data must be <%s> not <%s>", 
                   name, base_class(object))
           }
       }), class = "S7_base_class"), properties = list(name = structure(list(
       name = "name", class = structure(list(class = "character", 
           constructor_name = "character", constructor = function (.data = character(0)) 
           .data, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"), getter = NULL, setter = NULL, 
       validator = NULL, default = NULL), class = "S7_property"), 
       methods = structure(list(name = "methods", class = structure(list(
           class = "environment", constructor_name = "environment", 
           constructor = function (.data = new.env(parent = emptyenv())) 
           .data, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"), getter = NULL, setter = NULL, 
           validator = NULL, default = NULL), class = "S7_property"), 
       dispatch_args = structure(list(name = "dispatch_args", class = structure(list(
           class = "character", constructor_name = "character", 
           constructor = function (.data = character(0)) 
           .data, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"), getter = NULL, setter = NULL, 
           validator = NULL, default = NULL), class = "S7_property")), abstract = FALSE, constructor = function (.data = function() NULL, 
       name = character(0), methods = new.env(parent = emptyenv()), 
       dispatch_args = character(0)) 
   new_object(fun(.data = .data), name = name, methods = methods, 
       dispatch_args = dispatch_args), class = c("S7_class", "S7_object"
   )), name = "my_generic", methods = <environment>, dispatch_args = "x"), signature = list(
       structure(list(class = "double", constructor_name = "double", 
           constructor = function (.data = numeric(0)) 
           .data, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"))))(x = 10, ...) at method-dispatch.R#23
2: S7::S7_dispatch()
1: my_generic(10)

[lawremi]

Nice improvement. The verbose traces were bothering me, so I was setting the option to truncate them. This is much more readable though.

[hadley]

I think this fixes #132, at least to the level we want to worry about for now.

...

Actually I think #483 did most of the rest. The call stack is now pretty minimal:

    ▆
 1. └─global my_generic(10)
 2.   ├─S7::S7_dispatch()
 3.   └─global `my_generic@methods$double`(x = `<dbl>`, ...)

cf. CRAN S7:

    ▆
 1. └─global my_generic(10)
 2.   ├─S7::S7_dispatch()
 3.   │ └─base::eval(S7_dispatched_call, envir = sys.frame(-1))
 4.   │   └─base::eval(S7_dispatched_call, envir = sys.frame(-1))
 5.   └─global `<S7_methd>`(`<dbl>`, ... = ...)

[t-kalinowski]

The snapshot test is failing, but I can't reproduce the failure locally. On CI, the call stack includes the .External2(method_call_, ...) call, but when I run it locally, it does not. I could work around this by adding a variant or capturing less in the snapshot, but I’m curious—does anyone know why .External2 only appears sometimes?

It was because the call had a srcref sometimes. The srcref printed as .External2(...), even though the actual call constructed and passed to Rf_eval() from .External2() was different.

[hadley]

This is worth of a news bullet IMO.