Refine external class resolution and deferred methods

NEWS.md

@@ -1,6 +1,5 @@
 # S7 (development version)
 
-* Internal changes to support R-devel (4.6) (#592, #593, #598, #600).
 * New `:=` operator creates and names an object in one step, so `Foo := new_class()` is equivalent to `Foo <- new_class(name = "Foo")` (#658).
 * Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646).
 * `class_POSIXct` uses the `tzone` attribute (not `tz`), and allows it to be absent (#401).

R/class-spec.R

@@ -204,7 +204,9 @@ class_validate <- function(class, object) {
     S7 = class@validator,
     S7_base = class$validator,
     S7_S3 = class$validator,
-    S7_external = class_validate(resolve_external_class_req(class), object),
+    S7_external = function(object) {
+      class_validate(resolve_external_class_req(class), object)
+    },
     NULL
   )
 
@@ -299,7 +301,13 @@ class_deparse <- function(x) {
       paste0("new_union(", paste(classes, collapse = ", "), ")")
     },
     S7_S3 = paste0("new_S3_class(", deparse1(x$class), ")"),
-    S7_external = sprintf("new_external_class(%s, %s)", x$package, x$name),
+    S7_external = {
+      args <- c(deparse1(x$package), deparse1(x$name))
+      if (!is.null(x$version)) {
+        args <- c(args, paste0("version = ", deparse1(x$version)))
+      }
+      sprintf("new_external_class(%s)", paste(args, collapse = ", "))
+    },
   )
 }
 
@@ -312,16 +320,28 @@ class_inherits <- function(x, what) {
     S4 = isS4(x) && methods::is(x, what),
     S7 = inherits(x, "S7_object") && inherits(x, S7_class_name(what)),
     S7_base = what$class == base_class(x),
-    S7_union = any(vlapply(what$classes, class_inherits, x = x)),
+    S7_union = {
+      for (class in what$classes) {
+        if (class_inherits(x, class)) {
+          return(TRUE)
+        }
+      }
+      FALSE
+    },
     S7_S3 = !isS4(x) && class_dispatch_extends(what$class, class(x)),
-    S7_external = inherits(x, "S7_object") && inherits(x, what$class_name),
+    S7_external = inherits(x, "S7_object") &&
+      inherits(x, what$class_name) &&
+      (is.null(what$version) ||
+        class_inherits(x, resolve_external_class_req(what))),
   )
 }
 
 # Is every instance of `child` guaranteed to also be an instance of `parent`?
 # Used to check that a child class only narrows the type of a property
 class_extends <- function(child, parent) {
-  if (is_class_any(parent) || union_contains_any(parent)) {
+  if (identical(child, parent)) {
+    TRUE
+  } else if (is_class_any(parent) || union_contains_any(parent)) {
     # as a parent, `class_any` accepts every child class
     TRUE
   } else if (is_class_any(child)) {
@@ -332,25 +352,34 @@ class_extends <- function(child, parent) {
     all(vlapply(child$classes, class_extends, parent = parent))
   } else if (is_union(parent)) {
     # A non-union child extends a union parent if it extends any of its members.
-    any(vlapply(parent$classes, class_extends, child = child))
+    for (class in parent$classes) {
+      if (class_extends(child, class)) {
+        return(TRUE)
+      }
+    }
+    FALSE
   } else if (is.null(child) && !is.null(parent)) {
     # as a child, NULL can only extend NULL
     FALSE
   } else if (is.null(parent)) {
     # as a parent, NULL only accepts NULL
     is.null(child)
-  } else if (is_S4_class(child) || is_S4_class(parent)) {
-    is_S4_class(child) &&
-      is_S4_class(parent) &&
-      methods::extends(child@className, parent@className)
   } else if (is_class(parent) && parent@name == "S7_object") {
-    is_class(child)
+    is_class(child) || is_external_class(child)
   } else if (is_external_class(child)) {
     child <- resolve_external_class_req(child)
     class_extends(child, parent)
+  } else if (is_class(child) && is_external_class(parent)) {
+    is_external_class_match(child, parent) &&
+      (is.null(parent$version) ||
+        class_extends(child, resolve_external_class_req(parent)))
   } else if (is_external_class(parent)) {
     parent <- resolve_external_class_req(parent)
     class_extends(child, parent)
+  } else if (is_S4_class(child) || is_S4_class(parent)) {
+    is_S4_class(child) &&
+      is_S4_class(parent) &&
+      methods::extends(child@className, parent@className)
   } else {
     # handle S7, S3, and base types.
     class_dispatch_extends(class_dispatch(parent), class_dispatch(child))

R/external-class.R

@@ -37,9 +37,9 @@
 #' @returns An S7 external class, i.e. a list with S3 class `S7_external_class`.
 #' @export
 #' @examples
-#' # Refer to a class in another package without taking a hard dependency:
-#' Tibble <- new_external_class("tibble", "tbl_df")
-#' Tibble
+#' # Refer to an S7 class in another package without taking a hard dependency:
+#' TheirClass <- new_external_class("theirpkg", "TheirClass")
+#' TheirClass
 #'
 #' # Self-referential class: the `child` property can be another `tree`,
 #' # or `NULL` to terminate the chain.
@@ -71,20 +71,6 @@ is_external_class <- function(x) {
   inherits(x, "S7_external_class")
 }
 
-class_has_external_class <- function(x) {
-  if (is_external_class(x)) {
-    TRUE
-  } else if (is_union(x)) {
-    any(vlapply(x$classes, class_has_external_class))
-  } else {
-    FALSE
-  }
-}
-
-signature_has_external_class <- function(signature) {
-  any(vlapply(signature, class_has_external_class))
-}
-
 class_external_deps <- function(x) {
   if (is_external_class(x)) {
     list(x)
@@ -99,6 +85,12 @@ signature_external_deps <- function(signature) {
   flatten_external_deps(lapply(signature, class_external_deps))
 }
 
+external_deps_resolvable <- function(deps) {
+  all(vlapply(deps, function(dep) {
+    dep_available(dep) && !is.null(find_external_class(dep))
+  }))
+}
+
 flatten_external_deps <- function(x) {
   unlist(x, recursive = FALSE, use.names = FALSE)
 }
@@ -116,16 +108,19 @@ print.S7_external_class <- function(x, ...) {
 }
 
 dep_available <- function(dep) {
-  isNamespaceLoaded(dep$package) &&
-    (is.null(dep$version) || getNamespaceVersion(dep$package) >= dep$version)
+  isNamespaceLoaded(dep$package) && dep_version_ok(dep)
+}
+
+dep_version_ok <- function(dep) {
+  is.null(dep$version) || getNamespaceVersion(dep$package) >= dep$version
 }
 
 # Make it mockable
 getNamespaceVersion <- NULL
 
 resolve_signature <- function(signature) {
   for (i in seq_along(signature)) {
-    signature[[i]] <- resolve_class_req(signature[[i]])
+    signature[i] <- list(resolve_class_req(signature[[i]]))
   }
   signature
 }
@@ -142,47 +137,36 @@ resolve_class_req <- function(x) {
 
 find_external_class <- function(x) {
   ns <- asNamespace(x$package)
-  if (exists(x$name, envir = ns, inherits = FALSE)) {
-    obj <- get(x$name, envir = ns, inherits = FALSE)
-    if (is_external_class_match(obj, x)) {
-      return(obj)
-    }
-  }
-
-  # Also consider cases where the constructor isn't named the same as the class
-  for (name in ls(ns, all.names = TRUE)) {
-    obj <- get(name, envir = ns, inherits = FALSE)
-    if (is_external_class_match(obj, x)) {
-      return(obj)
-    }
+  obj <- get0(x$name, envir = ns, inherits = FALSE)
+  if (is_external_class_match(obj, x)) {
+    obj
+  } else {
+    NULL
   }
-
-  NULL
 }
 
 is_external_class_match <- function(obj, x) {
   is_class(obj) &&
-    (identical(S7_class_name(obj), x$class_name) ||
-      (identical(obj@name, x$name) &&
-        (is.null(obj@package) || identical(obj@package, x$package))))
+    identical(obj@name, x$name) &&
+    identical(obj@package, x$package)
 }
 
 # Required resolution: errors if the external class can't be resolved (e.g.
 # its package isn't loaded). Used wherever we need the real class: registering
 # or looking up methods, checking property overrides in a subclass, and
 # constructing or validating an instance.
 resolve_external_class_req <- function(x) {
-  prefix <- sprintf("Can't find external class <%s>:\n", x$class_name)
+  prefix <- sprintf("Can't find external class <%s>:", x$class_name)
   if (!requireNamespace(x$package, quietly = TRUE)) {
     stop2(
-      paste0(prefix, sprintf("* Package '%s' is not installed.", x$package)),
+      c(prefix, sprintf("* Package '%s' is not installed.", x$package)),
       call = NULL
     )
   }
 
-  if (!is.null(x$version) && getNamespaceVersion(x$package) < x$version) {
+  if (!dep_version_ok(x)) {
     stop2(
-      paste0(
+      c(
         prefix,
         sprintf(
           "* Package '%s' needs version %s, but only %s is available.",
@@ -197,10 +181,20 @@ resolve_external_class_req <- function(x) {
 
   class <- find_external_class(x)
   if (is.null(class)) {
+    binding <- sprintf(
+      "`%s` with @name '%s' and @package '%s'",
+      x$name,
+      x$name,
+      x$package
+    )
     stop2(
-      paste0(
+      c(
         prefix,
-        sprintf("* Packages '%s' doesn't contain '%s'.", x$package, x$name)
+        sprintf(
+          "* Package '%s' must bind an S7 class to %s.",
+          x$package,
+          binding
+        )
       ),
       call = NULL
     )

R/external-generic.R

@@ -41,7 +41,12 @@ new_external_generic <- function(package, name, dispatch_args, version = NULL) {
 }
 
 as_external_generic <- function(x, env = parent.frame()) {
-  if (is_S7_generic(x)) {
+  if (is_generic_sentinel(x)) {
+    # Sentinels are external generic specs with an extra marker class; keep
+    # this in sync with generic_sentinel().
+    class(x) <- "S7_external_generic"
+    x
+  } else if (is_S7_generic(x)) {
     pkg <- package_name(x)
     new_external_generic(pkg, x@name, x@dispatch_args)
   } else if (is_external_generic(x)) {
@@ -78,41 +83,47 @@ is_external_generic <- function(x) {
 
 external_generic_available <- function(generic) {
   is_external_generic(generic) &&
-    isNamespaceLoaded(generic$package) &&
-    external_generic_version_ok(generic, asNamespace(generic$package))
-}
-
-external_generic_version_ok <- function(generic, ns) {
-  stopifnot(is_external_generic(generic), is.environment(ns))
-
-  is.null(generic$version) || getNamespaceVersion(ns) >= generic$version
+    dep_available(generic)
 }
 
-registrar <- function(deps, generic, signature, method, env) {
+registrar <- function(generic, signature, method, env) {
   # Force all arguments
-  deps
   generic
   signature
   method
   env
 
   function(...) {
-    if (!all(vlapply(deps, dep_available))) {
+    if (!dep_available(generic)) {
       return(invisible())
     }
 
+    sig_deps <- signature_external_deps(signature)
+    if (length(sig_deps)) {
+      if (!all(vlapply(sig_deps, dep_available))) {
+        return(invisible())
+      }
+      for (dep in sig_deps) {
+        resolve_external_class_req(dep)
+      }
+    }
+
     generic_fun <- resolve_generic(generic)
     if (is.null(generic_fun)) {
       return(invisible())
     }
 
-    signature <- resolve_signature(signature)
-    register_method(generic_fun, signature, method, env, package = NULL)
+    register_method(
+      generic_fun,
+      resolve_signature(signature),
+      method,
+      env,
+      package = NULL
+    )
+    invisible()
   }
 }
 
-# Collects all external dependencies (the generic + any external classes)
-# into a single list. Each entry has at minimum `package` + `version`.
 method_deps <- function(generic, signature) {
   c(list(generic), signature_external_deps(signature))
 }