Refactoring generic tooling

R/external-generic.R

@@ -40,6 +40,20 @@ new_external_generic <- function(package, name, dispatch_args, version = NULL) {
   out
 }
 
+as_external_generic <- function(x) {
+  if (is_S7_generic(x)) {
+    pkg <- package_name(x)
+    new_external_generic(pkg, x@name, x@dispatch_args)
+  } else if (is_external_generic(x)) {
+    x
+  } else if (is_S3_generic(x)) {
+    pkg <- package_name(x)
+    new_external_generic(pkg, x$name, "__S3__")
+  } else if (is_S4_generic(x)) {
+    new_external_generic(x@package, as.vector(x@generic), x@signature)
+  }
+}
+
 #' @export
 print.S7_external_generic <- function(x, ...) {
   cat(

R/generic-spec.R

@@ -1,5 +1,9 @@
+is_generic <- function(x) {
+  is_S7_generic(x) || is_external_generic(x) || is_S3_generic(x) || is_S4_generic(x)
+}
+
 as_generic <- function(x) {
-  if (is_generic(x) || is_external_generic(x) || is_S4_generic(x)) {
+  if (is_generic(x)) {
     x
   } else if (is.function(x)) {
     as_S3_generic(x)
@@ -57,13 +61,13 @@ package_name <- function(f) {
 }
 
 generic_n_dispatch <- function(x) {
-  if (is_S3_generic(x)) {
-    1
-  } else if (is_generic(x)) {
+  if (is_S7_generic(x)) {
     length(x@dispatch_args)
   } else if (is_external_generic(x)) {
     length(x$dispatch_args)
-  } else if (methods::is(x, "genericFunction")) {
+  } else if (is_S3_generic(x)) {
+    1
+  } else if (is_S4_generic(x)) {
     length(x@signature)
   } else {
     stop(sprintf("Invalid input %", obj_desc(x)), call. = FALSE)

R/method-register.R

@@ -68,7 +68,7 @@ register_method <- function(generic,
   signature <- as_signature(signature, generic)
 
   # Register in current session
-  if (is_generic(generic)) {
+  if (is_S7_generic(generic)) {
     check_method(method, generic, name = method_name(generic, signature))
     register_S7_method(generic, signature, method)
   } else if (is_external_generic(generic)) {
@@ -79,29 +79,18 @@ register_method <- function(generic,
     }
   } else if (is_S3_generic(generic)) {
     register_S3_method(generic, signature, method)
-  } else if (inherits(generic, "genericFunction")) {
+  } else if (is_S4_generic(generic)) {
     register_S4_method(generic, signature, method, env)
   }
 
   # if we're inside a package, we also need to be able register methods
   # when the package is loaded
   if (!is.null(package) && !is_local_generic(generic, package)) {
-    if (is_generic(generic)) {
-      pkg <- package_name(generic)
-      generic <- new_external_generic(pkg, generic@name, generic@dispatch_args)
-    } else if (is_external_generic(generic)) {
-      # already in correct form
-    } else if (is_S3_generic(generic)) {
-      pkg <- package_name(generic)
-      generic <- new_external_generic(pkg, generic$name, NULL)
-    } else if (is_S4_generic(generic)) {
-      generic <- new_external_generic(generic@package, generic@generic, NULL)
-    }
-
+    generic <- as_external_generic(generic)
     external_methods_add(package, generic, signature, method)
   }
 
-  invisible()
+  invisible(generic)
 }
 
 register_S3_method <- function(generic, signature, method) {

R/zzz.R

@@ -98,7 +98,7 @@ S7_generic <- new_class(
   parent = class_function
 )
 methods::setOldClass(c("S7_generic", "function", "S7_object"))
-is_generic <- function(x) inherits(x, "S7_generic")
+is_S7_generic <- function(x) inherits(x, "S7_generic")
 
 S7_method <- new_class("S7_method",
   parent = class_function,

tests/testthat/test-external-generic.R

@@ -27,6 +27,32 @@ test_that("displays nicely", {
   })
 })
 
+test_that("can convert existing generics to external", {
+  foo_S7 <- new_generic("foo_S7", "x")
+  env <- new.env()
+  env$.packageName <- "test"
+  environment(foo_S7) <- env
+
+  expect_equal(
+    as_external_generic(foo_S7),
+    new_external_generic("test", "foo_S7", "x")
+  )
+
+  foo_ext <- new_external_generic("pkg", "foo", "x")
+  expect_equal(as_external_generic(foo_ext), foo_ext)
+
+  expect_equal(
+    as_external_generic(as_S3_generic(sum)),
+    new_external_generic("base", "sum", "__S3__")
+  )
+
+  methods::setGeneric("foo_S4", function(x) {})
+  expect_equal(
+    as_external_generic(foo_S4),
+    new_external_generic("S7", "foo_S4", "x")
+  )
+})
+
 test_that("new_method works with both hard and soft dependencies", {
   # NB: Relies on installed S7