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