From 2297f33b963c10a0c44c8cf3295a7c9abc8f9952 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Tue, 21 Nov 2023 16:42:19 -0600
Subject: [PATCH] Derive S3 metadata from `@exportS3Method()` (#1546)

Fixes #1202
---
 NEWS.md                                |  3 +++
 R/namespace.R                          |  2 +-
 R/object-from-call.R                   | 22 +++++++++++------
 tests/testthat/test-object-from-call.R | 34 ++++++++++++++++++++++++++
 tests/testthat/test-object-s3.R        | 10 --------
 5 files changed, 53 insertions(+), 18 deletions(-)

diff --git a/NEWS.md b/NEWS.md
index ee6a4a520..2a37250bd 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,8 @@
 # roxygen2 (development version)
 
+* `@exportS3Method` provides the needed metadata to generate correct usage
+  for S3 methods, just like `@method` (#1202).
+
 * If you document a function from another package it is automatically 
   imported. Additionally, if you set `@rdname` or `@name` you can opt out 
   of the default `reexports` topic generation and provide your own docs 
diff --git a/R/namespace.R b/R/namespace.R
index 38f77fef1..c12225fd5 100644
--- a/R/namespace.R
+++ b/R/namespace.R
@@ -207,7 +207,7 @@ roxy_tag_ns.roxy_tag_exportS3Method <- function(x, block, env) {
 
     method <- attr(obj$value, "s3method")
   } else if (length(x$val) == 1) {
-    if (!inherits(obj, "function")) {
+    if (!inherits(obj, "function") && !inherits(obj, "s3method")) {
       warn_roxy_tag(x, "must be used with a function")
       return()
     }
diff --git a/R/object-from-call.R b/R/object-from-call.R
index 5b71ccb69..b99c6546e 100644
--- a/R/object-from-call.R
+++ b/R/object-from-call.R
@@ -71,7 +71,7 @@ object_from_name <- function(name, env, block) {
   } else if (is.function(value)) {
     # Potential S3 methods/generics need metadata added
     method <- block_get_tag_value(block, "method")
-    value <- add_s3_metadata(value, name, env, method)
+    value <- add_s3_metadata(value, name, env, block)
     if (inherits(value, "s3generic")) {
       type <- "s3generic"
     } else if (inherits(value, "s3method")) {
@@ -185,8 +185,7 @@ parser_setMethodS3 <- function(call, env, block) {
   class <- as.character(call[[3]])
   name <- paste(method, class, sep = ".")
 
-  method <- block_get_tag_value(block, "method")
-  value <- add_s3_metadata(get(name, env), name, env, method)
+  value <- add_s3_metadata(get(name, env), name, env, block)
 
   object(value, name, "s3method")
 }
@@ -199,10 +198,19 @@ parser_setConstructorS3 <- function(call, env, block) {
 
 # helpers -----------------------------------------------------------------
 
-# @param override Either NULL to use default, or a character vector of length 2
-add_s3_metadata <- function(val, name, env, override = NULL) {
-  if (!is.null(override)) {
-    return(s3_method(val, override))
+add_s3_metadata <- function(val, name, env, block) {
+  if (block_has_tags(block, "method")) {
+    method <- block_get_tag_value(block, "method")
+    return(s3_method(val, method))
+  }
+
+  if (block_has_tags(block, "exportS3Method")) {
+    method <- block_get_tag_value(block, "exportS3Method")
+    if (length(method) == 1 && str_detect(method, "::")) {
+      generic <- strsplit(method, "::")[[1]][[2]]
+      class <- gsub(paste0("^", generic, "\\."), "", name)
+      return(s3_method(val, c(generic, class)))
+    }
   }
 
   if (is_s3_generic(name, env)) {
diff --git a/tests/testthat/test-object-from-call.R b/tests/testthat/test-object-from-call.R
index 40482a29c..c5537b1e9 100644
--- a/tests/testthat/test-object-from-call.R
+++ b/tests/testthat/test-object-from-call.R
@@ -127,6 +127,39 @@ test_that("finds function created with delayed assignment", {
   expect_s3_class(obj, "function")
 })
 
+# S3 ----------------------------------------------------------------------
+
+test_that("can derive S3 metadata for base generics", {
+  block <- "
+    #' @export
+    mean.foo <- function(...) 1
+  "
+  out <- parse_text(block)[[1]]
+
+  expect_equal(s3_method_info(out$object$value), c("mean", "foo"))
+})
+
+test_that("@method overrides auto-detection", {
+  block <- "
+    #' @export
+    #' @method all.equal data.frame
+    all.equal.data.frame <- function(...) 1
+  "
+  out <- parse_text(block)[[1]]
+
+  expect_equal(s3_method_info(out$object$value), c("all.equal", "data.frame"))
+})
+
+test_that("exportS3Method registers S3 metadata", {
+  block <- "
+    #' @exportS3Method stats::median
+    median.foo <- function(...) 1
+  "
+  out <- parse_text(block)[[1]]
+  expect_equal(s3_method_info(out$object$value), c("median", "foo"))
+})
+
+
 # S4 ----------------------------------------------------------------------
 
 test_that("finds S4 and RC classes", {
@@ -184,6 +217,7 @@ test_that("finds arguments when S4 method wrapped inside .local()", {
   expect_named(formals(obj$value@.Data), c("x", "foo", "..."))
 })
 
+
 # R.oo / R.methodsS3 ------------------------------------------------------
 
 test_that("can define constructor with R.oo", {
diff --git a/tests/testthat/test-object-s3.R b/tests/testthat/test-object-s3.R
index c1f104763..6d1b88fe2 100644
--- a/tests/testthat/test-object-s3.R
+++ b/tests/testthat/test-object-s3.R
@@ -50,13 +50,3 @@ test_that("user defined functions override primitives", {
   expect_false(is_s3_generic("c"))
   expect_false(is_s3_method("c"))
 })
-
-test_that("@method overrides auto-detection", {
-  out <- parse_text("
-    #' @export
-    #' @method all.equal data.frame
-    all.equal.data.frame <- function(...) 1
-  ")[[1]]
-
-  expect_equal(s3_method_info(out$object$value), c("all.equal", "data.frame"))
-})