1
2#' List the currently active themes
3#'
4#' If there is no active app, then it calls [start_app()].
5#'
6#' @return A list of data frames with the active themes.
7#' Each data frame row is a style that applies to selected CLI tree nodes.
8#' Each data frame has columns:
9#' * `selector`: The original CSS-like selector string. See [themes].
10#' * `parsed`: The parsed selector, as used by cli for matching to nodes.
11#' * `style`: The original style.
12#' * `cnt`: The id of the container the style is currently applied to, or
13#'   `NA` if the style is not used.
14#'
15#' @export
16#' @seealso [themes]
17
18cli_list_themes <- function() {
19  app <- default_app() %||% start_app()
20  app$list_themes()
21}
22
23clii_list_themes <- function(app) {
24  app$themes
25}
26
27clii_add_theme <- function(app, theme) {
28  id <- new_uuid()
29  app$themes <-
30    c(app$themes, structure(list(theme_create(theme)), names = id))
31  id
32}
33
34clii_remove_theme <- function(app, id) {
35  if (! id %in% names(app$themes)) return(invisible(FALSE))
36  app$themes[[id]] <- NULL
37  invisible(TRUE)
38}
39
40#' The built-in CLI theme
41#'
42#' This theme is always active, and it is at the bottom of the theme
43#' stack. See [themes].
44#'
45#' # Showcase
46#'
47#' ```{asciicast builtin-theme}
48#' cli_h1("Heading 1")
49#' cli_h2("Heading 2")
50#' cli_h3("Heading 3")
51#'
52#' cli_par()
53#' cli_alert_danger("Danger alert")
54#' cli_alert_warning("Warning alert")
55#' cli_alert_info("Info alert")
56#' cli_alert_success("Success alert")
57#' cli_alert("Alert for starting a process or computation",
58#'   class = "alert-start")
59#' cli_end()
60#'
61#' cli_text("Packages and versions: {.pkg cli} {.version 1.0.0}.")
62#' cli_text("Time intervals: {.timestamp 3.4s}")
63#'
64#' cli_text("{.emph Emphasis} and  {.strong strong emphasis}")
65#'
66#' cli_text("This is a piece of code: {.code sum(x) / length(x)}")
67#' cli_text("Function names: {.fn cli::simple_theme}")
68#'
69#' cli_text("Files: {.file /usr/bin/env}")
70#' cli_text("URLs: {.url https://r-project.org}")
71#'
72#' cli_h2("Longer code chunk")
73#' cli_par(class = "code R")
74#' cli_verbatim(
75#'   '# window functions are useful for grouped mutates',
76#'   'mtcars %>%',
77#'   '  group_by(cyl) %>%',
78#'   '  mutate(rank = min_rank(desc(mpg)))')
79#' ```
80#'
81#' @seealso [themes], [simple_theme()].
82#' @return A named list, a CLI theme.
83#'
84#' @param dark Whether to use a dark theme. The `cli_theme_dark` option
85#'   can be used to request a dark theme explicitly. If this is not set,
86#'   or set to `"auto"`, then cli tries to detect a dark theme, this
87#'   works in recent RStudio versions and in iTerm on macOS.
88#' @export
89
90builtin_theme <- function(dark = getOption("cli_theme_dark", "auto")) {
91
92  dark <- detect_dark_theme(dark)
93
94  list(
95    body = list(
96      "class-map" = list(
97        fs_path = "file",
98        "cli-progress-bar" = "progress-bar"
99      )
100    ),
101
102    h1 = list(
103      "font-weight" = "bold",
104      "margin-top" = 1,
105      "margin-bottom" = 0,
106      fmt = function(x) cli::rule(x, line_col = "cyan")),
107    h2 = list(
108      "font-weight" = "bold",
109      "margin-top" = 1,
110      "margin-bottom" = 1,
111      fmt = function(x) paste0(symbol$line, symbol$line, " ", x, " ",
112                               symbol$line, symbol$line)),
113    h3 = list(
114      "margin-top" = 1,
115      fmt = function(x) paste0(symbol$line, symbol$line, " ", x, " ")),
116
117    ".alert" = list(
118      before = function() paste0(symbol$arrow_right, " ")
119    ),
120    ".alert-success" = list(
121      before = function() paste0(col_green(symbol$tick), " ")
122    ),
123    ".alert-danger" = list(
124      before = function() paste0(col_red(symbol$cross), " ")
125    ),
126    ".alert-warning" = list(
127      before = function() paste0(col_yellow("!"), " ")
128    ),
129    ".alert-info" = list(
130      before = function() paste0(col_cyan(symbol$info), " ")
131    ),
132
133    ".memo .memo-item-empty" = list(),
134    ".memo .memo-item-space" = list("margin-left" = 2),
135    ".memo .memo-item-v" = list(
136      "text-exdent" = 2,
137      before = function(x) paste0(col_green(symbol$tick), " ")
138    ),
139    ".memo .memo-item-x" = list(
140      "text-exdent" = 2,
141      before = function(x) paste0(col_red(symbol$cross), " ")
142    ),
143    ".memo .memo-item-!" = list(
144      "text-exdent" = 2,
145      before = function(x) paste0(col_yellow("!"), " ")
146    ),
147    ".memo .memo-item-i" = list(
148      "text-exdent" = 2,
149      before = function(x) paste0(col_cyan(symbol$info), " ")
150    ),
151    ".memo .memo-item-*" = list(
152      "text-exdent" = 2,
153      before = function(x) paste0(col_cyan(symbol$bullet), " ")
154    ),
155    ".memo .memo-item->" = list(
156      "text-exdent" = 2,
157      before = function(x) paste0(symbol$arrow_right, " ")
158    ),
159    ".memo .memo-item-1" = list(
160    ),
161
162    par = list("margin-top" = 0, "margin-bottom" = 1),
163    ul = list(
164      "list-style-type" = function() symbol$bullet
165    ),
166
167    # these are tags in HTML, but in cli they are inline
168    span.dt = list(after = ": "),
169    span.dd = list(),
170
171    # This means that list elements have a margin, if they are nested
172    "ul ul li" = list("margin-left" = 2),
173    "ul ol li" = list("margin-left" = 2),
174    "ul dl li" = list("margin-left" = 2),
175    "ol ul li" = list("margin-left" = 2),
176    "ol ol li" = list("margin-left" = 2),
177    "ol dl li" = list("margin-left" = 2),
178    "ol ul li" = list("margin-left" = 2),
179    "ol ol li" = list("margin-left" = 2),
180    "ol dl li" = list("margin-left" = 2),
181
182    blockquote = list("padding-left" = 4L, "padding-right" = 10L,
183                      "font-style" = "italic", "margin-top" = 1L,
184                      "margin-bottom" = 1L,
185                      before = function() symbol$dquote_left,
186                      after = function() symbol$dquote_right),
187    "blockquote cite" = list(
188      before = function() paste0(symbol$em_dash, " "),
189      "font-style" = "italic",
190      "font-weight" = "bold"
191    ),
192
193    .code = list(fmt = format_code(dark)),
194    .code.R = list(fmt = format_r_code(dark)),
195
196    span.emph = list("font-style" = "italic"),
197    span.strong = list("font-weight" = "bold"),
198    span.code = theme_code_tick(dark),
199
200    span.q   = list(fmt = quote_weird_name2),
201    span.pkg = list(color = "blue"),
202    span.fn = theme_function(dark),
203    span.fun = theme_function(dark),
204    span.arg = theme_code_tick(dark),
205    span.kbd = list(before = "[", after = "]", color = "blue"),
206    span.key = list(before = "[", after = "]", color = "blue"),
207    span.file = list(color = "blue", fmt = quote_weird_name),
208    span.path = list(color = "blue", fmt = quote_weird_name),
209    span.email = list(color = "blue", fmt = quote_weird_name),
210    span.url = list(before = "<", after = ">", color = "blue",
211                    "font-style" = "italic"),
212    span.var = theme_code_tick(dark),
213    span.col = theme_code_tick(dark),
214    span.str = list(fmt = encode_string),
215    span.envvar = theme_code_tick(dark),
216    span.val = list(
217      transform = function(x, ...) cli_format(x, ...),
218      color = "blue"
219    ),
220    span.field = list(color = "green"),
221    span.cls = list(collapse = "/", color = "blue", before = "<", after = ">"),
222    "span.progress-bar" = list(
223      transform = theme_progress_bar,
224      color = "green"
225    ),
226    span.or = list(vec_sep2 = " or ", vec_last = ", or "),
227    span.timestamp = list(before = "[", after = "]", color = "grey")
228  )
229}
230
231encode_string <- function(x) {
232  encodeString(x, quote = "\"")
233}
234
235quote_weird_name0 <- function(x) {
236  x <- gsub(" ", "\u00a0", x)
237  x2 <- ansi_strip(x)
238
239  fc <- first_character(x2)
240  sc <- second_character(x2)
241  lc <- last_character(x2)
242
243  wfst <- !is_alnum(fc, ok = "~") || (fc == "~" && !is_alnum(sc))
244  wlst <- !is_alnum(lc)
245
246  if (wfst || wlst) {
247    lsp <- leading_space(x2)
248    tsp <- trailing_space(x2)
249    if (nzchar(lsp)) {
250      x <- paste0(
251        bg_blue(lsp),
252        ansi_substr(x, nchar(lsp) + 1, ansi_nchar(x))
253      )
254    }
255    if (nzchar(tsp)) {
256      x <- paste0(
257        ansi_substr(x, 1, ansi_nchar(x) - nchar(tsp)),
258        bg_blue(tsp)
259      )
260    }
261  }
262
263  list(x, wfst || wlst)
264}
265
266quote_weird_name <- function(x) {
267  x2 <- quote_weird_name0(x)
268  if (x2[[2]] || num_ansi_colors() == 1) {
269    x2[[1]] <- paste0("'", x2[[1]], "'")
270  }
271  x2[[1]]
272}
273
274quote_weird_name2 <- function(x) {
275  x2 <- quote_weird_name0(x)
276  paste0("\"", x2[[1]], "\"")
277}
278
279theme_progress_bar <- function(x, app, style) {
280  make_progress_bar(x$current / x$total, style = style)
281}
282
283detect_dark_theme <- function(dark) {
284  tryCatch({
285    if (dark == "auto") {
286      dark <- if (Sys.getenv("RSTUDIO", "0") == "1") {
287        rstudioapi::getThemeInfo()$dark
288      } else if (is_iterm()) {
289        is_iterm_dark()
290      } else {
291        FALSE
292      }
293    }
294  }, error = function(e) FALSE)
295
296  isTRUE(dark)
297}
298
299theme_code <- function(dark) {
300  if (dark) {
301    list("background-color" = "#232323", color = "#d0d0d0")
302  } else{
303    list("background-color" = "#e8e8e8", color = "#202020")
304  }
305}
306
307theme_code_tick <- function(dark) {
308  utils::modifyList(theme_code(dark), list(before = "`", after = "`"))
309}
310
311theme_function <- function(dark) {
312  utils::modifyList(theme_code(dark), list(before = "`", after = "()`"))
313}
314
315format_r_code <- function(dark) {
316  function(x) {
317    x <- ansi_strip(x)
318    lines <- unlist(strsplit(x, "\n", fixed = TRUE))
319    code_highlight(lines)
320  }
321}
322
323format_code <- function(dark) {
324  function(x) {
325    unlist(strsplit(x, "\n", fixed = TRUE))
326  }
327}
328
329theme_create <- function(theme) {
330  mtheme <- theme
331  mtheme[] <- lapply(mtheme, create_formatter)
332  selectors <- names(theme)
333  res <- data.frame(
334    stringsAsFactors = FALSE,
335    selector = as.character(selectors),
336    parsed = I(lapply(selectors, parse_selector) %||% list()),
337    style = I(mtheme %||% list()),
338    cnt = rep(NA_character_, length(selectors))
339  )
340
341  rownames(res) <- NULL
342  res
343}
344
345create_formatter <- function(x) {
346  is_bold <- identical(x[["font-weight"]], "bold")
347  is_italic <- identical(x[["font-style"]], "italic")
348  is_underline <- identical(x[["text-decoration"]], "underline")
349  is_color <- "color" %in% names(x)
350  is_bg_color <- "background-color" %in% names(x)
351
352  if (!is_bold && !is_italic && !is_underline && !is_color
353      && !is_bg_color) return(x)
354
355  if (is_color && is.null(x[["color"]])) {
356    x[["color"]] <- "none"
357  }
358  if (is_bg_color && is.null(x[["background-color"]])) {
359    x[["background-color"]] <- "none"
360  }
361
362  fmt <- c(
363    if (is_bold) list(style_bold),
364    if (is_italic) list(style_italic),
365    if (is_underline) list(style_underline),
366    if (is_color) make_ansi_style(x[["color"]]),
367    if (is_bg_color) make_ansi_style(x[["background-color"]], bg = TRUE)
368  )
369
370  new_fmt <- do.call(combine_ansi_styles, fmt)
371
372  if (is.null(x[["fmt"]])) {
373    x[["fmt"]] <- new_fmt
374  } else {
375    orig_fmt <- x[["fmt"]]
376    x[["fmt"]] <- function(x) orig_fmt(new_fmt(x))
377  }
378
379  x
380}
381
382merge_embedded_styles <- function(old, new) {
383  # before and after is not inherited, fmt is not inherited, either
384  # side margins are additive, class mappings are merged
385  # rest is updated, counter is reset
386  old$before <- old$after <- old$fmt <- NULL
387
388  top <- new$`margin-top` %||% 0L
389  bottom <- new$`margin-bottom` %||% 0L
390  left <- (old$`margin-left` %||% 0L) + (new$`margin-left` %||% 0L)
391  right <- (old$`margin-right` %||% 0L) + (new$`margin-right` %||% 0L)
392
393  map <- utils::modifyList(old$`class-map` %||% list(), new$`class-map` %||% list())
394
395  start <- new$start %||% 1L
396
397  mrg <- utils::modifyList(old, new)
398  mrg[c("margin-top", "margin-bottom", "margin-left", "margin-right",
399        "start", "class-map")] <- list(top, bottom, left, right, start, map)
400
401  ## Formatter needs to be re-generated
402  create_formatter(mrg)
403}
404
405#' Parse a CSS3-like selector
406#'
407#' This is the rather small subset of CSS3 that is supported:
408#'
409#' Selectors:
410#'
411#' * Type selectors, e.g. `input` selects all `<input>` elements.
412#' * Class selectors, e.g. `.index` selects any element that has a class
413#'   of "index".
414#' * ID selector. `#toc` will match the element that has the ID `"toc"`.
415#'
416#' Combinators:
417#'
418#' * Descendant combinator, i.e. the space, that combinator selects nodes
419#'   that are descendants of the first element. E.g. `div span` will match
420#'   all `<span>` elements that are inside a `<div>` element.
421#'
422#' @param x CSS3-like selector string.
423#'
424#' @keywords internal
425
426parse_selector <- function(x) {
427  lapply(strsplit(x, " ", fixed = TRUE)[[1]], parse_selector_node)
428}
429
430parse_selector_node <- function(x) {
431
432  parse_ids <- function(y) {
433    r <- strsplit(y, "#", fixed = TRUE)[[1]]
434    if (length(r) > 1) r[-1] <- paste0("#", r[-1])
435    r
436  }
437
438  parts <- strsplit(x, ".", fixed = TRUE)[[1]]
439  if (length(parts) > 1) parts[-1] <- paste0(".", parts[-1])
440  parts <- unlist(lapply(parts, parse_ids))
441  parts <- parts[parts != ""]
442
443  m_cls <- grepl("^\\.", parts)
444  m_ids <- grepl("^#", parts)
445
446  list(tag = as.character(unique(parts[!m_cls & !m_ids])),
447       class = str_tail(unique(parts[m_cls])),
448       id = str_tail(unique(parts[m_ids])))
449}
450
451#' Match a selector node to a container
452#'
453#' @param node Selector node, as parsed by `parse_selector_node()`.
454#' @param cnt Container node, has elements `tag`, `id`, `class`.
455#'
456#' The selector node matches the container, if all these hold:
457#'
458#' * The id of the selector is missing or unique.
459#' * The tag of the selector is missing or unique.
460#' * The id of the container is missing or unique.
461#' * The tag of the container is unique.
462#' * If the selector specifies an id, it matches the id of the container.
463#' * If the selector specifies a tag, it matches the tag of the container.
464#' * If the selector specifies class names, the container has all these
465#'   classes.
466#'
467#' @keywords internal
468
469match_selector_node <- function(node, cnt) {
470  if (length(node$id) > 1 || length(cnt$id) > 1) return(FALSE)
471  if (length(node$tag) > 1 || length(cnt$tag) > 1) return(FALSE)
472  all(node$id %in% cnt$id) &&
473    all(node$tag %in% cnt$tag) &&
474    all(node$class %in% cnt$class)
475}
476
477#' Match a selector to a container stack
478#'
479#' @param sels A list of selector nodes.
480#' @param cnts A list of container nodes.
481#'
482#' The last selector in the list must match the last container, so we
483#' do the matching from the back. This is because we use this function
484#' to calculate the style of newly encountered containers.
485#'
486#' @keywords internal
487
488match_selector <- function(sels, cnts) {
489  sptr <- length(sels)
490  cptr <- length(cnts)
491
492  # Last selector must match the last container
493  if (sptr == 0 || sptr > cptr) return(FALSE)
494  match <- match_selector_node(sels[[sptr]], cnts[[cptr]])
495  if (!match) return (FALSE)
496
497  # Plus the rest should match somehow
498  sptr <- sptr - 1L
499  cptr <- cptr - 1L
500  while (sptr != 0L && sptr <= cptr) {
501    match <- match_selector_node(sels[[sptr]], cnts[[cptr]])
502    if (match) {
503      sptr <- sptr - 1L
504      cptr <- cptr - 1L
505    } else {
506      cptr <- cptr - 1L
507    }
508  }
509
510  sptr == 0
511}
512