Merge pull request #744 from r-lib/configurable-file-hyperlinks

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: cli
 Title: Helpers for Developing Command Line Interfaces
-Version: 3.6.3.9001
+Version: 3.6.3.9002
 Authors@R: c(
     person("Gábor", "Csárdi", , "csardi.gabor@gmail.com", role = c("aut", "cre")),
     person("Hadley", "Wickham", role = "ctb"),

NEWS.md

@@ -1,7 +1,7 @@
 # cli (development version)
 
-* The format of the URI part of "run", "help" and "vignette" hyperlinks can now
-  be configured via options and env vars (@jennybc, #739).
+* The URI generated for `.file`, `.run`, `.help` and `.vignette` hyperlinks can
+  now be configured via options and env vars (@jennybc, #739, #744).
 
 * `cli_progress_bar()` now accepts `total` = Inf or -Inf which mimics the behavior    of when `total` is NA.
 

R/ansi-hyperlink.R

@@ -74,39 +74,98 @@ make_link_file <- function(txt) {
   linked <- grepl("\007|\033\\\\", txt)
   ret[!linked] <- vcapply(which(!linked), function(i) {
     params <- parse_file_link_params(txt[i])
+    link <- construct_file_link(params)
     style_hyperlink(
       txt[i],
-      paste0(abs_path(params$path), params$suffix),
-      params = params$params
+      link$url,
+      params = link$params
     )
   })
   ret
 }
 
 parse_file_link_params <- function(txt) {
-  if (grepl(":[0-9]+:[0-9]+$", txt)) {
-    # path:line:col
-    path <- sub("^(.*):[0-9]+:[0-9]+$", "\\1", txt)
-    num <- strsplit(sub("^.*:([0-9]+:[0-9]+)$", "\\1", txt), ":", fixed = TRUE)[[1]]
-    if (Sys.getenv("R_CLI_HYPERLINK_STYLE") == "iterm") {
-      list(path = path, params = NULL, suffix = paste0("#", num[1], ":", num[2]))
-    } else {
-      list(path = path, params = c(line = num[1], col = num[2]))
-    }
+  pattern <- "^(?<path>.*?)(?::(?<line>\\d*))?(?::(?<column>\\d*))?$"
+  matches <- re_match(txt, pattern)
+  ret <- as.list(matches)
+  ret[!nzchar(ret)] <- list(NULL)
+  ret
+}
 
-  } else if (grepl(":[0-9]+$", txt)) {
-    # path:line
-    path <- sub("^(.*):[0-9]+$", "\\1", txt)
-    num <- sub("^.*:([0-9]+$)", "\\1", txt)
-    if (Sys.getenv("R_CLI_HYPERLINK_STYLE") == "iterm") {
-      list(path = path, params = NULL, suffix = paste0("#", num))
-    } else {
-      list(path = path, params = c(line = num, col = "1"))
-    }
+construct_file_link <- function(params) {
+  fmt <- get_config_chr("hyperlink_file_url_format")
+
+  if (is.null(fmt)) {
+    return(construct_file_link_OG(params))
+  }
+
+  params$path <- sub("^file://", "", params$path)
+  params$path <- path.expand(params$path)
+
+  looks_absolute <- function(path) {
+    grepl("^/", params$path) || (is_windows() && grepl("^[a-zA-Z]:", params$path))
+  }
+  if (!looks_absolute(params$path)) {
+    params$path <- file.path(getwd(), params$path)
+  }
+  if (!grepl("^/", params$path)) {
+    params$path <- paste0("/", params$path)
+  }
+
+  res <- interpolate_parts(fmt, params)
+  list(url = res)
+}
 
+# the order of operations is very intentional and important:
+# column, then line, then path
+# relates to how interpolate_part() works
+interpolate_parts <- function(fmt, params) {
+  res <- interpolate_part(fmt, "column", params$column)
+  res <- interpolate_part(res, "line", params$line)
+  interpolate_part(res, "path", params$path)
+}
+
+# interpolate a part, if possible
+# if no placeholder for part, this is a no-op
+# if placeholder exists, but no value to fill, remove placeholder (and everything after it!)
+interpolate_part <- function(fmt, part = c("column", "line", "path"), value = NULL) {
+  part <- match.arg(part)
+  re <- glue(
+    "^(?<before>.*)(?<part>\\{<<<part>>>\\})(?<after>.*?)$",
+    .open = "<<<", .close = ">>>"
+  )
+  m <- re_match(fmt, re)
+
+  if (is.na(m$part) || !nzchar(m$part)) {
+    return(fmt)
+  }
+
+  if (is.null(value) || !nzchar(value)) {
+    return(sub("}[^}]*$", "}", m$before))
+  }
+
+  paste0(m$before, value, m$after)
+}
+
+# handle the iterm and RStudio cases, which predated the notion of configuring
+# the file hyperlink format
+construct_file_link_OG <- function(params) {
+  params$path <- abs_path(params$path)
+
+  if (Sys.getenv("R_CLI_HYPERLINK_STYLE") == "iterm") {
+    fmt <- "{path}#{line}:{column}"
+    res <- interpolate_parts(fmt, params)
+    return(list(url = res))
+  }
+
+  # RStudio takes line and col via params
+  loc <- if (is.null(params$line)) {
+    NULL
   } else {
-    list(path = txt, params = NULL)
+    list(line = params$line, col = params$column %||% 1)
   }
+
+  list(url = params$path, params = loc)
 }
 
 abs_path <- function(x) {

R/test.R

@@ -112,11 +112,13 @@ test_that_cli <- function(desc, code,
         cli.hyperlink_help = links,
         cli.hyperlink_run = links,
         cli.hyperlink_vignette = links,
+        cli.hyperlink_file_url_format = NULL,
         cli.hyperlink_run_url_format = NULL,
         cli.hyperlink_help_url_format = NULL,
         cli.hyperlink_vignette_url_format = NULL
       )
       withr::local_envvar(
+        R_CLI_HYPERLINK_FILE_URL_FORMAT = 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_
@@ -139,6 +141,7 @@ local_clean_cli_context <- function(.local_envir = parent.frame()) {
     cli.hyperlink_run = NULL,
     cli.hyperlink_help = NULL,
     cli.hyperlink_vignette = NULL,
+    cli.hyperlink_file_url_format = NULL,
     cli.hyperlink_run_url_format = NULL,
     cli.hyperlink_help_url_format = NULL,
     cli.hyperlink_vignette_url_format = NULL,
@@ -152,6 +155,7 @@ local_clean_cli_context <- function(.local_envir = parent.frame()) {
     R_CLI_HYPERLINK_RUN = NA_character_,
     R_CLI_HYPERLINK_HELP = NA_character_,
     R_CLI_HYPERLINK_VIGNETTE = NA_character_,
+    R_CLI_HYPERLINK_FILE_URL_FORMAT = 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_,

tests/testthat/test-ansi-hyperlink.R

@@ -232,6 +232,7 @@ test_that("unknown hyperlink type", {
 
 test_that("iterm file links", {
   withr::local_envvar(R_CLI_HYPERLINK_STYLE = "iterm")
+  withr::local_envvar(R_CLI_HYPERLINK_FILE_URL_FORMAT = NA_character_)
   withr::local_options(cli.hyperlink = TRUE)
   expect_snapshot({
     cli::cli_text("{.file /path/to/file:10}")
@@ -422,3 +423,185 @@ test_that("get_hyperlink_format() delivers custom format", {
   expect_equal(get_hyperlink_format("help"), "option{topic}")
   expect_equal(get_hyperlink_format("vignette"), "option{vignette}")
 })
+
+test_that("parse_file_link_params(), typical input", {
+  expect_equal(
+    parse_file_link_params("some/path.ext"),
+    list(
+      path = "some/path.ext",
+      line = NULL,
+      column = NULL
+    )
+  )
+  expect_equal(
+    parse_file_link_params("some/path.ext:14"),
+    list(
+      path = "some/path.ext",
+      line = "14",
+      column = NULL
+    )
+  )
+  expect_equal(
+    parse_file_link_params("some/path.ext:14:23"),
+    list(
+      path = "some/path.ext",
+      line = "14",
+      column = "23"
+    )
+  )
+})
+
+test_that("parse_file_link_params(), weird trailing colons", {
+  expect_equal(
+    parse_file_link_params("some/path.ext:"),
+    list(
+      path = "some/path.ext",
+      line = NULL,
+      column = NULL
+    )
+  )
+  expect_equal(
+    parse_file_link_params("some/path.ext::"),
+    list(
+      path = "some/path.ext",
+      line = NULL,
+      column = NULL
+    )
+  )
+  expect_equal(
+    parse_file_link_params("some/path.ext:14:"),
+    list(
+      path = "some/path.ext",
+      line = "14",
+      column = NULL
+    )
+  )
+})
+
+test_that("interpolate_parts(), more or less data in `params`", {
+  fmt <- "whatever/{path}#@${line}^&*{column}"
+  params <- list(path = "some/path.ext", line = "14", column = "23")
+
+  expect_equal(
+    interpolate_parts(fmt, params),
+    "whatever/some/path.ext#@$14^&*23"
+  )
+
+  params <- list(path = "some/path.ext", line = "14", column = NULL)
+  expect_equal(
+    interpolate_parts(fmt, params),
+    "whatever/some/path.ext#@$14"
+  )
+
+  params <- list(path = "some/path.ext", line = NULL, column = NULL)
+  expect_equal(
+    interpolate_parts(fmt, params),
+    "whatever/some/path.ext"
+  )
+})
+
+test_that("interpolate_parts(), format only has `path`", {
+  fmt <- "whatever/{path}"
+  params <- list(path = "some/path.ext", line = "14", column = "23")
+  expect_equal(
+    interpolate_parts(fmt, params),
+    "whatever/some/path.ext"
+  )
+})
+
+test_that("construct_file_link() works with custom format and an absolute path", {
+  withr::local_options(
+    "cli.hyperlink_file_url_format" = "positron://file{path}:{line}:{column}"
+  )
+
+  expect_equal(
+    construct_file_link(list(path = "/absolute/path")),
+    list(url = "positron://file/absolute/path")
+  )
+  expect_equal(
+    construct_file_link(list(path = "/absolute/path", line = "12")),
+    list(url = "positron://file/absolute/path:12")
+  )
+  expect_equal(
+    construct_file_link(list(path = "/absolute/path", line = "12", column = "5")),
+    list(url = "positron://file/absolute/path:12:5")
+  )
+
+  local_mocked_bindings(is_windows = function() TRUE)
+  expect_equal(
+    construct_file_link(list(path = "c:/absolute/path")),
+    list(url = "positron://file/c:/absolute/path")
+  )
+})
+
+test_that("construct_file_link() works with custom format and a relative path", {
+  withr::local_options(
+    "cli.hyperlink_file_url_format" = "positron://file{path}:{line}:{column}"
+  )
+
+  # inspired by test helpers `sanitize_wd()` and `sanitize_home()`, but these
+  # don't prefix the pattern-to-replace with `file://`
+  sanitize_dir <- function(x, what = c("wd", "home")) {
+    what <- match.arg(what)
+    pattern <- switch(what, wd = getwd(), home = path.expand("~"))
+    if (is_windows()) {
+      pattern <- paste0("/", pattern)
+    }
+    replacement <- switch(what, wd = "/working/directory", home = "/my/home")
+    sub(pattern, replacement, x$url, fixed = TRUE)
+  }
+
+  expect_equal(
+    sanitize_dir(construct_file_link(list(path = "relative/path")), what = "wd"),
+    "positron://file/working/directory/relative/path"
+  )
+  expect_equal(
+    sanitize_dir(construct_file_link(list(path = "relative/path:12")), what = "wd"),
+    "positron://file/working/directory/relative/path:12"
+  )
+  expect_equal(
+    sanitize_dir(construct_file_link(list(path = "relative/path:12:5")), what = "wd"),
+    "positron://file/working/directory/relative/path:12:5"
+  )
+
+  expect_equal(
+    sanitize_dir(construct_file_link(list(path = "./relative/path")), what = "wd"),
+    "positron://file/working/directory/./relative/path"
+  )
+  expect_equal(
+    sanitize_dir(construct_file_link(list(path = "./relative/path:12")), what = "wd"),
+    "positron://file/working/directory/./relative/path:12"
+  )
+  expect_equal(
+    sanitize_dir(construct_file_link(list(path = "./relative/path:12:5")), what = "wd"),
+    "positron://file/working/directory/./relative/path:12:5"
+  )
+
+  expect_equal(
+    sanitize_dir(construct_file_link(list(path = "~/relative/path")), what = "home"),
+    "positron://file/my/home/relative/path"
+  )
+  expect_equal(
+    sanitize_dir(construct_file_link(list(path = "~/relative/path:17")), what = "home"),
+    "positron://file/my/home/relative/path:17"
+  )
+  expect_equal(
+    sanitize_dir(construct_file_link(list(path = "~/relative/path:17:22")), what = "home"),
+    "positron://file/my/home/relative/path:17:22"
+  )
+})
+
+test_that("construct_file_link() works with custom format and input starting with 'file://'", {
+  withr::local_options(
+    "cli.hyperlink_file_url_format" = "positron://file{path}:{line}:{column}"
+  )
+
+  expect_equal(
+    construct_file_link(list(path = "file:///absolute/path")),
+    list(url = "positron://file/absolute/path")
+  )
+  expect_equal(
+    construct_file_link(list(path = "file:///absolute/path", line = "12", column = "5")),
+    list(url = "positron://file/absolute/path:12:5")
+  )
+})