#' List the currently active themes
#'
#' If there is no active app, then it calls [start_app()].
#'
#' @return A list of data frames with the active themes.
#' Each data frame row is a style that applies to selected CLI tree nodes.
#' Each data frame has columns:
#' * `selector`: The original CSS-like selector string. See [themes].
#' * `parsed`: The parsed selector, as used by cli for matching to nodes.
#' * `style`: The original style.
#' * `cnt`: The id of the container the style is currently applied to, or
#' `NA` if the style is not used.
#'
#' @export
#' @seealso [themes]
cli_list_themes <- function() {
app <- default_app() %||% start_app()
app$list_themes()
}
clii_list_themes <- function(app) {
app$themes
}
clii_add_theme <- function(app, theme) {
id <- new_uuid()
app$themes <-
c(app$themes, structure(list(theme_create(theme)), names = id))
id
}
clii_remove_theme <- function(app, id) {
if (! id %in% names(app$themes)) return(invisible(FALSE))
app$themes[[id]] <- NULL
invisible(TRUE)
}
#' The built-in CLI theme
#'
#' This theme is always active, and it is at the bottom of the theme
#' stack. See [themes].
#'
#' # Showcase
#'
#' ```{asciicast builtin-theme}
#' cli_h1("Heading 1")
#' cli_h2("Heading 2")
#' cli_h3("Heading 3")
#'
#' cli_par()
#' cli_alert_danger("Danger alert")
#' cli_alert_warning("Warning alert")
#' cli_alert_info("Info alert")
#' cli_alert_success("Success alert")
#' cli_alert("Alert for starting a process or computation",
#' class = "alert-start")
#' cli_end()
#'
#' cli_text("Packages and versions: {.pkg cli} {.version 1.0.0}.")
#' cli_text("Time intervals: {.timestamp 3.4s}")
#'
#' cli_text("{.emph Emphasis} and {.strong strong emphasis}")
#'
#' cli_text("This is a piece of code: {.code sum(x) / length(x)}")
#' cli_text("Function names: {.fn cli::simple_theme}")
#'
#' cli_text("Files: {.file /usr/bin/env}")
#' cli_text("URLs: {.url https://r-project.org}")
#'
#' cli_h2("Longer code chunk")
#' cli_par(class = "code R")
#' cli_verbatim(
#' '# window functions are useful for grouped mutates',
#' 'mtcars %>%',
#' ' group_by(cyl) %>%',
#' ' mutate(rank = min_rank(desc(mpg)))')
#' ```
#'
#' @seealso [themes], [simple_theme()].
#' @return A named list, a CLI theme.
#'
#' @param dark Whether to use a dark theme. The `cli.theme_dark` option
#' can be used to request a dark theme explicitly. If this is not set,
#' or set to `"auto"`, then cli tries to detect a dark theme, this
#' works in recent RStudio versions and in iTerm on macOS.
#' @export
builtin_theme <- function(dark = getOption("cli.theme_dark", "auto")) {
dark <- detect_dark_theme(dark)
list(
body = list(
"class-map" = list(
fs_path = "file",
"cli-progress-bar" = "progress-bar"
)
),
h1 = list(
"font-weight" = "bold",
"margin-top" = 1,
"margin-bottom" = 0,
fmt = function(x) cli::rule(x, line_col = "cyan")),
h2 = list(
"font-weight" = "bold",
"margin-top" = 1,
"margin-bottom" = 1,
fmt = function(x) paste0(symbol$line, symbol$line, " ", x, " ",
symbol$line, symbol$line)),
h3 = list(
"margin-top" = 1,
fmt = function(x) paste0(symbol$line, symbol$line, " ", x, " ")),
".alert" = list(
before = function() paste0(symbol$arrow_right, " ")
),
".alert-success" = list(
before = function() paste0(col_green(symbol$tick), " ")
),
".alert-danger" = list(
before = function() paste0(col_red(symbol$cross), " ")
),
".alert-warning" = list(
before = function() paste0(col_yellow("!"), " ")
),
".alert-info" = list(
before = function() paste0(col_cyan(symbol$info), " ")
),
".bullets .bullet-empty" = list(),
".bullets .bullet-space" = list("margin-left" = 2),
".bullets .bullet-v" = list(
"text-exdent" = 2,
before = function(x) paste0(col_green(symbol$tick), " ")
),
".bullets .bullet-x" = list(
"text-exdent" = 2,
before = function(x) paste0(col_red(symbol$cross), " ")
),
".bullets .bullet-!" = list(
"text-exdent" = 2,
before = function(x) paste0(col_yellow("!"), " ")
),
".bullets .bullet-i" = list(
"text-exdent" = 2,
before = function(x) paste0(col_cyan(symbol$info), " ")
),
".bullets .bullet-*" = list(
"text-exdent" = 2,
before = function(x) paste0(col_cyan(symbol$bullet), " ")
),
".bullets .bullet->" = list(
"text-exdent" = 2,
before = function(x) paste0(symbol$arrow_right, " ")
),
".bullets .bullet-1" = list(
),
par = list("margin-top" = 0, "margin-bottom" = 1),
ul = list(
"list-style-type" = function() symbol$bullet
),
# these are tags in HTML, but in cli they are inline
span.dt = list(postfix = ": "),
span.dd = list(),
# This means that list elements have a margin, if they are nested
"ul ul li" = list("margin-left" = 2),
"ul ol li" = list("margin-left" = 2),
"ul dl li" = list("margin-left" = 2),
"ol ul li" = list("margin-left" = 2),
"ol ol li" = list("margin-left" = 2),
"ol dl li" = list("margin-left" = 2),
"ol ul li" = list("margin-left" = 2),
"ol ol li" = list("margin-left" = 2),
"ol dl li" = list("margin-left" = 2),
blockquote = list("padding-left" = 4L, "padding-right" = 10L,
"font-style" = "italic", "margin-top" = 1L,
"margin-bottom" = 1L,
before = function() symbol$dquote_left,
after = function() symbol$dquote_right),
"blockquote cite" = list(
before = function() paste0(symbol$em_dash, " "),
"font-style" = "italic",
"font-weight" = "bold"
),
.code = list(fmt = format_code(dark)),
.code.R = list(fmt = format_r_code(dark)),
span.emph = list("font-style" = "italic"),
span.strong = list("font-weight" = "bold"),
span.code = theme_code_tick(dark),
span.q = list(fmt = quote_weird_name2),
span.pkg = list(color = "blue"),
span.fn = theme_function(dark),
span.fun = theme_function(dark),
span.arg = theme_code_tick(dark),
span.kbd = list(before = "[", after = "]", color = "blue"),
span.key = list(before = "[", after = "]", color = "blue"),
span.file = theme_file(),
span.path = theme_file(),
span.email = list(
color = "blue",
transform = function(x) make_link(x, type = "email"),
fmt = quote_weird_name
),
span.url = list(
before = "<", after = ">",
color = "blue", "font-style" = "italic",
transform = function(x) make_link(x, type = "url")
),
span.href = list(
transform = function(x) make_link(x, type = "href")
),
span.help = list(
transform = function(x) make_link(x, type = "help")
),
span.topic = list(
transform = function(x) make_link(x, type = "topic")
),
span.vignette = list(
transform = function(x) make_link(x, type = "vignette")
),
span.run = list(
transform = function(x) make_link(x, type = "run")
),
span.var = theme_code_tick(dark),
span.col = theme_code_tick(dark),
span.str = list(fmt = encode_string),
span.envvar = theme_code_tick(dark),
span.val = list(
transform = function(x, ...) cli_format(x, ...),
color = "blue"
),
span.field = list(color = "green"),
span.cls = list(collapse = "/", color = "blue", before = "<", after = ">"),
"span.progress-bar" = list(
transform = theme_progress_bar,
color = "green"
),
span.obj_type_friendly = list(
transform = function(x) format_inline(typename(x))
),
span.type = list(
transform = function(x) format_inline(typename(x))
),
span.or = list("vec-sep2" = " or ", "vec-last" = ", or "),
span.timestamp = list(before = "[", after = "]", color = "grey")
)
}
encode_string <- function(x) {
encodeString(x, quote = "\"")
}
quote_weird_name0 <- function(x) {
x <- gsub(" ", "\u00a0", x)
x2 <- ansi_strip(x)
fc <- first_character(x2)
sc <- second_character(x2)
lc <- last_character(x2)
wfst <- !is_alnum(fc, ok = "~") || (fc == "~" && !is_alnum(sc))
wlst <- !is_alnum(lc)
if (wfst || wlst) {
lsp <- leading_space(x2)
tsp <- trailing_space(x2)
if (nzchar(lsp)) {
x <- paste0(
bg_blue(lsp),
ansi_substr(x, nchar(lsp) + 1, ansi_nchar(x))
)
}
if (nzchar(tsp)) {
x <- paste0(
ansi_substr(x, 1, ansi_nchar(x) - nchar(tsp)),
bg_blue(tsp)
)
}
}
list(x, wfst || wlst)
}
quote_weird_name <- function(x) {
x2 <- quote_weird_name0(x)
if (x2[[2]] || num_ansi_colors() == 1) {
x2[[1]] <- paste0("'", x2[[1]], "'")
}
x2[[1]]
}
quote_weird_name2 <- function(x) {
x2 <- quote_weird_name0(x)
paste0("\"", x2[[1]], "\"")
}
theme_progress_bar <- function(x, app, style) {
make_progress_bar(x$current / x$total, style = style)
}
detect_dark_theme <- function(dark) {
tryCatch({
if (dark == "auto") {
dark <- if (Sys.getenv("RSTUDIO", "0") == "1") {
get_rstudio_theme()$dark
} else if (is_iterm()) {
is_iterm_dark()
} else if (is_emacs()) {
Sys.getenv("ESS_BACKGROUND_MODE", "light") == "dark"
} else {
FALSE
}
}
}, error = function(e) FALSE)
isTRUE(dark)
}
theme_code <- function(dark) {
list()
}
tick_formatter <- function(x) {
tt <- grepl("`", x, fixed = TRUE) + 1L
t1 <- c("`", "`` ")[tt]
t2 <- c("`", " ``")[tt]
paste0(t1, x, t2)
}
tick_formatter_fun <- function(x) {
tt <- grepl("`", x, fixed = TRUE) + 1L
t1 <- c("`", "`` ")[tt]
t2 <- c("()`", " ()``")[tt]
paste0(t1, x, t2)
}
theme_code_tick <- function(dark) {
utils::modifyList(
theme_code(dark),
list(transform = tick_formatter)
)
}
theme_function <- function(dark) {
utils::modifyList(
theme_code(dark),
list(transform = function(x) tick_formatter_fun(make_link(x, type = "fun")))
)
}
theme_file <- function() {
list(
color = "blue",
transform = function(x) make_link(x, type = "file"),
fmt = quote_weird_name
)
}
format_r_code <- function(dark) {
function(x) {
x <- ansi_strip(x)
lines <- unlist(strsplit(x, "\n", fixed = TRUE))
code_highlight(lines)
}
}
format_code <- function(dark) {
function(x) {
unlist(strsplit(x, "\n", fixed = TRUE))
}
}
theme_create <- function(theme) {
mtheme <- theme
mtheme[] <- lapply(mtheme, create_formatter)
selectors <- names(theme)
res <- data.frame(
stringsAsFactors = FALSE,
selector = as.character(selectors),
parsed = I(lapply(selectors, parse_selector) %||% list()),
style = I(mtheme %||% list()),
cnt = rep(NA_character_, length(selectors))
)
rownames(res) <- NULL
res
}
create_formatter <- function(x) {
is_bold <- identical(x[["font-weight"]], "bold")
is_italic <- identical(x[["font-style"]], "italic")
is_underline <- identical(x[["text-decoration"]], "underline")
is_color <- "color" %in% names(x)
is_bg_color <- "background-color" %in% names(x)
if (!is_bold && !is_italic && !is_underline && !is_color
&& !is_bg_color) return(x)
if (is_color && is.null(x[["color"]])) {
x[["color"]] <- "none"
}
if (is_bg_color && is.null(x[["background-color"]])) {
x[["background-color"]] <- "none"
}
fmt <- c(
if (is_bold) list(style_bold),
if (is_italic) list(style_italic),
if (is_underline) list(style_underline),
if (is_color) make_ansi_style(x[["color"]]),
if (is_bg_color) make_ansi_style(x[["background-color"]], bg = TRUE)
)
new_fmt <- do.call(combine_ansi_styles, fmt)
if (is.null(x[["fmt"]])) {
x[["fmt"]] <- new_fmt
} else {
orig_fmt <- x[["fmt"]]
x[["fmt"]] <- function(x) orig_fmt(new_fmt(x))
}
x
}
merge_embedded_styles <- function(old, new) {
# before and after is not inherited, fmt is not inherited, either
# side margins are additive, class mappings are merged
# rest is updated, counter is reset, prefix and postfix are merged
old$before <- old$after <- old$fmt <- NULL
old$transform <- NULL
# these will be applied on the container, so we don't need them inside
old$color <- old$`background-color` <- NULL
top <- new$`margin-top` %||% 0L
bottom <- new$`margin-bottom` %||% 0L
left <- (old$`margin-left` %||% 0L) + (new$`margin-left` %||% 0L)
right <- (old$`margin-right` %||% 0L) + (new$`margin-right` %||% 0L)
prefix <- paste0(old$prefix, new$prefix)
postfix <- paste0(new$postfix, old$postfix)
map <- utils::modifyList(old$`class-map` %||% list(), new$`class-map` %||% list())
start <- new$start %||% 1L
mrg <- utils::modifyList(old, new)
mrg[c("margin-top", "margin-bottom", "margin-left", "margin-right",
"start", "class-map", "prefix", "postfix")] <-
list(top, bottom, left, right, start, map, prefix, postfix)
## Formatter needs to be re-generated
create_formatter(mrg)
}
#' Parse a CSS3-like selector
#'
#' This is the rather small subset of CSS3 that is supported:
#'
#' Selectors:
#'
#' * Type selectors, e.g. `input` selects all `<input>` elements.
#' * Class selectors, e.g. `.index` selects any element that has a class
#' of "index".
#' * ID selector. `#toc` will match the element that has the ID `"toc"`.
#'
#' Combinators:
#'
#' * Descendant combinator, i.e. the space, that combinator selects nodes
#' that are descendants of the first element. E.g. `div span` will match
#' all `<span>` elements that are inside a `<div>` element.
#'
#' @param x CSS3-like selector string.
#'
#' @keywords internal
parse_selector <- function(x) {
lapply(strsplit(x, " ", fixed = TRUE)[[1]], parse_selector_node)
}
parse_selector_node <- function(x) {
parse_ids <- function(y) {
r <- strsplit(y, "#", fixed = TRUE)[[1]]
if (length(r) > 1) r[-1] <- paste0("#", r[-1])
r
}
parts <- strsplit(x, ".", fixed = TRUE)[[1]]
if (length(parts) > 1) parts[-1] <- paste0(".", parts[-1])
parts <- unlist(lapply(parts, parse_ids))
parts <- parts[parts != ""]
m_cls <- grepl("^\\.", parts)
m_ids <- grepl("^#", parts)
list(tag = as.character(unique(parts[!m_cls & !m_ids])),
class = str_tail(unique(parts[m_cls])),
id = str_tail(unique(parts[m_ids])))
}
#' Match a selector node to a container
#'
#' @param node Selector node, as parsed by `parse_selector_node()`.
#' @param cnt Container node, has elements `tag`, `id`, `class`.
#'
#' The selector node matches the container, if all these hold:
#'
#' * The id of the selector is missing or unique.
#' * The tag of the selector is missing or unique.
#' * The id of the container is missing or unique.
#' * The tag of the container is unique.
#' * If the selector specifies an id, it matches the id of the container.
#' * If the selector specifies a tag, it matches the tag of the container.
#' * If the selector specifies class names, the container has all these
#' classes.
#'
#' @keywords internal
match_selector_node <- function(node, cnt) {
if (length(node$id) > 1 || length(cnt$id) > 1) return(FALSE)
if (length(node$tag) > 1 || length(cnt$tag) > 1) return(FALSE)
all(node$id %in% cnt$id) &&
all(node$tag %in% cnt$tag) &&
all(node$class %in% cnt$class)
}
#' Match a selector to a container stack
#'
#' @param sels A list of selector nodes.
#' @param cnts A list of container nodes.
#'
#' The last selector in the list must match the last container, so we
#' do the matching from the back. This is because we use this function
#' to calculate the style of newly encountered containers.
#'
#' @keywords internal
match_selector <- function(sels, cnts) {
sptr <- length(sels)
cptr <- length(cnts)
# Last selector must match the last container
if (sptr == 0 || sptr > cptr) return(FALSE)
match <- match_selector_node(sels[[sptr]], cnts[[cptr]])
if (!match) return (FALSE)
# Plus the rest should match somehow
sptr <- sptr - 1L
cptr <- cptr - 1L
while (sptr != 0L && sptr <= cptr) {
match <- match_selector_node(sels[[sptr]], cnts[[cptr]])
if (match) {
sptr <- sptr - 1L
cptr <- cptr - 1L
} else {
cptr <- cptr - 1L
}
}
sptr == 0
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.