From cf551c63ecae4c8b2de591c25a1a66f6418c5737 Mon Sep 17 00:00:00 2001
From: Jim Hester <jimhester@netflix.com>
Date: Tue, 29 Oct 2024 12:31:28 -0400
Subject: [PATCH 01/20] Initial work on S7 support for covr

---
 R/S7.R                                        | 28 +++++++++++++++
 R/covr.R                                      |  1 +
 src/reassign.c                                |  3 +-
 tests/testthat/TestS7/DESCRIPTION             | 17 ++++++++++
 tests/testthat/TestS7/NAMESPACE               |  3 ++
 tests/testthat/TestS7/R/foo.R                 | 34 +++++++++++++++++++
 tests/testthat/TestS7/tests/testthat.R        | 12 +++++++
 .../testthat/TestS7/tests/testthat/test-foo.R | 18 ++++++++++
 tests/testthat/test-S7.R                      |  5 +++
 9 files changed, 119 insertions(+), 2 deletions(-)
 create mode 100644 R/S7.R
 create mode 100644 tests/testthat/TestS7/DESCRIPTION
 create mode 100644 tests/testthat/TestS7/NAMESPACE
 create mode 100644 tests/testthat/TestS7/R/foo.R
 create mode 100644 tests/testthat/TestS7/tests/testthat.R
 create mode 100644 tests/testthat/TestS7/tests/testthat/test-foo.R
 create mode 100644 tests/testthat/test-S7.R

diff --git a/R/S7.R b/R/S7.R
new file mode 100644
index 00000000..bb1c6509
--- /dev/null
+++ b/R/S7.R
@@ -0,0 +1,28 @@
+replacements_S7 <- function(env) {
+  unlist(recursive = FALSE, use.names = FALSE, eapply(env, all.names = TRUE,
+    function(obj) {
+      if (inherits(obj, "S7_generic")) {
+        traverse_S7_generic(obj)
+      } else if (inherits(obj, "S7_class")) {
+        traverse_S7_class(obj)
+      }
+    }))
+}
+
+traverse_S7_generic <- function(x) {
+	 lapply(names(x@methods), replacement, env = x@methods)
+}
+
+traverse_S7_class <- function(x) {
+  c(use.names=FALSE,
+    list(
+      replacement("constructor", env = x, target_value=x@constructor),
+      replacement("validator", env = x, target_value=x@validator)
+    ),
+    for (prop_fun in c("getter", "setter", "validator")) {
+      lapply(x@properties, function(p) {
+        if (!is.null(p[[prop_fun]])) { replacement(prop_fun, env=p, target_value=p[[prop_fun]]) }
+      })
+    }
+  )
+}
\ No newline at end of file
diff --git a/R/covr.R b/R/covr.R
index 7510db65..6117ad9b 100644
--- a/R/covr.R
+++ b/R/covr.R
@@ -93,6 +93,7 @@ trace_environment <- function(env) {
       replacements_S4(env),
       replacements_RC(env),
       replacements_R6(env),
+      replacements_S7(env),
       replacements_box(env),
       lapply(ls(env, all.names = TRUE), replacement, env = env)))
 
diff --git a/src/reassign.c b/src/reassign.c
index db01f307..6997ecfc 100644
--- a/src/reassign.c
+++ b/src/reassign.c
@@ -5,9 +5,8 @@
 #include <Rdefines.h>
 #include <stdlib.h>  // for NULL
 
-SEXP covr_reassign_function(SEXP name, SEXP env, SEXP old_fun, SEXP new_fun) {
+SEXP covr_reassign_function(SEXP name, SEXP /* unused */ env, SEXP old_fun, SEXP new_fun) {
   if (TYPEOF(name) != SYMSXP) error("name must be a symbol");
-  if (TYPEOF(env) != ENVSXP) error("env must be an environment");
   if (TYPEOF(old_fun) != CLOSXP) error("old_fun must be a function");
   if (TYPEOF(new_fun) != CLOSXP) error("new_fun must be a function");
 
diff --git a/tests/testthat/TestS7/DESCRIPTION b/tests/testthat/TestS7/DESCRIPTION
new file mode 100644
index 00000000..ae47f8ae
--- /dev/null
+++ b/tests/testthat/TestS7/DESCRIPTION
@@ -0,0 +1,17 @@
+Package: tests7
+Title: What the Package Does (One Line, Title Case)
+Version: 0.0.0.9000
+Authors@R: c(
+    person("Jim", "Hester", , "james.f.hester@gmail.com", role = c("aut", "cre"),
+           comment = c(ORCID = "0000-0002-2739-7082")),
+    person("RStudio", role = c("cph", "fnd"))
+  )
+Description: What the package does (one paragraph).
+License: MIT + file LICENSE
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.3.1
+Imports: S7
+Suggests: 
+    testthat (>= 3.0.0)
+Config/testthat/edition: 3
diff --git a/tests/testthat/TestS7/NAMESPACE b/tests/testthat/TestS7/NAMESPACE
new file mode 100644
index 00000000..587cf7fc
--- /dev/null
+++ b/tests/testthat/TestS7/NAMESPACE
@@ -0,0 +1,3 @@
+# Generated by roxygen2: do not edit by hand
+
+import(S7)
diff --git a/tests/testthat/TestS7/R/foo.R b/tests/testthat/TestS7/R/foo.R
new file mode 100644
index 00000000..0603c2c2
--- /dev/null
+++ b/tests/testthat/TestS7/R/foo.R
@@ -0,0 +1,34 @@
+#' @import S7
+range <- new_class("range",
+  properties = list(
+    start = class_double,
+    end = class_double,
+    length = new_property(
+      class = class_double,
+      getter = function(self) self@end - self@start,
+      setter = function(self, value) {
+        self@end <- self@start + value
+        self
+      }
+    )
+  ),
+  constructor = function(x) {
+    new_object(S7_object(), start = as.double(min(x, na.rm = TRUE)), end = as.double(max(x, na.rm = TRUE)))
+  },
+  validator = function(self) {
+    if (length(self@start) != 1) {
+      "@start must be length 1"
+    } else if (length(self@end) != 1) {
+      "@end must be length 1"
+    } else if (self@end < self@start) {
+      "@end must be greater than or equal to @start"
+    }
+  }
+)
+
+#' @export
+inside <- new_generic("inside", "x")
+
+method(inside, range) <- function(x, y) {
+  y >= x@start & y <= x@end
+}
diff --git a/tests/testthat/TestS7/tests/testthat.R b/tests/testthat/TestS7/tests/testthat.R
new file mode 100644
index 00000000..df23a12d
--- /dev/null
+++ b/tests/testthat/TestS7/tests/testthat.R
@@ -0,0 +1,12 @@
+# This file is part of the standard setup for testthat.
+# It is recommended that you do not modify it.
+#
+# Where should you do additional test configuration?
+# Learn more about the roles of various files in:
+# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview
+# * https://testthat.r-lib.org/articles/special-files.html
+
+library(testthat)
+library(tests7)
+
+test_check("tests7")
diff --git a/tests/testthat/TestS7/tests/testthat/test-foo.R b/tests/testthat/TestS7/tests/testthat/test-foo.R
new file mode 100644
index 00000000..987115e5
--- /dev/null
+++ b/tests/testthat/TestS7/tests/testthat/test-foo.R
@@ -0,0 +1,18 @@
+test_that("range works", {
+  x <- range(1:10)
+
+  x@end <- 20
+
+  expect_error(x@end <- "x", "must be <double>")
+
+  expect_error(x@end <- -1, "greater than or equal")
+
+  expect_equal(inside(x, c(0, 5, 10, 15)), c(FALSE, TRUE, TRUE, TRUE))
+
+  x@length <- 5
+
+  expect_equal(x@length, 5)
+  expect_equal(x@end, 6)
+})
+
+
diff --git a/tests/testthat/test-S7.R b/tests/testthat/test-S7.R
new file mode 100644
index 00000000..92b97134
--- /dev/null
+++ b/tests/testthat/test-S7.R
@@ -0,0 +1,5 @@
+test_that("S7 coverage is reported", {
+  cov <- as.data.frame(package_coverage("TestS7"))
+ 
+  expect_equal(cov$value, c(1, 1, 1, 1, 3, 0, 3, 0, 3, 1, 1))
+})

From 682b17c395e363bfde6be9bbf835fff8c1924850 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 11:53:32 -0500
Subject: [PATCH 02/20] fix prop replacements in `traverse_S7_class`

---
 R/S7.R | 18 ++++++++++++------
 1 file changed, 12 insertions(+), 6 deletions(-)

diff --git a/R/S7.R b/R/S7.R
index bb1c6509..068a38f4 100644
--- a/R/S7.R
+++ b/R/S7.R
@@ -14,15 +14,21 @@ traverse_S7_generic <- function(x) {
 }
 
 traverse_S7_class <- function(x) {
-  c(use.names=FALSE,
+  prop_fun_replacements <-
+    lapply(x@properties, function(p) {
+      lapply(c("getter", "setter", "validator"), function(prop_fun) {
+        if (!is.null(p[[prop_fun]])) {
+          replacement(prop_fun, env = p, target_value = p[[prop_fun]])
+        }
+      })
+  })
+  prop_fun_replacements <- unlist(prop_fun_replacements, FALSE, FALSE)
+
+  c(
     list(
       replacement("constructor", env = x, target_value=x@constructor),
       replacement("validator", env = x, target_value=x@validator)
     ),
-    for (prop_fun in c("getter", "setter", "validator")) {
-      lapply(x@properties, function(p) {
-        if (!is.null(p[[prop_fun]])) { replacement(prop_fun, env=p, target_value=p[[prop_fun]]) }
-      })
-    }
+    prop_fun_replacements
   )
 }
\ No newline at end of file

From 5d69e0e21e77c4e954669d96e3995f4da958dcde Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 11:53:53 -0500
Subject: [PATCH 03/20] handle multi-dispatch generics in
 `traverse_S7_generic()`

---
 R/S7.R | 16 +++++++++++++++-
 1 file changed, 15 insertions(+), 1 deletion(-)

diff --git a/R/S7.R b/R/S7.R
index 068a38f4..aaf109b2 100644
--- a/R/S7.R
+++ b/R/S7.R
@@ -10,7 +10,21 @@ replacements_S7 <- function(env) {
 }
 
 traverse_S7_generic <- function(x) {
-	 lapply(names(x@methods), replacement, env = x@methods)
+  # Each binding in the environment at x@methods is either a function or, for
+  # generics that dispatch on multiple arguments, another environment.
+  get_replacements <- function(env) {
+    replacements <- lapply(names(env), function(name) {
+      target_value <- get(name, envir = env)
+      if (is.environment(target_value)) {
+        # Recurse for nested environments
+        get_replacements(target_value)
+      } else {
+        list(replacement(name, env, target_value))
+      }
+    })
+    unlist(replacements, FALSE, FALSE)
+  }
+  get_replacements(x@methods)
 }
 
 traverse_S7_class <- function(x) {

From 659804d25646308f7176e9a41242ea5bf64502c9 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 11:55:13 -0500
Subject: [PATCH 04/20] add missing `test_path()` in tests

---
 tests/testthat/test-S7.R | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/tests/testthat/test-S7.R b/tests/testthat/test-S7.R
index 92b97134..fb096857 100644
--- a/tests/testthat/test-S7.R
+++ b/tests/testthat/test-S7.R
@@ -1,5 +1,5 @@
 test_that("S7 coverage is reported", {
-  cov <- as.data.frame(package_coverage("TestS7"))
- 
+  cov <- as.data.frame(package_coverage(test_path("TestS7")))
+
   expect_equal(cov$value, c(1, 1, 1, 1, 3, 0, 3, 0, 3, 1, 1))
 })

From 8058180326b9bb71b003ac2175d56b8d9c14bdb4 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 11:56:08 -0500
Subject: [PATCH 05/20] update expected validator run counts in tests: 3 -> 4

---
 tests/testthat/test-S7.R | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/testthat/test-S7.R b/tests/testthat/test-S7.R
index fb096857..0ba7a8b5 100644
--- a/tests/testthat/test-S7.R
+++ b/tests/testthat/test-S7.R
@@ -1,5 +1,5 @@
 test_that("S7 coverage is reported", {
   cov <- as.data.frame(package_coverage(test_path("TestS7")))
 
-  expect_equal(cov$value, c(1, 1, 1, 1, 3, 0, 3, 0, 3, 1, 1))
+  expect_equal(cov$value, c(1, 1, 1, 1, 4, 0, 4, 0, 4, 1, 1))
 })

From 712211c456b01f39287c591238ba5af4720af823 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 11:58:08 -0500
Subject: [PATCH 06/20] CamelCase S7 class name

---
 tests/testthat/TestS7/R/foo.R                   | 4 ++--
 tests/testthat/TestS7/tests/testthat/test-foo.R | 6 ++----
 2 files changed, 4 insertions(+), 6 deletions(-)

diff --git a/tests/testthat/TestS7/R/foo.R b/tests/testthat/TestS7/R/foo.R
index 0603c2c2..786934db 100644
--- a/tests/testthat/TestS7/R/foo.R
+++ b/tests/testthat/TestS7/R/foo.R
@@ -1,5 +1,5 @@
 #' @import S7
-range <- new_class("range",
+Range <- new_class("Range",
   properties = list(
     start = class_double,
     end = class_double,
@@ -29,6 +29,6 @@ range <- new_class("range",
 #' @export
 inside <- new_generic("inside", "x")
 
-method(inside, range) <- function(x, y) {
+method(inside, Range) <- function(x, y) {
   y >= x@start & y <= x@end
 }
diff --git a/tests/testthat/TestS7/tests/testthat/test-foo.R b/tests/testthat/TestS7/tests/testthat/test-foo.R
index 987115e5..0af07179 100644
--- a/tests/testthat/TestS7/tests/testthat/test-foo.R
+++ b/tests/testthat/TestS7/tests/testthat/test-foo.R
@@ -1,5 +1,5 @@
-test_that("range works", {
-  x <- range(1:10)
+test_that("Range works", {
+  x <- Range(1:10)
 
   x@end <- 20
 
@@ -14,5 +14,3 @@ test_that("range works", {
   expect_equal(x@length, 5)
   expect_equal(x@end, 6)
 })
-
-

From 1599df7cd73b984d35e539d1392425528516ae17 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 12:26:47 -0500
Subject: [PATCH 07/20] Fix package-name / dir-name mismatch

---
 tests/testthat/TestS7/DESCRIPTION | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/testthat/TestS7/DESCRIPTION b/tests/testthat/TestS7/DESCRIPTION
index ae47f8ae..5d220743 100644
--- a/tests/testthat/TestS7/DESCRIPTION
+++ b/tests/testthat/TestS7/DESCRIPTION
@@ -1,4 +1,4 @@
-Package: tests7
+Package: TestS7
 Title: What the Package Does (One Line, Title Case)
 Version: 0.0.0.9000
 Authors@R: c(

From 8687ed4e771cfd795d77abd23eac1a2542f45411 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 12:32:25 -0500
Subject: [PATCH 08/20] revert `test_path()` usage

---
 tests/testthat/test-S7.R | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/testthat/test-S7.R b/tests/testthat/test-S7.R
index 0ba7a8b5..45af3fa7 100644
--- a/tests/testthat/test-S7.R
+++ b/tests/testthat/test-S7.R
@@ -1,5 +1,5 @@
 test_that("S7 coverage is reported", {
-  cov <- as.data.frame(package_coverage(test_path("TestS7")))
+  cov <- as.data.frame(package_coverage("TestS7"))
 
   expect_equal(cov$value, c(1, 1, 1, 1, 4, 0, 4, 0, 4, 1, 1))
 })

From 517a018a0f2c51b83e1f1d2b3a40130d8e157bd1 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 12:44:05 -0500
Subject: [PATCH 09/20] one more test pkgname fix

---
 tests/testthat/TestS7/tests/testthat.R | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/tests/testthat/TestS7/tests/testthat.R b/tests/testthat/TestS7/tests/testthat.R
index df23a12d..e4a3e859 100644
--- a/tests/testthat/TestS7/tests/testthat.R
+++ b/tests/testthat/TestS7/tests/testthat.R
@@ -7,6 +7,6 @@
 # * https://testthat.r-lib.org/articles/special-files.html
 
 library(testthat)
-library(tests7)
+library(TestS7)
 
-test_check("tests7")
+test_check("TestS7")

From 459217f4e2daccfc6c3de59eef00b67225cc8d39 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 15:42:55 -0500
Subject: [PATCH 10/20] add S7 to Suggests

---
 DESCRIPTION | 1 +
 1 file changed, 1 insertion(+)

diff --git a/DESCRIPTION b/DESCRIPTION
index 35845bed..7ded0970 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -56,6 +56,7 @@ Imports:
     yaml
 Suggests:
     R6,
+    S7,
     curl,
     knitr,
     rmarkdown,

From 4add15bd1b1a6d50572ae1262886ee07c5704ad3 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 16:20:42 -0500
Subject: [PATCH 11/20] Revert "update expected validator run counts in tests:
 3 -> 4"

This reverts commit 8058180326b9bb71b003ac2175d56b8d9c14bdb4.
---
 tests/testthat/test-S7.R | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/testthat/test-S7.R b/tests/testthat/test-S7.R
index 45af3fa7..9b5d0632 100644
--- a/tests/testthat/test-S7.R
+++ b/tests/testthat/test-S7.R
@@ -1,5 +1,5 @@
 test_that("S7 coverage is reported", {
   cov <- as.data.frame(package_coverage("TestS7"))
 
-  expect_equal(cov$value, c(1, 1, 1, 1, 4, 0, 4, 0, 4, 1, 1))
+  expect_equal(cov$value, c(1, 1, 1, 1, 3, 0, 3, 0, 3, 1, 1))
 })

From efbbd52076daf256f44717f5038f03a43a00b401 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 16:31:26 -0500
Subject: [PATCH 12/20] Use `S7::prop()` instead of `@` for R oldrel compat

---
 R/S7.R | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/R/S7.R b/R/S7.R
index aaf109b2..2cc27088 100644
--- a/R/S7.R
+++ b/R/S7.R
@@ -29,7 +29,7 @@ traverse_S7_generic <- function(x) {
 
 traverse_S7_class <- function(x) {
   prop_fun_replacements <-
-    lapply(x@properties, function(p) {
+    lapply(S7::prop(x, "properties"), function(p) {
       lapply(c("getter", "setter", "validator"), function(prop_fun) {
         if (!is.null(p[[prop_fun]])) {
           replacement(prop_fun, env = p, target_value = p[[prop_fun]])
@@ -40,9 +40,9 @@ traverse_S7_class <- function(x) {
 
   c(
     list(
-      replacement("constructor", env = x, target_value=x@constructor),
-      replacement("validator", env = x, target_value=x@validator)
+      replacement("constructor", env = x, target_value = S7::prop(x, "constructor")),
+      replacement("validator"  , env = x, target_value = S7::prop(x, "validator"))
     ),
     prop_fun_replacements
   )
-}
\ No newline at end of file
+}

From f228960022036614ff35395371f07e7e979eae60 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 18:41:37 -0500
Subject: [PATCH 13/20] import backported `@` in TestS7 package

---
 tests/testthat/TestS7/DESCRIPTION | 2 +-
 tests/testthat/TestS7/NAMESPACE   | 3 +++
 tests/testthat/TestS7/R/foo.R     | 5 +++++
 3 files changed, 9 insertions(+), 1 deletion(-)

diff --git a/tests/testthat/TestS7/DESCRIPTION b/tests/testthat/TestS7/DESCRIPTION
index 5d220743..33f0c65f 100644
--- a/tests/testthat/TestS7/DESCRIPTION
+++ b/tests/testthat/TestS7/DESCRIPTION
@@ -10,7 +10,7 @@ Description: What the package does (one paragraph).
 License: MIT + file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Imports: S7
 Suggests: 
     testthat (>= 3.0.0)
diff --git a/tests/testthat/TestS7/NAMESPACE b/tests/testthat/TestS7/NAMESPACE
index 587cf7fc..3e02b753 100644
--- a/tests/testthat/TestS7/NAMESPACE
+++ b/tests/testthat/TestS7/NAMESPACE
@@ -1,3 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+export(Range)
+export(inside)
+if (getRversion() < "4.3.0") importFrom("S7", "@")
 import(S7)
diff --git a/tests/testthat/TestS7/R/foo.R b/tests/testthat/TestS7/R/foo.R
index 786934db..13c4a6a6 100644
--- a/tests/testthat/TestS7/R/foo.R
+++ b/tests/testthat/TestS7/R/foo.R
@@ -1,4 +1,5 @@
 #' @import S7
+#' @export
 Range <- new_class("Range",
   properties = list(
     start = class_double,
@@ -32,3 +33,7 @@ inside <- new_generic("inside", "x")
 method(inside, Range) <- function(x, y) {
   y >= x@start & y <= x@end
 }
+
+# enable usage of <S7_object>@name in package code
+#' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@")
+NULL

From 085939a2ccc0ec77f949e702ddd817518a06cef1 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 19:10:02 -0500
Subject: [PATCH 14/20] stray `@` -> `S7::prop()` replacement

---
 R/S7.R | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/R/S7.R b/R/S7.R
index 2cc27088..c38a7532 100644
--- a/R/S7.R
+++ b/R/S7.R
@@ -24,7 +24,7 @@ traverse_S7_generic <- function(x) {
     })
     unlist(replacements, FALSE, FALSE)
   }
-  get_replacements(x@methods)
+  get_replacements(S7::prop(x, "methods"))
 }
 
 traverse_S7_class <- function(x) {

From 6583c1313934a35c9242f38114bd59daa85d21ad Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 19:11:01 -0500
Subject: [PATCH 15/20] return of `test_path()`

---
 tests/testthat/test-S7.R | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/testthat/test-S7.R b/tests/testthat/test-S7.R
index 9b5d0632..fb096857 100644
--- a/tests/testthat/test-S7.R
+++ b/tests/testthat/test-S7.R
@@ -1,5 +1,5 @@
 test_that("S7 coverage is reported", {
-  cov <- as.data.frame(package_coverage("TestS7"))
+  cov <- as.data.frame(package_coverage(test_path("TestS7")))
 
   expect_equal(cov$value, c(1, 1, 1, 1, 3, 0, 3, 0, 3, 1, 1))
 })

From 1636d1262e4a131c5359d2c59b178fc0629a0fb1 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Thu, 7 Nov 2024 19:21:49 -0500
Subject: [PATCH 16/20] Class validator runs 4 times, not 3

---
 tests/testthat/test-S7.R | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/testthat/test-S7.R b/tests/testthat/test-S7.R
index fb096857..0ba7a8b5 100644
--- a/tests/testthat/test-S7.R
+++ b/tests/testthat/test-S7.R
@@ -1,5 +1,5 @@
 test_that("S7 coverage is reported", {
   cov <- as.data.frame(package_coverage(test_path("TestS7")))
 
-  expect_equal(cov$value, c(1, 1, 1, 1, 3, 0, 3, 0, 3, 1, 1))
+  expect_equal(cov$value, c(1, 1, 1, 1, 4, 0, 4, 0, 4, 1, 1))
 })

From 59b1f7e7dc9cdad8d753f052b96a26eee4bef144 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <kalinowskit@gmail.com>
Date: Fri, 8 Nov 2024 07:33:52 -0500
Subject: [PATCH 17/20] Install S7 >= 0.2.0

---
 DESCRIPTION | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/DESCRIPTION b/DESCRIPTION
index 7ded0970..d72b1226 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -56,7 +56,7 @@ Imports:
     yaml
 Suggests:
     R6,
-    S7,
+    S7 (>= 0.2.0),
     curl,
     knitr,
     rmarkdown,

From 580544d5c7e9318aef78eb15edc53564e4c6254b Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Fri, 8 Nov 2024 11:18:09 -0500
Subject: [PATCH 18/20] better names in coverage report

Give the `cov$functions` columns more informative names, for interactive development. E.g.:

> cov$functions
 [1] "Range@properties$length$getter"
 [2] "Range@properties$length$setter"
 [3] "Range@properties$length$setter"
 [4] "Range@constructor"
 [5] "Range@validator"
 [6] "Range@validator"
 [7] "Range@validator"
 [8] "Range@validator"
 [9] "Range@validator"
[10] "Range@validator"
[11] "method(inside, TestS7::Range)"
---
 R/S7.R | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

diff --git a/R/S7.R b/R/S7.R
index c38a7532..26931b44 100644
--- a/R/S7.R
+++ b/R/S7.R
@@ -19,6 +19,7 @@ traverse_S7_generic <- function(x) {
         # Recurse for nested environments
         get_replacements(target_value)
       } else {
+        name <- as.character(attr(target_value, "name", TRUE) %||% name)
         list(replacement(name, env, target_value))
       }
     })
@@ -28,11 +29,15 @@ traverse_S7_generic <- function(x) {
 }
 
 traverse_S7_class <- function(x) {
+  class_name <- S7::prop(x, "name")
   prop_fun_replacements <-
     lapply(S7::prop(x, "properties"), function(p) {
       lapply(c("getter", "setter", "validator"), function(prop_fun) {
         if (!is.null(p[[prop_fun]])) {
-          replacement(prop_fun, env = p, target_value = p[[prop_fun]])
+          replacement(
+            sprintf("%s@properties$%s$%s", class_name, p$name, prop_fun),
+            env = p,
+            target_value = p[[prop_fun]])
         }
       })
   })
@@ -40,8 +45,8 @@ traverse_S7_class <- function(x) {
 
   c(
     list(
-      replacement("constructor", env = x, target_value = S7::prop(x, "constructor")),
-      replacement("validator"  , env = x, target_value = S7::prop(x, "validator"))
+      replacement(paste0(class_name, "@constructor"), env = x, target_value = S7::prop(x, "constructor")),
+      replacement(paste0(class_name, "@validator")  , env = x, target_value = S7::prop(x, "validator"))
     ),
     prop_fun_replacements
   )

From 5d1cafa1c84113002bcb1092a4303803693cb6a9 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Fri, 8 Nov 2024 12:08:00 -0500
Subject: [PATCH 19/20] Add support for S7 methods registered for external
 generics

---
 R/S7.R                                        | 33 ++++++++++++++++++-
 tests/testthat/TestS7/R/foo.R                 | 15 +++++++++
 .../testthat/TestS7/tests/testthat/test-foo.R |  8 +++++
 tests/testthat/_snaps/S7.md                   | 22 +++++++++++++
 tests/testthat/test-S7.R                      |  4 ++-
 5 files changed, 80 insertions(+), 2 deletions(-)
 create mode 100644 tests/testthat/_snaps/S7.md

diff --git a/R/S7.R b/R/S7.R
index 26931b44..e76c9afa 100644
--- a/R/S7.R
+++ b/R/S7.R
@@ -1,5 +1,5 @@
 replacements_S7 <- function(env) {
-  unlist(recursive = FALSE, use.names = FALSE, eapply(env, all.names = TRUE,
+  bindings <- unlist(recursive = FALSE, use.names = FALSE, eapply(env, all.names = TRUE,
     function(obj) {
       if (inherits(obj, "S7_generic")) {
         traverse_S7_generic(obj)
@@ -7,6 +7,21 @@ replacements_S7 <- function(env) {
         traverse_S7_class(obj)
       }
     }))
+
+  S7_methods_tbl <- attr(env[[".__S3MethodsTable__."]], "S7methods", TRUE)
+  external_methods <- lapply(seq_along(S7_methods_tbl), function(i) {
+    entry <- S7_methods_tbl[[i]]
+    name <- external_generic_method_signature(entry$generic, entry$signature)
+
+    replacement(
+      # `name` is for informative printouts only.
+      # It is not used by covr, and does not need to be unique,
+      name = name,
+      env = entry,
+      target_value = entry$method)
+  })
+
+  c(bindings, external_methods)
 }
 
 traverse_S7_generic <- function(x) {
@@ -51,3 +66,19 @@ traverse_S7_class <- function(x) {
     prop_fun_replacements
   )
 }
+
+
+external_generic_method_signature <- function(generic, signature) {
+  # This function is a lightly modified copy of S7:::method_signature() for external generics
+  display_generic <- paste0(c(generic$package, generic$name), collapse = "::")
+  class_deparse <- asNamespace("S7")$class_deparse # not exported from S7 :/
+  single <- length(generic$dispatch_args) == 1
+  if (single) {
+    signature <- class_deparse(signature[[1]])
+  } else {
+    classes <- vapply(signature, class_deparse, "", USE.NAMES = FALSE)
+    signature <- paste0("list(", paste0(classes, collapse = ", "), ")")
+  }
+
+  sprintf("method(%s, %s)", display_generic, signature)
+}
diff --git a/tests/testthat/TestS7/R/foo.R b/tests/testthat/TestS7/R/foo.R
index 13c4a6a6..77060924 100644
--- a/tests/testthat/TestS7/R/foo.R
+++ b/tests/testthat/TestS7/R/foo.R
@@ -37,3 +37,18 @@ method(inside, Range) <- function(x, y) {
 # enable usage of <S7_object>@name in package code
 #' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@")
 NULL
+
+# test external S3 generics
+method(format, Range) <- function(x) {
+  sprintf("Range(%s, %s)", x@start, x@end)
+}
+
+testthat_print <- new_external_generic("testthat", "testthat_print", "x")
+method(testthat_print, Range) <- function(x, ...) {
+  cat(format(x))
+  invisible(x)
+}
+
+.onLoad <- function(libname, pkgname) {
+  S7::methods_register()
+}
\ No newline at end of file
diff --git a/tests/testthat/TestS7/tests/testthat/test-foo.R b/tests/testthat/TestS7/tests/testthat/test-foo.R
index 0af07179..5877d020 100644
--- a/tests/testthat/TestS7/tests/testthat/test-foo.R
+++ b/tests/testthat/TestS7/tests/testthat/test-foo.R
@@ -14,3 +14,11 @@ test_that("Range works", {
   expect_equal(x@length, 5)
   expect_equal(x@end, 6)
 })
+
+test_that("Range methods work", {
+  x <- Range(1:10)
+  expect_equal(base::format(x), "Range(1, 10)")
+
+  # Test external generic method for testthat::testthat_print()
+  expect_equal(testthat::capture_output(x, print = TRUE), "Range(1, 10)")
+})
\ No newline at end of file
diff --git a/tests/testthat/_snaps/S7.md b/tests/testthat/_snaps/S7.md
new file mode 100644
index 00000000..50a3e336
--- /dev/null
+++ b/tests/testthat/_snaps/S7.md
@@ -0,0 +1,22 @@
+# S7 coverage is reported
+
+    Code
+      cov[, c("functions", "first_line", "last_line", "value")]
+    Output
+                                               functions first_line last_line value
+      1                   Range@properties$length$getter          9         9     1
+      2                   Range@properties$length$setter         11        11     1
+      3                   Range@properties$length$setter         12        12     1
+      4                                            Range         17        17     2
+      5                                  Range@validator         20        20     5
+      6                                  Range@validator         21        21     0
+      7                                  Range@validator         22        22     5
+      8                                  Range@validator         23        23     0
+      9                                  Range@validator         24        24     5
+      10                                 Range@validator         25        25     1
+      11                   method(inside, TestS7::Range)         34        34     1
+      12             method(base::format, TestS7::Range)         43        43     2
+      13 method(testthat::testthat_print, TestS7::Range)         48        48     1
+      14 method(testthat::testthat_print, TestS7::Range)         49        49     1
+      15                                         .onLoad         53        53     0
+
diff --git a/tests/testthat/test-S7.R b/tests/testthat/test-S7.R
index 0ba7a8b5..c5ce0dbc 100644
--- a/tests/testthat/test-S7.R
+++ b/tests/testthat/test-S7.R
@@ -1,5 +1,7 @@
 test_that("S7 coverage is reported", {
+  local_edition(3)
   cov <- as.data.frame(package_coverage(test_path("TestS7")))
 
-  expect_equal(cov$value, c(1, 1, 1, 1, 4, 0, 4, 0, 4, 1, 1))
+  expect_equal(cov$value, c(1, 1, 1, 2, 5, 0, 5, 0, 5, 1, 1, 2, 1, 1, 0))
+  expect_snapshot(cov[, c("functions", "first_line", "last_line", "value")])
 })

From 0aa82ed720b7723e6c314398eb1cd4445bf39459 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Fri, 8 Nov 2024 12:09:44 -0500
Subject: [PATCH 20/20] enable `workflow_dispatch` for R-CMD-check action

---
 .github/workflows/R-CMD-check.yaml | 1 +
 1 file changed, 1 insertion(+)

diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml
index ee65ccb5..5df3051d 100644
--- a/.github/workflows/R-CMD-check.yaml
+++ b/.github/workflows/R-CMD-check.yaml
@@ -5,6 +5,7 @@
 # check-standard.yaml is likely a better choice.
 # usethis::use_github_action("check-standard") will install it.
 on:
+  workflow_dispatch:
   push:
     branches: [main, master]
   pull_request: