Draft compat file for cli

NEWS.md

@@ -1,5 +1,8 @@
 # rlang (development version)
 
+* Added `compat-cli.R` file to format message elements consistently
+  with cli in zero-deps packages.
+
 * `exprs_auto_name()` gains a `repair_auto` argument to make automatic
   names unique (#1116).
 

R/arg.R

@@ -38,7 +38,7 @@ arg_match <- function(arg, values = NULL) {
     values <- eval_bare(values, get_env(fn))
   }
   if (!is_character(arg)) {
-    abort(paste0(chr_quoted(arg_nm), " must be a character vector."))
+    abort(sprintf("%s must be a character vector.", style_arg(arg_nm)))
   }
   if (length(arg) > 1 && !setequal(arg, values)) {
     abort(arg_match_invalid_msg(arg, values, arg_nm))
@@ -110,7 +110,7 @@ stop_arg_match <- function(arg, values, arg_nm) {
 }
 
 arg_match_invalid_msg <- function(arg, values, arg_nm) {
-  msg <- paste0(chr_quoted(arg_nm), " must be one of ")
+  msg <- paste0(style_arg(arg_nm), " must be one of ")
   msg <- paste0(msg, chr_enumerate(chr_quoted(values, "\"")))
 
   if (is_null(arg)) {
@@ -151,9 +151,16 @@ arg_require <- function(arg) {
   call <- sys.calls()[[sys.parent()]]
   if (is_call(call) && is_symbol(call[[1]])) {
     fn <- as_string(call[[1]])
-    msg <- sprintf("`%s()` requires the argument `%s` to be supplied.", fn, arg)
+    msg <- sprintf(
+      "%s requires the argument %s to be supplied.",
+      style_fn(fn),
+      style_arg(arg)
+    )
   } else {
-    msg <- sprintf("The argument `%s` must be supplied.", arg)
+    msg <- sprintf(
+      "The argument %s must be supplied.",
+      style_arg(arg)
+    )
   }
 
   abort(msg)

R/compat-cli.R

@@ -0,0 +1,77 @@
+# nocov start - compat-cli.R
+# Latest version: https://github.com/r-lib/rlang/blob/master/R/compat-cli.R
+
+# Provides a minimal shim API to format message elements consistently
+# with cli in packages that can't depend on it. If available, cli is
+# used to format the elements. Otherwise a fallback format is used.
+#
+# Changelog:
+# 2021-05-11:
+# * Initial version.
+
+style_emph <- function(x) {
+  .rlang_cli_style(x, "emph", "_%s_")
+}
+style_strong <- function(x) {
+  .rlang_cli_style(x, "strong", "*%s*")
+}
+style_code <- function(x) {
+  .rlang_cli_style(x, "code", "`%s`")
+}
+style_q <- function(x) {
+  .rlang_cli_style(x, "q", NULL)
+}
+style_pkg <- function(x) {
+  .rlang_cli_style(x, "pkg", NULL)
+}
+style_fn <- function(x) {
+  .rlang_cli_style(x, "fn", "`%s()`")
+}
+style_arg <- function(x) {
+  .rlang_cli_style(x, "arg", "`%s`")
+}
+style_kbd <- function(x) {
+  .rlang_cli_style(x, "kbd", "[%s]")
+}
+style_key <- function(x) {
+  .rlang_cli_style(x, "key", "[%s]")
+}
+style_file <- function(x) {
+  .rlang_cli_style(x, "file", NULL)
+}
+style_path <- function(x) {
+  .rlang_cli_style(x, "path", NULL)
+}
+style_email <- function(x) {
+  .rlang_cli_style(x, "email", NULL)
+}
+style_url <- function(x) {
+  .rlang_cli_style(x, "url", "<%s>")
+}
+style_var <- function(x) {
+  .rlang_cli_style(x, "var", "`%s`")
+}
+style_envvar <- function(x) {
+  .rlang_cli_style(x, "envvar", "`%s`")
+}
+style_field <- function(x) {
+  .rlang_cli_style(x, "field", NULL)
+}
+style_cls <- function(x) {
+  fallback <- function(x) sprintf("<%s>", paste0(x, collapse = "/"))
+  .rlang_cli_style(x, "cls", fallback)
+}
+
+.rlang_cli_style <- function(x, span, fallback = "`%s`") {
+  if (requireNamespace("cli") && cli::num_ansi_colors() > 1) {
+    cli::format_message(paste0("{.", span, " {x}}"))
+  } else if (is.null(fallback)) {
+    x
+  } else if (is.function(fallback)) {
+    fallback(x)
+  } else {
+    sprintf(fallback, x)
+  }
+}
+
+# nocov end

tests/testthat/_snaps/compat-cli.md

@@ -0,0 +1,150 @@
+# can style strings with cli [plain]
+
+    Code
+      style_emph("foo")
+    Output
+      [1] "_foo_"
+    Code
+      style_strong("foo")
+    Output
+      [1] "*foo*"
+    Code
+      style_code("foo")
+    Output
+      [1] "`foo`"
+    Code
+      style_q("foo")
+    Output
+      [1] "foo"
+    Code
+      style_pkg("foo")
+    Output
+      [1] "foo"
+    Code
+      style_fn("foo")
+    Output
+      [1] "`foo()`"
+    Code
+      style_arg("foo")
+    Output
+      [1] "`foo`"
+    Code
+      style_kbd("foo")
+    Output
+      [1] "[foo]"
+    Code
+      style_key("foo")
+    Output
+      [1] "[foo]"
+    Code
+      style_file("foo")
+    Output
+      [1] "foo"
+    Code
+      style_path("foo")
+    Output
+      [1] "foo"
+    Code
+      style_email("foo")
+    Output
+      [1] "foo"
+    Code
+      style_url("foo")
+    Output
+      [1] "<foo>"
+    Code
+      style_var("foo")
+    Output
+      [1] "`foo`"
+    Code
+      style_envvar("foo")
+    Output
+      [1] "`foo`"
+    Code
+      style_field("foo")
+    Output
+      [1] "foo"
+    Code
+      style_cls("foo")
+    Output
+      [1] "<foo>"
+    Code
+      style_cls(c("foo", "bar"))
+    Output
+      [1] "<foo/bar>"
+
+# can style strings with cli [ansi]
+
+    Code
+      style_emph("foo")
+    Output
+      [1] "\033[1m\033[22m\033[3m\033[3mfoo\033[3m\033[23m"
+    Code
+      style_strong("foo")
+    Output
+      [1] "\033[1m\033[22m\033[1m\033[1mfoo\033[1m\033[22m"
+    Code
+      style_code("foo")
+    Output
+      [1] "\033[1m\033[22m\033[30m\033[47m\033[30m\033[47m`foo`\033[47m\033[30m\033[49m\033[39m"
+    Code
+      style_q("foo")
+    Output
+      [1] "\033[1m\033[22mfoo"
+    Code
+      style_pkg("foo")
+    Output
+      [1] "\033[1m\033[22m\033[34m\033[34mfoo\033[34m\033[39m"
+    Code
+      style_fn("foo")
+    Output
+      [1] "\033[1m\033[22m\033[30m\033[47m\033[30m\033[47m`foo()`\033[47m\033[30m\033[49m\033[39m"
+    Code
+      style_arg("foo")
+    Output
+      [1] "\033[1m\033[22m\033[30m\033[47m\033[30m\033[47m`foo`\033[47m\033[30m\033[49m\033[39m"
+    Code
+      style_kbd("foo")
+    Output
+      [1] "\033[1m\033[22m\033[34m\033[34m[foo]\033[34m\033[39m"
+    Code
+      style_key("foo")
+    Output
+      [1] "\033[1m\033[22m\033[34m\033[34m[foo]\033[34m\033[39m"
+    Code
+      style_file("foo")
+    Output
+      [1] "\033[1m\033[22m\033[34m\033[34mfoo\033[34m\033[39m"
+    Code
+      style_path("foo")
+    Output
+      [1] "\033[1m\033[22m\033[34m\033[34mfoo\033[34m\033[39m"
+    Code
+      style_email("foo")
+    Output
+      [1] "\033[1m\033[22m\033[34m\033[34mfoo\033[34m\033[39m"
+    Code
+      style_url("foo")
+    Output
+      [1] "\033[1m\033[22m\033[3m\033[34m\033[3m\033[34m<foo>\033[34m\033[3m\033[39m\033[23m"
+    Code
+      style_var("foo")
+    Output
+      [1] "\033[1m\033[22m\033[30m\033[47m\033[30m\033[47m`foo`\033[47m\033[30m\033[49m\033[39m"
+    Code
+      style_envvar("foo")
+    Output
+      [1] "\033[1m\033[22m\033[30m\033[47m\033[30m\033[47m`foo`\033[47m\033[30m\033[49m\033[39m"
+    Code
+      style_field("foo")
+    Output
+      [1] "\033[1m\033[22m\033[32m\033[32mfoo\033[32m\033[39m"
+    Code
+      style_cls("foo")
+    Output
+      [1] "\033[1m\033[22m\033[34m\033[34m<foo>\033[34m\033[39m"
+    Code
+      style_cls(c("foo", "bar"))
+    Output
+      [1] "\033[1m\033[22m\033[34m\033[34m<foo/bar>\033[34m\033[39m"
+

tests/testthat/test-compat-cli.R

@@ -0,0 +1,28 @@
+skip_if_not_installed("cli")
+
+cli::test_that_cli(configs = c("plain", "ansi"), "can style strings with cli", {
+  expect_snapshot({
+    style_emph("foo")
+    style_strong("foo")
+    style_code("foo")
+    style_q("foo")
+    style_pkg("foo")
+    style_fn("foo")
+    style_arg("foo")
+    style_kbd("foo")
+    style_key("foo")
+    style_file("foo")
+    style_path("foo")
+    style_email("foo")
+    style_url("foo")
+    style_var("foo")
+    style_envvar("foo")
+    style_field("foo")
+    style_cls("foo")
+    style_cls(c("foo", "bar"))
+  })
+})
+
+cli::test_that_cli(configs = "plain", "styled strings may contain `{` syntax", {
+  expect_equal(style_emph("{foo {}"), "_{foo {}_")
+})