Extended hyperlink support

NAMESPACE

@@ -37,6 +37,7 @@ export(ansi_has_hyperlink_support)
 export(ansi_hide_cursor)
 export(ansi_html)
 export(ansi_html_style)
+export(ansi_hyperlink_types)
 export(ansi_nchar)
 export(ansi_nzchar)
 export(ansi_palette_show)

R/ansi-hyperlink.R

@@ -1,4 +1,255 @@
 
+#' Auto-linking existing styles
+#'
+#' They keep formatting. It is not possible to use a different link text
+#' with them. We could add link text support, but theming is applied to the
+#' result of these tags, and it would look weird for link text. (I.e. if
+#' there is link text you don't want to append `()` to the function name,
+#' etc.)
+#'
+#' N | Goal                                        | Input                           |Links to (link text is always the verbatim content, styled)
+#' --|---------------------------------------------|---------------------------------|---------------------------------------------------------------------
+#' 1 | auto-link emails                            | `{.email [email protected]}`          | `mailto:[email protected]`
+#' 2 | auto-link file                              | `{.file path/file}`             | `file:///abs/path/dile`
+#' 3 | auto-link file with line and column numbers | `{.file /abs/path:line:col}`    | `file:///abs/path:line:col`, `params = list(line = line, col = col)`
+#' 4 | auto-link function                          | `{.fun pkg::fun}`               | `x-r-help:pkg::fun`
+#' 5 | mention function w/o package                | `{.fun fun}`                    | no link is created for this form
+#' 6 | auto-link url                               | `{.url url}`                    | `url`
+#'
+#' ## New styles to create links
+#'
+#' These all have link text support, via the `[text](link)` markdown syntax.
+#'
+#' N | Goal                                        | Input                           | Link text         | Links to                 | Non-link form
+#' --|---------------------------------------------|---------------------------------|-------------------|--------------------------|------------------------------------
+#' 7 | link qualified function name to help        | `{.help pkg::fun}`              | `{.fun pkg::fun}` | `x-r-help:pkg::fun`      | `{.fun ?pkg::fun}`
+#' 8 | link to function with link text             | `{.help [text](pkg::fun)}`      | `text`            | `x-r-help:pkg::fun`      | `text ({.fun pkg::fun})`
+#' 9 | link to topic                               | `{.topic pkg::topic}`           | `pkg::topic`      | `x-r-help:pkg::topic`    | `{.code pkg::topic}`
+#' 10| link to topic with link text                | `{.topic [text](pkg::topic)}`   | `text`            | `x-r-help:pkg::topic`    | `text ({.code pkg::topic})`
+#' 11| link url                                    | `{.href url}`                   | `{.url url}`      | `url`                    | `{.url url}`
+#' 12| link url with link text                     | `{.href [text](url)}`           | `text`            | `url`                    | `text ({.url url})`
+#' 13| link running expr                           | `{.run expr}`                   | `{.code expr}`    | `x-r-run:expr`           | `{.code expr}`
+#' 14| link running expr, show code                | `{.run [code](expr)}`           | `{.code code}`    | `x-r-run:expr`           | `{.code expr}`
+#' 15| link to vignette                            | `{.vignette pkg::name}`         | `pkg::name`       | `x-r-vignette:pkg::name` | `{.code vignette(pkg::name)}`
+#' 16| link to vignette with link text             | `{.vignette [text](pkg::name)}` | `text`            | `x-r-vignette:pkg::name` | `text ({.code vignette(pkg::name)})`
+#'
+#' @name cli-links
+#' @noRd
+NULL
+
+make_link <- function(txt, type = c("email", "file", "fun", "help", "href",
+                                    "run", "topic", "url", "vignette")) {
+  type <- match.arg(type)
+
+  switch(
+    type,
+    email    = make_link_email(txt),
+    file     = make_link_file(txt),
+    fun      = make_link_fun(txt),
+    help     = make_link_help(txt),
+    href     = make_link_href(txt),
+    run      = make_link_run(txt),
+    topic    = make_link_topic(txt),
+    url      = make_link_url(txt),
+    vignette = make_link_vignette(txt),
+    stop("Unknown link type")
+  )
+}
+
+# -- {.email} -------------------------------------------------------------
+
+make_link_email <- function(txt) {
+  style_hyperlink(txt, paste0("mailto:", txt))
+}
+
+# -- {.file} and {.path} --------------------------------------------------
+
+# if txt already contains a hyperlink, then we do not add another link
+# this is needed because some packages, e.g. roxygen2 currently create
+# links to files manually:
+# https://github.com/r-lib/roxygen2/blob/3ddfd7f2e35c3a71d5705ab4f49e851cd8da306d/R/utils.R#L91
+
+make_link_file <- function(txt) {
+  ret <- txt
+  linked <- grepl("\007|\033\\\\", txt)
+  ret[!linked] <- vcapply(which(!linked), function(i) {
+    params <- parse_file_link_params(txt[i])
+    style_hyperlink(txt[i], abs_path(params$path), params = params$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]]
+    list(path = path, params = c(line = num[1], col = num[2]))
+
+  } else if (grepl(":[0-9]+$", txt)) {
+    # path:line
+    path <- sub("^(.*):[0-9]+$", "\\1", txt)
+    num <- sub("^.*:([0-9]+$)", "\\1", txt)
+    list(path = path, params = c(line = num, col = "1"))
+
+  } else {
+    list(path = txt, params = NULL)
+  }
+}
+
+abs_path <- function(x) {
+  x <- path.expand(x)
+  vcapply(x, abs_path1, USE.NAMES = FALSE)
+}
+
+abs_path1 <- function(x) {
+  if (grepl("^file://", x)) return(x)
+  if (grepl("^/", x)) return(paste0("file://", x))
+  if (is_windows() && grepl("^[a-zA-Z]:", x)) return(paste0("file://", x))
+  paste0("file://", file.path(getwd(), x))
+}
+
+# -- {.fun} ---------------------------------------------------------------
+
+make_link_fun <- function(txt) {
+  tolink <- grepl("::", txt)
+  linked <- grepl("\007|\033\\\\", txt)
+  todo <- tolink & !linked
+  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])
+    )
+  }
+
+  txt
+}
+
+# -- {.help} --------------------------------------------------------------
+
+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)
+
+  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, ")"))
+  }
+}
+
+# -- {.href} --------------------------------------------------------------
+
+make_link_href <- 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)
+  if (ansi_has_hyperlink_support()) {
+    link <- style_hyperlink(text = text, url = url)
+    style <- is.na(mch$text)
+    link[style] <- vcapply(
+      url[style],
+      function(url1) format_inline("{.url {url1}}")
+    )
+    link
+  } else {
+    url2 <- vcapply(url, function(url1) format_inline("{.url {url1}}"))
+    ifelse(text == url, url2, paste0(text, " (", url2, ")"))
+  }
+}
+
+# -- {.run} ---------------------------------------------------------------
+
+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)
+
+  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}}"))
+  }
+}
+
+# -- {.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)
+
+  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, ")"))
+  }
+}
+
+# -- {.url} ---------------------------------------------------------------
+
+make_link_url <- function(txt) {
+  linked <- grepl("\007|\033\\\\", txt)
+  if (all(linked)) return(txt)
+  txt[!linked] <- style_hyperlink(txt[!linked], txt[!linked])
+  txt
+}
+
+# -- {.vignette} ----------------------------------------------------------
+
+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)
+
+  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, ")"))
+  }
+}
+
 #' Terminal Hyperlinks
 #'
 #' `ansi_hyperlink()` creates an ANSI hyperlink.
@@ -32,7 +283,11 @@ style_hyperlink <- function(text, url, params = NULL) {
     )
   }
 
-  ST <- "\u0007"
+  if (Sys.getenv("R_CLI_HYPERLINK_MODE") == "posix") {
+    ST <- "\033\\"
+  } else {
+    ST <- "\u0007"
+  }
 
   out <- if (ansi_has_hyperlink_support()) {
     paste0("\u001B]8;", params, ";", url, ST, text, "\u001B]8;;", ST)
@@ -45,7 +300,7 @@ style_hyperlink <- function(text, url, params = NULL) {
 }
 
 #' @export
-#' @name style_hyperlink
+#' @rdname style_hyperlink
 #' @examples
 #' ansi_has_hyperlink_support()
 
@@ -114,3 +369,58 @@ ansi_has_hyperlink_support <- function() {
 
   FALSE
 }
+
+
+#' @details
+#' `ansi_hyperlink_types()` checks if current `stdout()` supports various
+#' types of hyperlinks. It returns a list with entries `href`, `run`,
+#' `help` and `vignettes`.
+#'
+#' @rdname style_hyperlink
+#' @export
+
+ansi_hyperlink_types <- function() {
+
+  get_config <- function(x, default = NULL) {
+    opt <- getOption(paste0("cli.", tolower(x)))
+    if (!is.null(opt)) return(isTRUE(opt))
+
+    env <- Sys.getenv(paste0("R_CLI_", toupper(x)), NA_character_)
+    if (!is.na(env)) return(isTRUE(as.logical(env)))
+
+    default
+  }
+
+  rs <- rstudio_detect()
+  has <- ansi_has_hyperlink_support()
+
+  # they are on by default in RStudio, but not otherwise
+  run <- get_config("hyperlink_run", default = rs$hyperlink)
+  hlp <- get_config("hyperlink_help", default = rs$hyperlink)
+  vgn <- get_config("hyperlink_vignette", default = rs$hyperlink)
+
+  if (!has) {
+    list(
+      href = FALSE,
+      run = FALSE,
+      help = FALSE,
+      vignette = FALSE
+    )
+
+  } else if (rs$hyperlink) {
+    list(
+      href = TRUE,
+      run = structure(run, type = "rstudio"),
+      help = structure(hlp, type = "rstudio"),
+      vignette = structure(vgn, type = "rstudio")
+    )
+
+  } else {
+    list(
+      href = TRUE,
+      run = structure(run, type = "standard"),
+      help = structure(hlp, type = "standard"),
+      vignette = structure(vgn, type = "standard")
+    )
+  }
+}