1#' Display a call (or expression) as a tree.
2#'
3#' \code{ast_} takes a quoted expression; \code{ast} does the quoting
4#' for you.
5#'
6#' @param x Quoted call, list of calls, or expression to display.
7#' @param width Display width, defaults to current width as reported by
8#'   \code{getOption("width")}.
9#' @export
10#' @examples
11#' ast(f(x, 1, g(), h(i())))
12#' ast(if (TRUE) 3 else 4)
13#' ast(function(a = 1, b = 2) {a + b + 10})
14#' ast(f(x)(y)(z))
15#'
16#' ast_(quote(f(x, 1, g(), h(i()))))
17#' ast_(quote(if (TRUE) 3 else 4))
18#' ast_(expression(1, 2, 3))
19ast_ <- function(x, width = getOption("width")) {
20  if (is.expression(x) || is.list(x)) {
21    trees <- vapply(x, tree, character(1), width = width)
22    out <- paste0(trees, collapse = "\n\n")
23  } else {
24    out <- tree(x, width = width)
25  }
26
27  cat(out, "\n")
28}
29
30#' @rdname ast_
31#' @export
32ast <- function(x) ast_(expr_find(x))
33
34tree <- function(x, level = 1, width = getOption("width"), branch = "\u2517 ") {
35  if (is_atomic(x) && length(x) == 1) {
36    label <- paste0(" ", deparse(x)[1])
37    children <- NULL
38  } else if (is_name(x)) {
39    x <- as.character(x)
40    if (x == "") {
41      # Special case the missing argument
42      label <- "`MISSING"
43    } else {
44      label <- paste0("`", as.character(x))
45    }
46
47    children <- NULL
48  } else if (is_call(x)) {
49    label <- "()"
50    children <-  vapply(as.list(x), tree, character(1),
51      level = level + 1, width = width - 3)
52  } else if (is_pairlist(x)) {
53    label <- "[]"
54
55    branches <- paste("\u2517", format(names(x)), "=")
56    children <- character(length(x))
57    for (i in seq_along(x)) {
58      children[i] <- tree(x[[i]], level = level + 1, width = width - 3,
59        branch = branches[i])
60    }
61  } else {
62    # Special case for srcrefs, since they're commonly seen
63    if (inherits(x, "srcref")) {
64      label <- "<srcref>"
65    } else {
66      label <- paste0("<", typeof(x), ">")
67    }
68    children <- NULL
69  }
70
71  indent <- paste0(str_dup(" ", level - 1), branch)
72  label <- str_trunc(label, width - 3)
73
74  if (is.null(children)) {
75    paste0(indent, label)
76  } else {
77    paste0(indent, label, "\n", paste0(children, collapse = "\n"))
78  }
79}
80
81str_trunc <- function(x, width = getOption("width")) {
82  ifelse(nchar(x) <= width, x, paste0(substr(x, 1, width - 3), "..."))
83}
84
85str_dup <- function(x, n) {
86  paste0(rep(x, n), collapse = "")
87}
88