Make x-r-whatever-style hyperlinks configurable

R/ansi-hyperlink.R

@@ -130,19 +130,17 @@ make_link_fun <- function(txt) {
   if (!any(todo)) return(txt)
 
   sprt <- ansi_hyperlink_types()$help
-  if (sprt) {
-    scheme <- if (identical(attr(sprt, "type"), "rstudio")) {
-      "ide:help"
-    } else {
-      "x-r-help"
-    }
-
-    txt[todo] <- style_hyperlink(
-      text = txt[todo],
-      url = paste0(scheme, ":", txt[todo])
-    )
+  if (!sprt) {
+    return(txt)
   }
 
+  fmt <- get_hyperlink_format("help")
+  # the format has a placeholder for 'topic'
+  topic <- txt[todo]
+  done <- style_hyperlink(text = topic, url = glue(fmt))
+
+  txt[todo] <- done
+
   txt
 }
 
@@ -151,21 +149,16 @@ make_link_fun <- function(txt) {
 make_link_help <- function(txt) {
   mch <- re_match(txt, "^\\[(?<text>.*)\\]\\((?<url>.*)\\)$")
   text <- ifelse(is.na(mch$text), txt, mch$text)
-  url <- ifelse(is.na(mch$url), txt, mch$url)
+  topic <- ifelse(is.na(mch$url), txt, mch$url)
 
   sprt <- ansi_hyperlink_types()$help
-  if (sprt) {
-    scheme <- if (identical(attr(sprt, "type"), "rstudio")) {
-      "ide:help"
-    } else {
-      "x-r-help"
-    }
-    style_hyperlink(text = text, url = paste0(scheme, ":", url))
-
-  } else {
-    url2 <- vcapply(url, function(url1) format_inline("{.fun ?{url1}}"))
-    ifelse(text == url, url2, paste0(text, " (", url2, ")"))
+  if (!sprt) {
+    topic2 <- vcapply(topic, function(x) format_inline("{.fun ?{x}}"))
+    return(ifelse(text == topic, topic2, paste0(text, " (", topic2, ")")))
   }
+
+  fmt <- get_hyperlink_format("help")
+  style_hyperlink(text = text, url = glue(fmt))
 }
 
 # -- {.href} --------------------------------------------------------------
@@ -193,42 +186,32 @@ make_link_href <- function(txt) {
 make_link_run <- function(txt) {
   mch <- re_match(txt, "^\\[(?<text>.*)\\]\\((?<url>.*)\\)$")
   text <- ifelse(is.na(mch$text), txt, mch$text)
-  url <- ifelse(is.na(mch$url), txt, mch$url)
+  code <- ifelse(is.na(mch$url), txt, mch$url)
 
   sprt <- ansi_hyperlink_types()$run
-  if (sprt) {
-    scheme <- if (identical(attr(sprt, "type"), "rstudio")) {
-      "ide:run"
-    } else {
-      "x-r-run"
-    }
-    style_hyperlink(text = text, url = paste0(scheme, ":", url))
-
-  } else {
-    vcapply(text, function(url1) format_inline("{.code {url1}}"))
+  if (!sprt) {
+    return(vcapply(text, function(code1) format_inline("{.code {code1}}")))
   }
+
+  fmt <- get_hyperlink_format("run")
+  style_hyperlink(text = text, url = glue(fmt))
 }
 
 # -- {.topic} -------------------------------------------------------------
 
 make_link_topic <- function(txt) {
   mch <- re_match(txt, "^\\[(?<text>.*)\\]\\((?<url>.*)\\)$")
   text <- ifelse(is.na(mch$text), txt, mch$text)
-  url <- ifelse(is.na(mch$url), txt, mch$url)
+  topic <- ifelse(is.na(mch$url), txt, mch$url)
 
   sprt <- ansi_hyperlink_types()$help
-  if (sprt) {
-    scheme <- if (identical(attr(sprt, "type"), "rstudio")) {
-      "ide:help"
-    } else {
-      "x-r-help"
-    }
-    style_hyperlink(text = text, url = paste0(scheme, ":", url))
-
-  } else {
-    url2 <- vcapply(url, function(url1) format_inline("{.code ?{url1}}"))
-    ifelse(text == url, url2, paste0(text, " (", url2, ")"))
+  if (!sprt) {
+    topic2 <- vcapply(topic, function(x) format_inline("{.code ?{x}}"))
+    return(ifelse(text == topic, topic2, paste0(text, " (", topic2, ")")))
   }
+
+  fmt <- get_hyperlink_format("help")
+  style_hyperlink(text = text, url = glue(fmt))
 }
 
 # -- {.url} ---------------------------------------------------------------
@@ -245,21 +228,16 @@ make_link_url <- function(txt) {
 make_link_vignette <- function(txt) {
   mch <- re_match(txt, "^\\[(?<text>.*)\\]\\((?<url>.*)\\)$")
   text <- ifelse(is.na(mch$text), txt, mch$text)
-  url <- ifelse(is.na(mch$url), txt, mch$url)
+  vignette <- ifelse(is.na(mch$url), txt, mch$url)
 
   sprt <- ansi_hyperlink_types()$vignette
-  if (sprt) {
-    scheme <- if (identical(attr(sprt, "type"), "rstudio")) {
-      "ide:vignette"
-    } else {
-      "x-r-vignette"
-    }
-    style_hyperlink(text = text, url = paste0(scheme, ":", url))
-
-  } else {
-    url2 <- vcapply(url, function(url1) format_inline("{.code vignette({url1})}"))
-    ifelse(text == url, url2, paste0(text, " (", url2, ")"))
+  if (!sprt) {
+    vignette2 <- vcapply(vignette, function(x) format_inline("{.code vignette({x})}"))
+    return(ifelse(text == vignette, vignette2, paste0(text, " (", vignette2, ")")))
   }
+
+  fmt <- get_hyperlink_format("vignette")
+  style_hyperlink(text = text, url = glue(fmt))
 }
 
 #' Terminal Hyperlinks
@@ -426,3 +404,43 @@ ansi_hyperlink_types <- function() {
     )
   }
 }
+
+get_hyperlink_format <- function(type = c("run", "help", "vignette")) {
+  type <- match.arg(type)
+
+  key <- glue("hyperlink_{type}_url_format")
+  sprt <- ansi_hyperlink_types()[[type]]
+
+  custom_fmt <- get_config_chr(key)
+  if (is.null(custom_fmt)) {
+    if (identical(attr(sprt, "type"), "rstudio")) {
+      fmt_type <- "rstudio"
+    } else {
+      fmt_type <- "standard"
+    }
+  } else {
+    fmt_type <- "custom"
+  }
+
+  variable <- c(run = "code", help = "topic", vignette = "vignette")
+  fmt <- switch(
+    fmt_type,
+    custom = custom_fmt,
+    rstudio = glue("ide:{type}:{{{variable[type]}}}"),
+    standard = glue("x-r-{type}:{{{variable[type]}}}")
+  )
+  fmt
+}
+
+get_config_chr <- function(x, default = NULL) {
+  opt <- getOption(paste0("cli.", tolower(x)))
+  if (!is.null(opt)) {
+    stopifnot(is_string(opt))
+    return(opt)
+  }
+
+  env <- Sys.getenv(paste0("R_CLI_", toupper(x)), NA_character_)
+  if (!is.na(env)) return(env)
+
+  default
+}

R/test.R

@@ -112,6 +112,14 @@ test_that_cli <- function(desc, code,
         cli.hyperlink_help = links,
         cli.hyperlink_run = links,
         cli.hyperlink_vignette = links,
+        cli.hyperlink_run_url_format = NULL,
+        cli.hyperlink_help_url_format = NULL,
+        cli.hyperlink_vignette_url_format = NULL
+      )
+      withr::local_envvar(
+        R_CLI_HYPERLINK_RUN_URL_FORMAT = NA_character_,
+        R_CLI_HYPERLINK_HELP_URL_FORMAT = NA_character_,
+        R_CLI_HYPERLINK_VIGNETTE_URL_FORMAT = NA_character_
       )
       code_
     }, c(conf, list(code_ = code)))
@@ -131,13 +139,22 @@ local_clean_cli_context <- function(.local_envir = parent.frame()) {
     cli.hyperlink_run = NULL,
     cli.hyperlink_help = NULL,
     cli.hyperlink_vignette = NULL,
+    cli.hyperlink_run_url_format = NULL,
+    cli.hyperlink_help_url_format = NULL,
+    cli.hyperlink_vignette_url_format = NULL,
     cli.num_colors = NULL,
     cli.palette = NULL,
     crayon.enabled = NULL
   )
   withr::local_envvar(
     .local_envir = .local_envir,
     R_CLI_HYPERLINKS = NA_character_,
+    R_CLI_HYPERLINK_RUN = NA_character_,
+    R_CLI_HYPERLINK_HELP = NA_character_,
+    R_CLI_HYPERLINK_VIGNETTE = NA_character_,
+    R_CLI_HYPERLINK_RUN_URL_FORMAT = NA_character_,
+    R_CLI_HYPERLINK_HELP_URL_FORMAT = NA_character_,
+    R_CLI_HYPERLINK_VIGNETTE_URL_FORMAT = NA_character_,
     RSTUDIO_CLI_HYPERLINKS = NA_character_,
     R_CLI_NUM_COLORS = NA_character_,
     NO_COLOR = NA_character_,

tests/testthat/_snaps/links.md

@@ -819,6 +819,13 @@
     Message
       `pkg::func()`
 
+# .fun with custom format [plain-all]
+
+    Code
+      cli_text("{.fun pkg::func}")
+    Message
+      `]8;;aaa-pkg::func-zzzpkg::func]8;;()`
+
 # {.help} [plain-none]
 
     Code
@@ -857,6 +864,13 @@
     Message
       ]8;;x-r-help:pkg::fun1pkg::fun1]8;;, ]8;;x-r-help:pkg::fun2pkg::fun2]8;;, and ]8;;x-r-help:pkg::fun3pkg::fun3]8;;
 
+# .help with custom format [plain-all]
+
+    Code
+      cli_text("{.help pkg::fun}")
+    Message
+      ]8;;aaa-pkg::fun-zzzpkg::fun]8;;
+
 # {.href} [plain-none]
 
     Code
@@ -943,6 +957,13 @@
     Message
       ]8;;x-r-run:pkg::fun1()pkg::fun1()]8;;, ]8;;x-r-run:pkg::fun2()pkg::fun2()]8;;, and ]8;;x-r-run:pkg::fun3()pkg::fun3()]8;;
 
+# .run with custom format [plain-all]
+
+    Code
+      cli_text("{.run devtools::document()}")
+    Message
+      ]8;;aaa-devtools::document()-zzzdevtools::document()]8;;
+
 # {.topic} [plain-none]
 
     Code
@@ -981,6 +1002,13 @@
     Message
       ]8;;x-r-help:pkg::topic1pkg::topic1]8;;, ]8;;x-r-help:pkg::topic2pkg::topic2]8;;, and ]8;;x-r-help:pkg::topic3pkg::topic3]8;;
 
+# .topic with custom format [plain-all]
+
+    Code
+      cli_text("{.topic pkg::fun}")
+    Message
+      ]8;;aaa-pkg::fun-zzzpkg::fun]8;;
+
 # {.url} [plain-none]
 
     Code
@@ -1092,3 +1120,10 @@
     Message
       ]8;;x-r-vignette:pkg::topic1pkg::topic1]8;;, ]8;;x-r-vignette:pkg::topic2pkg::topic2]8;;, and ]8;;x-r-vignette:pkg::topic3pkg::topic3]8;;
 
+# .vignette with custom format [plain-all]
+
+    Code
+      cli_text("{.vignette pkgdown::accessibility}")
+    Message
+      ]8;;aaa-pkgdown::accessibility-zzzpkgdown::accessibility]8;;
+

tests/testthat/test-ansi-hyperlink.R

@@ -240,6 +240,7 @@ test_that("iterm file links", {
 })
 
 test_that("rstudio links", {
+  local_clean_cli_context()
   withr::local_envvar(
     RSTUDIO = "1",
     RSTUDIO_SESSION_PID = Sys.getpid(),
@@ -370,3 +371,54 @@ test_that("ansi_hyperlink_types", {
   )
   expect_true(ansi_hyperlink_types()[["run"]])
 })
+
+test_that("get_config_chr() consults option, env var, then its default", {
+  local_clean_cli_context()
+
+  key <- "hyperlink_TYPE_url_format"
+
+  expect_null(get_config_chr(key))
+
+  withr::local_envvar(R_CLI_HYPERLINK_TYPE_URL_FORMAT = "envvar")
+  expect_equal(get_config_chr(key), "envvar")
+
+  withr::local_options(cli.hyperlink_type_url_format = "option")
+  expect_equal(get_config_chr(key), "option")
+})
+
+test_that("get_config_chr() errors if option is not NULL or string", {
+  withr::local_options(cli.something = FALSE)
+
+  expect_error(get_config_chr("something"), "is_string")
+})
+
+test_that("get_hyperlink_format() delivers custom format", {
+  local_clean_cli_context()
+
+  withr::local_options(
+    cli.hyperlink_run = TRUE,
+    cli.hyperlink_help = TRUE,
+    cli.hyperlink_vignette = TRUE
+  )
+
+  # env var is consulted after option, so start with env var
+  withr::local_envvar(
+    R_CLI_HYPERLINK_RUN_URL_FORMAT = "envvar{code}",
+    R_CLI_HYPERLINK_HELP_URL_FORMAT = "envvar{topic}",
+    R_CLI_HYPERLINK_VIGNETTE_URL_FORMAT = "envvar{vignette}"
+  )
+
+  expect_equal(get_hyperlink_format("run"), "envvar{code}")
+  expect_equal(get_hyperlink_format("help"), "envvar{topic}")
+  expect_equal(get_hyperlink_format("vignette"), "envvar{vignette}")
+
+  withr::local_options(
+    cli.hyperlink_run_url_format = "option{code}",
+    cli.hyperlink_help_url_format = "option{topic}",
+    cli.hyperlink_vignette_url_format = "option{vignette}"
+  )
+
+  expect_equal(get_hyperlink_format("run"), "option{code}")
+  expect_equal(get_hyperlink_format("help"), "option{topic}")
+  expect_equal(get_hyperlink_format("vignette"), "option{vignette}")
+})