r-lib / cli
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

18
cli_list_themes <- function() {
19 0
  app <- default_app() %||% start_app()
20 0
  app$list_themes()
21
}
22

23
clii_list_themes <- function(app) {
24 1
  app$themes
25
}
26

27
clii_add_theme <- function(app, theme) {
28 1
  id <- new_uuid()
29 1
  app$themes <-
30 1
    c(app$themes, structure(list(theme_create(theme)), names = id))
31 1
  id
32
}
33

34
clii_remove_theme <- function(app, id) {
35 1
  if (! id %in% names(app$themes)) return(invisible(FALSE))
36 1
  app$themes[[id]] <- NULL
37 1
  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
#' @seealso [themes], [simple_theme()].
46
#' @return A named list, a CLI theme.
47
#'
48
#' @param dark Whether to use a dark theme. The `cli_theme_dark` option
49
#'   can be used to request a dark theme explicitly. If this is not set,
50
#'   or set to `"auto"`, then cli tries to detect a dark theme, this
51
#'   works in recent RStudio versions and in iTerm on macOS.
52
#' @export
53

54
builtin_theme <- function(dark = getOption("cli_theme_dark", "auto")) {
55

56 1
  dark <- detect_dark_theme(dark)
57

58 1
  list(
59 1
    body = list(
60 1
      "class-map" = list(
61 1
        fs_path = "file"
62
      )
63
    ),
64

65 1
    h1 = list(
66 1
      "font-weight" = "bold",
67 1
      "margin-top" = 1,
68 1
      "margin-bottom" = 0,
69 1
      fmt = function(x) cli::rule(x, line_col = "cyan")),
70 1
    h2 = list(
71 1
      "font-weight" = "bold",
72 1
      "margin-top" = 1,
73 1
      "margin-bottom" = 1,
74 1
      fmt = function(x) paste0(symbol$line, symbol$line, " ", x, " ",
75 1
                               symbol$line, symbol$line)),
76 1
    h3 = list(
77 1
      "margin-top" = 1,
78 1
      fmt = function(x) paste0(symbol$line, symbol$line, " ", x, " ")),
79

80 1
    ".alert" = list(
81 1
      before = paste0(symbol$arrow_right, " ")
82
    ),
83 1
    ".alert-success" = list(
84 1
      before = paste0(crayon::green(symbol$tick), " ")
85
    ),
86 1
    ".alert-danger" = list(
87 1
      before = paste0(crayon::red(symbol$cross), " ")
88
    ),
89 1
    ".alert-warning" = list(
90 1
      before = paste0(crayon::yellow("!"), " ")
91
    ),
92 1
    ".alert-info" = list(
93 1
      before = paste0(crayon::cyan(symbol$info), " ")
94
    ),
95

96 1
    par = list("margin-top" = 0, "margin-bottom" = 1),
97 1
    li = list("padding-left" = 2),
98 1
    ul = list("list-style-type" = symbol$bullet, "padding-left" = 0),
99 1
    "ul ul" = list("list-style-type" = symbol$circle, "padding-left" = 2),
100 1
    "ul ul ul" = list("list-style-type" = symbol$line),
101

102 1
    "ul ul" = list("padding-left" = 2),
103 1
    "ul dl" = list("padding-left" = 2),
104 1
    "ol ol" = list("padding-left" = 2),
105 1
    "ol ul" = list("padding-left" = 2),
106 1
    "ol dl" = list("padding-left" = 2),
107 1
    "dl ol" = list("padding-left" = 2),
108 1
    "dl ul" = list("padding-left" = 2),
109 1
    "dl dl" = list("padding-left" = 2),
110

111 1
    blockquote = list("padding-left" = 4L, "padding-right" = 10L,
112 1
                      "font-style" = "italic", "margin-top" = 1L,
113 1
                      "margin-bottom" = 1L, before = symbol$dquote_left,
114 1
                      after = symbol$dquote_right),
115 1
    "blockquote cite" = list(before = paste0(symbol$em_dash, " "),
116 1
                             "font-style" = "italic", "font-weight" = "bold"),
117

118 1
    .code = list(fmt = format_code(dark)),
119 1
    .code.R = list(fmt = format_r_code(dark)),
120

121 1
    span.emph = list("font-style" = "italic"),
122 1
    span.strong = list("font-weight" = "bold"),
123 1
    span.code = theme_code_tick(dark),
124

125 1
    span.pkg = list(color = "blue"),
126 1
    span.fn = theme_function(dark),
127 1
    span.fun = theme_function(dark),
128 1
    span.arg = theme_code_tick(dark),
129 1
    span.kbd = list(before = "[", after = "]", color = "blue"),
130 1
    span.key = list(before = "[", after = "]", color = "blue"),
131 1
    span.file = list(color = "blue"),
132 1
    span.path = list(color = "blue"),
133 1
    span.email = list(color = "blue"),
134 1
    span.url = list(before = "<", after = ">", color = "blue",
135 1
                    "font-style" = "italic"),
136 1
    span.var = theme_code_tick(dark),
137 1
    span.envvar = theme_code_tick(dark),
138 1
    span.val = list(
139 1
      transform = function(x, ...) cli_format(x, ...),
140 1
      color = "blue"
141
    ),
142 1
    span.field = list(color = "green")
143
  )
144
}
145

146
detect_dark_theme <- function(dark) {
147 1
  tryCatch({
148 1
    if (dark == "auto") {
149 1
      dark <- if (Sys.getenv("RSTUDIO", "0") == "1") {
150 0
        rstudioapi::getThemeInfo()$dark
151 1
      } else if (is_iterm()) {
152 0
        is_iterm_dark()
153
      } else {
154 1
        FALSE
155
      }
156
    }
157 1
  }, error = function(e) FALSE)
158

159 1
  isTRUE(dark)
160
}
161

162
theme_code <- function(dark) {
163 1
  if (dark) {
164 0
    list("background-color" = "#232323", color = "#d0d0d0")
165
  } else{
166 1
    list("background-color" = "#e8e8e8", color = "#202020")
167
  }
168
}
169

170
theme_code_tick <- function(dark) {
171 1
  modifyList(theme_code(dark), list(before = "`", after = "`"))
172
}
173

174
theme_function <- function(dark) {
175 1
  modifyList(theme_code(dark), list(before = "`", after = "()`"))
176
}
177

178
format_r_code <- function(dark) {
179 1
  function(x) {
180 1
    x <- crayon::strip_style(x)
181 1
    lines <- unlist(strsplit(x, "\n", fixed = TRUE))
182 1
    tryCatch(prettycode::highlight(lines), error = function(x) lines)
183
  }
184
}
185

186
format_code <- function(dark) {
187 1
  function(x) {
188 0
    unlist(strsplit(x, "\n", fixed = TRUE))
189
  }
190
}
191

192
theme_create <- function(theme) {
193 1
  mtheme <- theme
194 1
  mtheme[] <- lapply(mtheme, create_formatter)
195 1
  selectors <- names(theme)
196 1
  res <- data.frame(
197 1
    stringsAsFactors = FALSE,
198 1
    selector = as.character(selectors),
199 1
    parsed = I(lapply(selectors, parse_selector) %||% list()),
200 1
    style = I(mtheme %||% list()),
201 1
    cnt = rep(NA_character_, length(selectors))
202
  )
203

204 1
  rownames(res) <- NULL
205 1
  res
206
}
207

208
#' @importFrom crayon bold italic underline make_style combine_styles
209

210
create_formatter <- function(x) {
211 1
  is_bold <- identical(x[["font-weight"]], "bold")
212 1
  is_italic <- identical(x[["font-style"]], "italic")
213 1
  is_underline <- identical(x[["text-decoration"]], "underline")
214 1
  is_color <- "color" %in% names(x)
215 1
  is_bg_color <- "background-color" %in% names(x)
216

217 1
  if (!is_bold && !is_italic && !is_underline && !is_color
218 1
      && !is_bg_color) return(x)
219

220 1
  fmt <- c(
221 1
    if (is_bold) list(bold),
222 1
    if (is_italic) list(italic),
223 1
    if (is_underline) list(underline),
224 1
    if (is_color) make_style(x[["color"]]),
225 1
    if (is_bg_color) make_style(x[["background-color"]], bg = TRUE)
226
  )
227

228 1
  new_fmt <- do.call(combine_styles, fmt)
229

230 1
  if (is.null(x[["fmt"]])) {
231 1
    x[["fmt"]] <- new_fmt
232
  } else {
233 1
    orig_fmt <- x[["fmt"]]
234 1
    x[["fmt"]] <- function(x) orig_fmt(new_fmt(x))
235
  }
236

237 1
  x
238
}
239

240
#' @importFrom utils modifyList
241

242
merge_embedded_styles <- function(old, new) {
243
  # before and after is not inherited,
244
  # side margins are additive, class mappings are merged
245
  # rest is updated, counter is reset
246 1
  old$before <- old$after <- NULL
247

248 1
  top <- new$`margin-top` %||% 0L
249 1
  bottom <- new$`margin-bottom` %||% 0L
250 1
  left <- (old$`margin-left` %||% 0L) + (new$`margin-left` %||% 0L)
251 1
  right <- (old$`margin-right` %||% 0L) + (new$`margin-right` %||% 0L)
252

253 1
  map <- modifyList(old$`class-map` %||% list(), new$`class-map` %||% list())
254

255 1
  start <- new$start %||% 1L
256

257 1
  mrg <- modifyList(old, new)
258 1
  mrg[c("margin-top", "margin-bottom", "margin-left", "margin-right",
259 1
        "start", "class-map")] <- list(top, bottom, left, right, start, map)
260

261
  ## Formatter needs to be re-generated
262 1
  create_formatter(mrg)
263
}
264

265
#' Parse a CSS3-like selector
266
#'
267
#' This is the rather small subset of CSS3 that is supported:
268
#'
269
#' Selectors:
270
#'
271
#' * Type selectors, e.g. `input` selects all `<input>` elements.
272
#' * Class selectors, e.g. `.index` selects any element that has a class
273
#'   of "index".
274
#' * ID selector. `#toc` will match the element that has the ID "toc".
275
#'
276
#' Combinators:
277
#'
278
#' * Descendant combinator, i.e. the space, that combinator selects nodes
279
#'   that are descendants of the first element. E.g. `div span` will match
280
#'   all `<span>` elements that are inside a `<div>` element.
281
#'
282
#' @param x CSS3-like selector string.
283
#'
284
#' @keywords internal
285

286
parse_selector <- function(x) {
287 1
  lapply(strsplit(x, " ", fixed = TRUE)[[1]], parse_selector_node)
288
}
289

290
parse_selector_node <- function(x) {
291

292 1
  parse_ids <- function(y) {
293 1
    r <- strsplit(y, "#", fixed = TRUE)[[1]]
294 1
    if (length(r) > 1) r[-1] <- paste0("#", r[-1])
295 1
    r
296
  }
297

298 1
  parts <- strsplit(x, ".", fixed = TRUE)[[1]]
299 1
  if (length(parts) > 1) parts[-1] <- paste0(".", parts[-1])
300 1
  parts <- unlist(lapply(parts, parse_ids))
301 1
  parts <- parts[parts != ""]
302

303 1
  m_cls <- grepl("^\\.", parts)
304 1
  m_ids <- grepl("^#", parts)
305

306 1
  list(tag = as.character(unique(parts[!m_cls & !m_ids])),
307 1
       class = str_tail(unique(parts[m_cls])),
308 1
       id = str_tail(unique(parts[m_ids])))
309
}
310

311
#' Match a selector node to a container
312
#'
313
#' @param node Selector node, as parsed by `parse_selector_node()`.
314
#' @param cnt Container node, has elements `tag`, `id`, `class`.
315
#'
316
#' The selector node matches the container, if all these hold:
317
#'
318
#' * The id of the selector is missing or unique.
319
#' * The tag of the selector is missing or unique.
320
#' * The id of the container is missing or unique.
321
#' * The tag of the container is unique.
322
#' * If the selector specifies an id, it matches the id of the container.
323
#' * If the selector specifies a tag, it matxhes the tag of the container.
324
#' * If the selector specifies class names, the container has all these
325
#'   classes.
326
#'
327
#' @keywords internal
328

329
match_selector_node <- function(node, cnt) {
330 0
  if (length(node$id) > 1 || length(cnt$id) > 1) return(FALSE)
331 0
  if (length(node$tag) > 1 || length(cnt$tag) > 1) return(FALSE)
332 1
  all(node$id %in% cnt$id) &&
333 1
    all(node$tag %in% cnt$tag) &&
334 1
    all(node$class %in% cnt$class)
335
}
336

337
#' Match a selector to a container stack
338
#'
339
#' @param sels A list of selector nodes.
340
#' @param cnts A list of container nodes.
341
#'
342
#' The last selector in the list must match the last container, so we
343
#' do the matching from the back. This is because we use this function
344
#' to calculate the style of newly encountered containers.
345
#'
346
#' @keywords internal
347

348
match_selector <- function(sels, cnts) {
349 1
  sptr <- length(sels)
350 1
  cptr <- length(cnts)
351 1
  while (sptr != 0L && sptr <= cptr) {
352 1
    if (match_selector_node(sels[[sptr]], cnts[[cptr]])) {
353 1
      sptr <- sptr - 1L
354 1
      cptr <- cptr - 1L
355
    } else {
356 1
      cptr <- cptr - 1L
357
    }
358
  }
359

360 1
  sptr == 0
361
}

Read our documentation on viewing source code .

Loading