Introduce cli_menu() and friends

R/Gargle-class.R

@@ -273,14 +273,15 @@ encourage_httpuv <- function() {
   if (!is_interactive() || isTRUE(is_installed("httpuv"))) {
     return(invisible())
   }
-  local_gargle_verbosity("info")
-  gargle_info(c(
-    "The {.pkg httpuv} package enables a nicer Google auth experience, \\
-     in many cases.",
-    "It doesn't seem to be installed.",
-    "Would you like to install it now?"
-  ))
-  if (utils::menu(c("Yes", "No")) == 1) {
+  choice <- cli_menu(
+    c(
+      "The {.pkg httpuv} package enables a nicer Google auth experience, in many cases.",
+      "It doesn't seem to be installed."
+    ),
+    "Would you like to install it now?",
+    choices = c("Yes", "No")
+  )
+  if (choice == 1) {
     utils::install.packages("httpuv")
   }
   invisible()

R/oauth-cache.R

@@ -62,11 +62,13 @@ cache_allowed <- function(path) {
     return(FALSE)
   }
 
-  local_gargle_verbosity("info")
-  gargle_info("
-    Is it OK to cache OAuth access credentials in the folder \\
-    {.path {path}} between R sessions?")
-  utils::menu(c("Yes", "No")) == 1
+  choice <- cli_menu(
+    header = character(),
+    prompt = "Is it OK to cache OAuth access credentials in the folder \\
+              {.path {path}} between R sessions?",
+    choices = c("Yes", "No")
+  )
+  choice == 1
 }
 
 cache_create <- function(path) {
@@ -315,13 +317,14 @@ token_match <- function(candidate, existing, package = "gargle") {
 
   # we need user to OK our discovery or pick from multiple emails
   emails <- extract_email(existing)
-  local_gargle_verbosity("info")
-  gargle_info(c(
+  choice <- cli_menu(
     "The {.pkg {package}} package is requesting access to your Google account.",
-    "Select a pre-authorised account or enter '0' to obtain a new token.",
-    "Press Esc/Ctrl + C to cancel."
-  ))
-  choice <- utils::menu(emails)
+    c(
+      "Select a pre-authorised account or enter '0' to obtain a new token.",
+      "Press Esc/Ctrl + C to cancel."
+    ),
+    choices = emails
+  )
 
   if (choice == 0) {
     NULL

R/utils-ui.R

@@ -271,3 +271,89 @@ compute_n_show <- function(n, n_show_nominal = 5, n_fudge = 2) {
     n
   }
 }
+
+# menu(), but based on readline() + cli and mockable ---------------------------
+# https://github.com/r-lib/cli/issues/228
+# https://github.com/rstudio/rsconnect/blob/main/R/utils-cli.R
+
+cli_menu <- function(header,
+                     prompt,
+                     choices,
+                     not_interactive = choices,
+                     exit = integer(),
+                     .envir = caller_env(),
+                     error_call = caller_env()) {
+  if (!is_interactive()) {
+    cli::cli_abort(
+      c(header, not_interactive),
+      .envir = .envir,
+      call = error_call
+    )
+  }
+
+  choices <- paste0(cli::style_bold(seq_along(choices)), ": ", choices)
+  cli::cli_inform(
+    c(header, prompt, choices),
+    .envir = .envir
+  )
+
+  # guard against invalid mocked input
+  local_input <- getOption("cli_input", character())
+
+  repeat {
+    selected <- cli_readline("Selection: ")
+    if (selected %in% c("0", seq_along(choices))) {
+      break
+    }
+    if (length(local_input) > 0) {
+      cli::cli_abort(
+        c(x = "Internal error: mocked input is invalid."),
+        .envir = .envir,
+        call = error_call
+      )
+    }
+    cli::cli_inform(
+      "Enter a number between 1 and {length(choices)}, or enter 0 to exit."
+    )
+  }
+
+  selected <- as.integer(selected)
+  if (selected %in% c(0, exit)) {
+    if (is_testing()) {
+      cli::cli_abort("Exiting...", call = NULL)
+    } else {
+      cli::cli_alert_danger("Exiting...")
+      # simulate user pressing Ctrl + C
+      invokeRestart("abort")
+    }
+  }
+
+  selected
+}
+
+cli_readline <- function(prompt) {
+  local_input <- getOption("cli_input", character())
+
+  # not convinced that we need to plan for multiple mocked inputs, but leaving
+  # this feature in for now
+  if (length(local_input) > 0) {
+    input <- local_input[[1]]
+    cli::cli_inform(paste0(prompt, input))
+    options(local_input = local_input[-1])
+    input
+  } else {
+    readline(prompt)
+  }
+}
+
+local_user_input <- function(x, env = caller_env()) {
+  withr::local_options(
+    rlang_interactive = TRUE,
+    cli_input = as.character(x),
+    .local_envir = env
+  )
+}
+
+is_testing <- function() {
+  identical(Sys.getenv("TESTTHAT"), "true")
+}

tests/testthat/_snaps/utils-ui.md

@@ -146,3 +146,96 @@
       * g
       * h
 
+# cli_menu() basic usage
+
+    Code
+      cli_menu_with_mock(1)
+    Message
+      Found multiple thingies.
+      Which one do you want to use?
+      1: label a
+      2: label b
+      3: label c
+      Selection: 1
+    Output
+      [1] 1
+
+# cli_menu() invalid selection
+
+    Code
+      cli_menu_with_mock("nope")
+    Message
+      Found multiple thingies.
+      Which one do you want to use?
+      1: label a
+      2: label b
+      3: label c
+      Selection: nope
+    Condition
+      Error in `cli_menu_with_mock()`:
+      x Internal error: mocked input is invalid.
+
+# cli_menu(), request exit via 0
+
+    Code
+      cli_menu_with_mock(0)
+    Message
+      Found multiple thingies.
+      Which one do you want to use?
+      1: label a
+      2: label b
+      3: label c
+      Selection: 0
+    Condition
+      Error:
+      ! Exiting...
+
+# cli_menu(exit =) works
+
+    Code
+      cli_menu_with_mock(1)
+    Message
+      Hey we need to talk.
+      What do you want to do?
+      1: Give up
+      2: Some other thing
+      Selection: 1
+    Condition
+      Error:
+      ! Exiting...
+
+---
+
+    Code
+      cli_menu_with_mock(2)
+    Message
+      Hey we need to talk.
+      What do you want to do?
+      1: Give up
+      2: Some other thing
+      Selection: 2
+    Output
+      [1] 2
+
+# cli_menu() inline markup and environment passing
+
+    Code
+      cli_menu_with_mock(1)
+    Message
+      Hey we need to "talk".
+      What do you want to "do"?
+      1: Send email to '[email protected]'
+      2: Install the nifty package
+      Selection: 1
+    Output
+      [1] 1
+
+# cli_menu() not_interactive, many strings, chained error
+
+    Code
+      wrapper_fun()
+    Condition
+      Error in `wrapper_fun()`:
+      ! Multiple things found.
+      i Use `thingy` to specify one of "thing 1", "thing 2", and "thing 3".
+

tests/testthat/test-Gargle-class.R

@@ -25,7 +25,7 @@ test_that("email can be set in option", {
 })
 
 test_that("Attempt to initiate OAuth2 flow fails if non-interactive", {
-  rlang::local_interactive(FALSE)
+  local_interactive(FALSE)
   expect_error(gargle2.0_token(cache = FALSE), "requires an interactive session")
 })
 

tests/testthat/test-oauth-cache.R

@@ -86,6 +86,7 @@ test_that("default is to consult and set the oauth cache option", {
 # cache_allowed() --------------------------------------------------------------
 
 test_that("cache_allowed() returns false when non-interactive (or testing)", {
+  local_interactive(FALSE)
   expect_false(cache_allowed(getwd()))
 })
 

tests/testthat/test-utils-ui.R

@@ -58,3 +58,94 @@ test_that("bulletize() works", {
   expect_snapshot(cli::cli_bullets(bulletize(letters[1:6], n_fudge = 0)))
   expect_snapshot(cli::cli_bullets(bulletize(letters[1:8], n_fudge = 3)))
 })
+
+# menu(), but based on readline() + cli and mockable ---------------------------
+
+test_that("cli_menu() basic usage", {
+  cli_menu_with_mock <- function(x) {
+    local_user_input(x)
+    cli_menu(
+      "Found multiple thingies.",
+      "Which one do you want to use?",
+      glue("label {head(letters, 3)}")
+    )
+  }
+
+  expect_snapshot(cli_menu_with_mock(1))
+})
+
+test_that("cli_menu() invalid selection", {
+  cli_menu_with_mock <- function(x) {
+    local_user_input(x)
+    cli_menu(
+      "Found multiple thingies.",
+      "Which one do you want to use?",
+      glue("label {head(letters, 3)}")
+    )
+  }
+
+  expect_snapshot(cli_menu_with_mock("nope"), error = TRUE)
+})
+
+test_that("cli_menu(), request exit via 0", {
+  cli_menu_with_mock <- function(x) {
+    local_user_input(x)
+    cli_menu(
+      "Found multiple thingies.",
+      "Which one do you want to use?",
+      glue("label {head(letters, 3)}")
+    )
+  }
+
+  expect_snapshot(error = TRUE, cli_menu_with_mock(0))
+})
+
+test_that("cli_menu(exit =) works", {
+  cli_menu_with_mock <- function(x) {
+    local_user_input(x)
+    cli_menu(
+      header = "Hey we need to talk.",
+      prompt = "What do you want to do?",
+      choices = c(
+        "Give up",
+        "Some other thing"
+      ),
+      exit = 1
+    )
+  }
+
+  expect_snapshot(error = TRUE, cli_menu_with_mock(1))
+  expect_snapshot(cli_menu_with_mock(2))
+})
+
+test_that("cli_menu() inline markup and environment passing", {
+  cli_menu_with_mock <- function(x) {
+    local_user_input(x)
+    verb <- "talk"
+    action <- "do"
+    pkg_name <- "nifty"
+    cli_menu(
+      header = "Hey we need to {.str {verb}}.",
+      prompt = "What do you want to {.str {action}}?",
+      choices = c(
+        "Send email to {.email [email protected]}",
+        "Install the {.pkg {pkg_name}} package"
+      )
+    )
+  }
+  expect_snapshot(cli_menu_with_mock(1))
+})
+
+test_that("cli_menu() not_interactive, many strings, chained error", {
+  wrapper_fun <- function() {
+    local_interactive(FALSE)
+    things <- glue("thing {1:3}")
+    cli_menu(
+      header = "Multiple things found.",
+      prompt = "Which one do you want to use?",
+      choices = things,
+      not_interactive = c(i = "Use {.arg thingy} to specify one of {.str {things}}.")
+    )
+  }
+  expect_snapshot(wrapper_fun(), error = TRUE)
+})