Merge pull request #1199 from lionel-/pnf-error

Add restart for package not found errors

Author: lionel-

NAMESPACE

@@ -36,6 +36,7 @@ S3method(c,rlang_envs)
 S3method(cnd_body,default)
 S3method(cnd_footer,default)
 S3method(cnd_header,default)
+S3method(cnd_header,rlib_error_package_not_found)
 S3method(conditionMessage,rlang_error)
 S3method(format,rlang_error)
 S3method(format,rlang_trace)

NEWS.md

@@ -1,5 +1,16 @@
 # rlang (development version)
 
+* `check_installed()` now consults the
+  `rlib_restart_package_not_found` global option to determine whether
+  to prompt users to install packages. This also disables the restart
+  mechanism (see below).
+
+* `check_installed()` now signals errors of class
+  `rlib_error_package_not_found` with a
+  `rlib_restart_package_not_found` restart. This allows calling
+  handlers to install the required packages and restart the check
+  (#1150).
+
 * New `rlib_bytes` class imported from the bench package (#1117).
   It prints and parses human-friendly sizes.
 

R/session.R

@@ -16,6 +16,10 @@
 #'  interactive or if the user chooses not to install the packages,
 #'  the current evaluation is aborted.
 #'
+#'  You can disable the prompt by setting the
+#'  `rlib_restart_package_not_found` global option to `FALSE`. In that
+#'  case, missing packages always cause an error.
+#'
 #' @param pkg The package names.
 #' @param reason Optional string indicating why is `pkg` needed.
 #'   Appears in error messages (if non-interactive) and user prompts
@@ -27,6 +31,24 @@
 #'   provided in `pkg` are installed, `FALSE`
 #'   otherwise. `check_installed()` either doesn't return or returns
 #'   `NULL`.
+#'
+#' @section Handling package not found errors:
+#' `check_installed()` signals error conditions of class
+#' `rlib_error_package_not_found`. The error includes `pkg` and
+#' `version` fields. They are vectorised and may include several
+#' packages.
+#'
+#' The error is signalled with a `rlib_restart_package_not_found`
+#' restart on the stack to allow handlers to install the required
+#' packages. To do so, add a [calling handler][withCallingHandlers]
+#' for `rlib_error_package_not_found`, install the required packages,
+#' and invoke the restart without arguments. This restarts the check
+#' from scratch.
+#'
+#' The condition is not signalled in non-interactive sessions, in the
+#' restarting case, or if the `rlib_restart_package_not_found` user
+#' option is set to `FALSE`.
+#'
 #' @export
 #' @examples
 #' is_installed("utils")
@@ -35,6 +57,12 @@
 is_installed <- function(pkg, ..., version = NULL) {
   check_dots_empty0(...)
 
+  # Internal mechanism for unit tests
+  hook <- peek_option("rlang:::is_installed_hook")
+  if (is_function(hook)) {
+    return(all(hook(pkg, version)))
+  }
+
   if (!all(map_lgl(pkg, function(x) is_true(requireNamespace(x, quietly = TRUE))))) {
     return(FALSE)
   }
@@ -71,50 +99,48 @@ check_installed <- function(pkg,
     needs_install <- !map2_lgl(pkg, version, function(p, v) is_installed(p, version = v))
   }
 
-  if (!any(needs_install)) {
+  missing_pkgs <- pkg[needs_install]
+  missing_vers <- version[needs_install]
+
+  if (!length(missing_pkgs)) {
     return(invisible(NULL))
   }
 
-  missing_pkgs <- pkg[needs_install]
-  missing_pkgs <- chr_quoted(missing_pkgs)
+  cnd <- new_error_package_not_found(
+    missing_pkgs,
+    missing_vers,
+    reason = reason
+  )
 
-  if (!is_null(version)) {
-    missing_vers <- version[needs_install]
-    missing_pkgs <- map2_chr(missing_pkgs, missing_vers, function(p, v) {
-      if (is_na(v)) {
-        p
-      } else {
-        paste0(p, " (>= ", v, ")")
-      }
-    })
+  restart <- peek_option("rlib_restart_package_not_found") %||% TRUE
+  if (!is_bool(restart)) {
+    abort("`rlib_restart_package_not_found` must be a logical value.")
   }
 
-  missing_pkgs_enum <- chr_enumerate(missing_pkgs, final = "and")
+  if (!is_interactive() || !restart) {
+    abort(cnd_header(cnd))
+  }
 
-  n <- length(missing_pkgs)
-  info <- pluralise(
-    n,
-    paste0("The package ", missing_pkgs_enum, " is required"),
-    paste0("The packages ", missing_pkgs_enum, " are required")
-  )
-  if (is_null(reason)) {
-    info <- paste0(info, ".")
-  } else {
-    info <- paste(info, reason)
+  if (signal_package_not_found(cnd)) {
+    # A calling handler asked for a restart. Disable restarts and try
+    # again.
+    return(with_options(
+      "rlib_restart_package_not_found" = FALSE,
+      check_installed(pkg, reason, version = version)
+    ))
   }
 
+  header <- cnd_header(cnd)
+
+  n <- length(missing_pkgs)
   question <- pluralise(
     n,
     "Would you like to install it?",
     "Would you like to install them?"
   )
 
-  if (!is_interactive()) {
-    abort(info)
-  }
-
   cat(paste_line(
-    paste0(info(), " ", info),
+    paste0(info(), " ", header),
     paste0(cross(), " ", question),
     .trailing = TRUE
   ))
@@ -128,3 +154,71 @@ check_installed <- function(pkg,
     utils::install.packages(missing_pkgs)
   }
 }
+
+new_error_package_not_found <- function(pkg,
+                                        version = NULL,
+                                        ...,
+                                        reason = NULL,
+                                        class = NULL) {
+  if (!is_character(pkg)) {
+    abort("`pkg` must be character vector.")
+  }
+  if (!length(pkg)) {
+    abort("`pkg` must contain at least one package.")
+  }
+  if (!is_null(version) && !is_character(version, n = length(pkg))) {
+    abort("`version` must be a character vector as long as `pkg`.")
+  }
+
+  error_cnd(
+    class = c(class, "rlib_error_package_not_found"),
+    pkg = pkg,
+    version = version,
+    reason = reason,
+    ...
+  )
+}
+
+#' @export
+cnd_header.rlib_error_package_not_found <- function(cnd, ...) {
+  pkg <- cnd$pkg
+  version <- cnd$version
+  reason <- cnd$reason
+  n <- length(pkg)
+
+  pkg_enum <- chr_quoted(cnd$pkg)
+
+  if (!is_null(version)) {
+    pkg_enum <- map2_chr(pkg_enum, version, function(p, v) {
+      if (is_na(v)) {
+        p
+      } else {
+        paste0(p, " (>= ", v, ")")
+      }
+    })
+  }
+
+  pkg_enum <- chr_enumerate(pkg_enum, final = "and")
+
+  info <- pluralise(
+    n,
+    paste0("The package ", pkg_enum, " is required"),
+    paste0("The packages ", pkg_enum, " are required")
+  )
+
+  if (is_null(reason)) {
+    paste0(info, ".")
+  } else {
+    paste(info, reason)
+  }
+}
+
+signal_package_not_found <- function(cnd) {
+  withRestarts({
+    signalCondition(cnd)
+    FALSE
+  },
+  rlib_restart_package_not_found = function() {
+    TRUE
+  })
+}

man/is_installed.Rd

@@ -36,3 +36,71 @@ test_that("check_installed() checks minimal versions", {
     (expect_error(check_installed(c("_foo", "_bar"), "to proceed.", version = c("1.0", "2.0"))))
   })
 })
+
+test_that("pnf error is validated", {
+  expect_pnf <- function(out, pkg, ver) {
+    expect_s3_class(out, "rlib_error_package_not_found")
+    expect_equal(out$pkg, pkg)
+    expect_equal(out$version, ver)
+  }
+  expect_pnf(new_error_package_not_found("foo"), "foo", NULL)
+  expect_pnf(new_error_package_not_found("foo", "1.0"), "foo", "1.0")
+  expect_pnf(new_error_package_not_found(c("foo", "bar"), c("1.0", "1.0")), c("foo", "bar"), c("1.0", "1.0"))
+
+  expect_error(
+    new_error_package_not_found(chr()),
+    "at least one package"
+  )
+  expect_error(
+    new_error_package_not_found(c("foo", "bar"), "1.0"),
+    "as long as `pkg`"
+  )
+})
+
+test_that("can handle check-installed", {
+  local_interactive()
+
+  # Override `is_installed()` results
+  override <- NULL
+  is_installed_hook <- function(pkg, ver) {
+    if (is_bool(override)) {
+      rep_along(pkg, override)
+    } else {
+      with_options(
+        "rlang:::is_installed_hook" = NULL,
+        is_installed(pkg, version = ver)
+      )
+    }
+  }
+  local_options("rlang:::is_installed_hook" = is_installed_hook)
+
+  test_env <- current_env()
+  handle <- function(value, frame, expr) {
+    withCallingHandlers(
+      rlib_error_package_not_found = function(cnd) {
+        override <<- value
+        invokeRestart("rlib_restart_package_not_found")
+      },
+      expr
+    )
+  }
+
+  override <- NULL
+  expect_no_error(
+    handle(
+      TRUE,
+      test_env,
+      check_installed(c("foo", "bar"), version = c("1.0", "2.0"))
+    )
+  )
+
+  override <- NULL
+  expect_error(
+    handle(
+      FALSE,
+      test_env,
+      check_installed(c("foo", "bar"), version = c("1.0", "2.0"))
+    ),
+    "are required"
+  )
+})