Fix broken S3 generic discovery

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: box
 Title: Write Reusable, Composable and Modular R Code
-Version: 1.0.2
+Version: 1.0.2.9000
 Authors@R: c(
         person(
             'Konrad', 'Rudolph',

NEWS.md

@@ -1,3 +1,9 @@
+# box (development version)
+
+* Fix: Don’t crash in the presence of nested, expanded functions inside modules
+    (#203)
+
+
 # box 1.0.2
 
 * Make `box::help` work with attached objects (#170)

R/S3.r

@@ -43,19 +43,39 @@ register_S3_method = function (name, class, method) {
 #' @keywords internal
 #' @name s3
 is_S3_user_generic = function (function_name, envir = parent.frame()) {
-    is_S3 = function (b) {
-        if (length(b) == 0L) FALSE
-        else if (is.function(b)) b = body(b)
-        else if (is.call(b)) {
-            is_s3_dispatch = is.name(b[[1L]]) && b[[1L]] == 'UseMethod'
-            is_s3_dispatch || is_S3(as.list(b)[-1L])
-        } else is.recursive(b) && (is_S3(b[[1L]]) || is_S3(b[-1L]))
-    }
-
     ! bindingIsActive(function_name, envir) &&
         is_S3(body(get(function_name, envir = envir, mode = 'function')))
 }
 
+is_S3 = function (expr) {
+    if (length(expr) == 0L) {
+        FALSE
+    } else if (is.function(expr)) {
+        FALSE
+    } else if (is.call(expr)) {
+        fun = expr[[1L]]
+        if (is.name(fun)) {
+            # NB: this is relying purely on static analysis. We do not test
+            # whether these calls actually refer to the expected base R
+            # functions since that would require evaluating the function body in
+            # the general case (namely, the function body itself could redefine
+            # them).
+            if (identical(fun, quote(UseMethod))) return(TRUE)
+            # Make sure nested function definitions are *not* getting
+            # traversed: `UseMethod` inside a nested function does not make
+            # the containing function a generic.
+            if (identical(fun, quote(`function`))) return(FALSE)
+            Recall(as.list(expr)[-1])
+        } else {
+            Recall(fun) || Recall(expr[-1L])
+        }
+    } else if (is.recursive(expr)) {
+        Recall(expr[[1L]]) || Recall(expr[-1L])
+    } else {
+        FALSE
+    }
+}
+
 #' @param module the module object for which to register S3 methods
 #' @rdname s3
 make_S3_methods_known = function (module) {

tests/testthat/mod/issue203.r

@@ -0,0 +1,30 @@
+# The following defines a function which has a function inside its body. This is
+# *different* from a nested function; that is, `f` is different from
+#
+#   f1 = function () { identity }
+#
+# … because `f1` contains a *name* in its body. Likewise, it is different from
+#
+#   f2 = function () { function (x) x }
+#
+# … because `f2` contains a *call expression* which, when executed, *defines* a
+# function, in its body. That is:
+#
+#   class(body(f)[[2L]])  == 'function'
+#   class(body(f1)[[2L]]) == 'name'
+#   class(body(f2)[[2L]]) == 'call'
+f = function () { NULL }
+body(f)[[2L]] = identity
+
+#' `g` clearly isn’t a generic even though `UseMethod` is used inside a nested
+#' function in its body.
+#' @export
+g = function (x) {
+    nested = function () UseMethod('nested')
+    nested()
+}
+
+#' … nor is `h`.
+#' @export
+h = function () { NULL }
+body(h)[[2L]] = function () UseMethod('foo')

tests/testthat/test-S3.r

@@ -77,3 +77,9 @@ test_that('Forwarded S3 genetics without methods work', {
 test_that('`is_S3_user_generic` can deal with substituted functions', {
     expect_error(box::use(mod/issue125), regexp = NA)
 })
+
+test_that('nested functions are parsed correctly', {
+    expect_error(box::use(mod/issue203), NA)
+    expect_false(box:::is_S3_user_generic('g', issue203))
+    expect_false(box:::is_S3_user_generic('h', issue203))
+})