Revamp method calling

NEWS.md

@@ -2,6 +2,8 @@
 
 ## Jan 2020
 
+* Different evaluation mechanism for method dispatch, and greater restrictions 
+  on dispatch args (#141)
 * `x@.data` -> `r7_data()`; probably to be replaced by casting.
 * In generic, `signature` -> `dispatch_args`.
 * `new_class()` has properties as 3rd argument (instead of constructor).

R/dispatch.R

@@ -0,0 +1,11 @@
+method_lookup_error <- function(name, args, signatures) {
+  args <- setdiff(args, "...")
+  types <- paste0("- ", args, ": ", vcapply(signatures, fmt_classes), collapse = "\n")
+  stop(sprintf("Can't find method for generic `%s()` with classes:\n%s", name, types), call. = FALSE)
+}
+
+#' Lookup the R7 method for the current generic and call it.
+#' @export
+method_call <- function() {
+  .Call(method_call_, sys.call(-1), sys.function(-1), sys.frame(-1))
+}

R/generic.R

@@ -5,13 +5,29 @@
 #' of one or more arguments (the `signature`). Create a new generic with
 #' `new_generic()` then use [method<-] to add methods to it.
 #'
+#' @section Dispatch arguments:
+#' The arguments that are used to pick the method are called the **dispatch
+#' arguments**. In most cases, this will be one argument, in which case the
+#' generic is said to use **single dispatch**. If it consists of more than
+#' one argument, it's said to use **multiple dispatch**.
+#'
+#' There are two restrictions on the dispatch arguments: they must be the first
+#' arguments to the generic and if the generic uses `...`, it must occur
+#' immediately after the dispatch arguments.
+#'
 #' @param name The name of the generic. This should be the same as the object
 #'   that you assign it to.
 #' @param dispatch_args A character vector providing the names of arguments to
-#'   dispatch on. If omitted, defaults to the required arguments of `fun`.
+#'   dispatch on.
+#'
+#'   If `dispatch_args` are omitted, but `fun` is supplied, will default to the
+#'   arguments that appear before `...` in `fun`. If there are no dots, it will
+#'   default to the first argument. If both `fun` and `dispatch_args` are
+#'   supplied, the `dispatch_args` must appear at the start of `fun`'s formals.
+#'
 #' @param fun An optional specification of the generic, which must call
 #'  `method_call()` to dispatch to methods. This is usually generated
-#'  automatically from the `signature`, but you may want to supply it if
+#'  automatically from the `dispatch_args`, but you may want to supply it if
 #'  you want to add additional required arguments, or perform some standardised
 #'  computation in the generic.
 #' @seealso [new_external_generic()] to define a method for a generic
@@ -39,7 +55,9 @@
 #'   }
 #'   sum(x) / length(x)
 #' }
-#' method(mean2, "character") <- function(x, ...) {stop("Not supported")}
+#' method(mean2, "character") <- function(x, ..., na.rm = TRUE) {
+#'   stop("Not supported")
+#' }
 #'
 new_generic <- function(name, fun = NULL, dispatch_args = NULL) {
   if (is.null(dispatch_args) && is.null(fun)) {
@@ -53,12 +71,11 @@ new_generic <- function(name, fun = NULL, dispatch_args = NULL) {
     check_generic(fun)
     dispatch_args <- guess_dispatch_args(fun)
   } else {
-    dispatch_args <- check_dispatch_args(dispatch_args)
-    # For now, ensure all generics have ... in dispatch_args
-    dispatch_args <- union(dispatch_args, "...")
+    dispatch_args <- check_dispatch_args(dispatch_args, fun)
 
     if (is.null(fun)) {
-      args <- setNames(lapply(dispatch_args, function(i) quote(expr = )), dispatch_args)
+      args <- c(dispatch_args, "...")
+      args <- setNames(lapply(args, function(i) quote(expr = )), args)
       fun <- make_function(args, quote(method_call()), topenv(environment()))
     }
   }
@@ -68,17 +85,45 @@ new_generic <- function(name, fun = NULL, dispatch_args = NULL) {
 
 guess_dispatch_args <- function(fun) {
   formals <- formals(fun)
-  is_required <- vlapply(formals, identical, quote(expr = ))
-  names(formals[is_required])
+  # all arguments before ...
+  if (length(formals) == 0) {
+    character()
+  } else if ("..." %in% names(formals)) {
+    names(formals)[seq_len(which(names(formals) == "...") - 1)]
+  } else {
+    names(formals)[[1]]
+  }
 }
 
-check_dispatch_args <- function(dispatch_args) {
+check_dispatch_args <- function(dispatch_args, fun = NULL) {
   if (!is.character(dispatch_args)) {
     stop("`dispatch_args` must be a character vector", call. = FALSE)
   }
   if (length(dispatch_args) == 0) {
     stop("`dispatch_args` must have at least one component", call. = FALSE)
   }
+  if (anyDuplicated(dispatch_args)) {
+    stop("`dispatch_args` must be unique", call. = FALSE)
+  }
+  if (any(is.na(dispatch_args) | dispatch_args == "")) {
+    stop("`dispatch_args` must not be missing or the empty string")
+  }
+  if ("..." %in% dispatch_args) {
+    stop("Can't dispatch on `...`", call. = FALSE)
+  }
+
+  if (!is.null(fun)) {
+    arg_names <- names(formals(fun))
+
+    if (!identical(dispatch_args, arg_names[seq_along(dispatch_args)])) {
+      stop("`dispatch_args` must be a prefix of the generic arguments", call. = FALSE)
+    }
+
+    if ("..." %in% arg_names && arg_names[[length(dispatch_args) + 1]] != "...") {
+      stop("If present, ... must immediately follow the `dispatch_args`", call. = FALSE)
+    }
+  }
+
   dispatch_args
 }
 

R/method.R

@@ -136,36 +136,40 @@ next_method <- function() {
   method_impl(generic, signature, ignore = methods)
 }
 
-
-arg_to_string <- function(arg) {
-  if (is.na(names(arg)[[1]])) {
-    return("does not exist")
-  }
-  sprintf("is `%s = %s`", names(arg), deparse(arg[[1]]))
-}
-
 method_compatible <- function(method, generic) {
   generic_formals <- suppressWarnings(formals(args(generic)))
-  method_formals <- formals(method)
-
   # This can happen for some primitive functions such as `[`
   if (length(generic_formals) == 0) {
     return()
   }
 
-  for (i in seq_len(length(generic_formals) - 1)) {
-    if (!identical(generic_formals[i], method_formals[i])) {
-      stop(sprintf("`method` must be consistent with <R7_generic> %s.\n- Argument %i in generic %s\n- Argument %i in method %s", generic@name, i, arg_to_string(generic_formals[i]), i, arg_to_string(method_formals[i])), call. = FALSE)
-    }
+  method_formals <- formals(method)
+  generic_args <- names(generic_formals)
+  method_args <- names(method_formals)
+
+  n_dispatch <- length(generic@dispatch_args)
+  has_dispatch <- length(method_formals) >= n_dispatch &&
+    identical(method_args[1:n_dispatch], generic@dispatch_args)
+  if (!has_dispatch) {
+    stop("`method` doesn't match generic dispatch arg", call. = FALSE)
   }
-
-  if ("..." %in% names(generic_formals) && !"..." %in% names(method_formals)) {
-      stop(sprintf("`method` must be consistent with <R7_generic> %s.\n- `generic` has `...`\n- `method` does not have `...`", generic@name), call. = FALSE)
+  if ("..." %in% method_args && method_args[[n_dispatch + 1]] != "...") {
+    stop("... must immediately follow dispatch args", call. = FALSE)
+  }
+  empty_dispatch <- vlapply(method_formals[generic@dispatch_args], identical, quote(expr = ))
+  if (any(!empty_dispatch)) {
+    stop("Dispatch arguments must not have default values", call. = FALSE)
   }
 
-  if (!"..." %in% names(generic_formals) && "..." %in% names(method_formals)) {
-      stop(sprintf("`method` must be consistent with <R7_generic> %s.\n- `generic` does not have `...`\n- `method` has `...`", generic@name), call. = FALSE)
+  extra_args <- setdiff(names(generic_formals), c(generic@dispatch_args, "..."))
+  for (arg in extra_args) {
+    if (!arg %in% method_args) {
+      warning(sprintf("Argument `%s` is missing from method", arg), call. = FALSE)
+    } else if (!identical(generic_formals[[arg]], method_formals[[arg]])) {
+      warning(sprintf("Default value is not the same as the generic\n- Generic: %s = %s\n- Method:  %s = %s", arg, deparse1(generic_formals[[arg]]), arg, deparse1(method_formals[[arg]])), call. = FALSE)
+    }
   }
+
   TRUE
 }
 
@@ -263,18 +267,6 @@ as_generic <- function(generic) {
   generic
 }
 
-method_lookup_error <- function(name, args, signatures) {
-  args <- setdiff(args, "...")
-  types <- paste0("- ", args, ": ", vcapply(signatures, fmt_classes), collapse = "\n")
-  stop(sprintf("Can't find method for generic `%s()` with classes:\n%s", name, types), call. = FALSE)
-}
-
-#' Lookup the R7 method for the current generic and call it.
-#' @export
-method_call <- function() {
-  .Call(method_call_, sys.call(-1), sys.function(-1), sys.frame(-1))
-}
-
 #' @export
 print.R7_method <- function(x, ...) {
   method_signature <- method_signature(x@signature)