1#' Helpers for pairlist and language nodes
2#'
3#' @description
4#'
5#' **Important**: These functions are for expert R programmers only.
6#' You should only use them if you feel comfortable manipulating low
7#' level R data structures at the C level. We export them at the R level
8#' in order to make it easy to prototype C code. They don't perform
9#' any type checking and can crash R very easily (try to take the CAR
10#' of an integer vector --- save any important objects beforehand!).
11#'
12#' @param x A language or pairlist node. Note that these functions are
13#'   barebones and do not perform any type checking.
14#' @param car,newcar,cdr,newcdr The new CAR or CDR for the node. These
15#'   can be any R objects.
16#' @param newtag The new tag for the node. This should be a symbol.
17#' @return Setters like `node_poke_car()` invisibly return `x` modified
18#'   in place. Getters return the requested node component.
19#' @seealso [duplicate()] for creating copy-safe objects and
20#'   [base::pairlist()] for an easier way of creating a linked list of
21#'   nodes.
22#' @keywords internal
23#' @export
24new_node <- function(car, cdr = NULL) {
25  .Call(rlang_new_node, car, cdr)
26}
27
28#' @rdname new_node
29#' @export
30node_car <- function(x) {
31  .Call(rlang_node_car, x)
32}
33#' @rdname new_node
34#' @export
35node_cdr <- function(x) {
36  .Call(rlang_node_cdr, x)
37}
38#' @rdname new_node
39#' @export
40node_caar <- function(x) {
41  .Call(rlang_node_caar, x)
42}
43#' @rdname new_node
44#' @export
45node_cadr <- function(x) {
46  .Call(rlang_node_cadr, x)
47}
48#' @rdname new_node
49#' @export
50node_cdar <- function(x) {
51  .Call(rlang_node_cdar, x)
52}
53#' @rdname new_node
54#' @export
55node_cddr <- function(x) {
56  .Call(rlang_node_cddr, x)
57}
58
59#' @rdname new_node
60#' @export
61node_poke_car <- function(x, newcar) {
62  invisible(.Call(rlang_node_poke_car, x, newcar))
63}
64#' @rdname new_node
65#' @export
66node_poke_cdr <- function(x, newcdr) {
67  invisible(.Call(rlang_node_poke_cdr, x, newcdr))
68}
69#' @rdname new_node
70#' @export
71node_poke_caar <- function(x, newcar) {
72  invisible(.Call(rlang_node_poke_caar, x, newcar))
73}
74#' @rdname new_node
75#' @export
76node_poke_cadr <- function(x, newcar) {
77  invisible(.Call(rlang_node_poke_cadr, x, newcar))
78}
79#' @rdname new_node
80#' @export
81node_poke_cdar <- function(x, newcdr) {
82  invisible(.Call(rlang_node_poke_cdar, x, newcdr))
83}
84#' @rdname new_node
85#' @export
86node_poke_cddr <- function(x, newcdr) {
87  invisible(.Call(rlang_node_poke_cddr, x, newcdr))
88}
89
90node_get <- function(node, i) {
91  if (node < 1L) {
92    abort("`i` must be an integer greater than 0.")
93  }
94  while (i > 1L) {
95    node <- node_cdr(node)
96    i <- i - 1L
97  }
98  node
99}
100node_get_car <- function(node, i) {
101  node_car(node_get(node, i))
102}
103
104#' @rdname new_node
105#' @export
106node_tag <- function(x) {
107  .Call(rlang_node_tag, x)
108}
109#' @rdname new_node
110#' @export
111node_poke_tag <- function(x, newtag) {
112  invisible(.Call(rlang_node_poke_tag, x, newtag))
113}
114
115#' Coerce to pairlist
116#'
117#' This transforms vector objects to a linked pairlist of nodes. See
118#' the [pairlist][node] type help page.
119#'
120#'
121#' @keywords internal
122#' @section Life cycle:
123#'
124#' `as_pairlist()` is experimental because we are still figuring out
125#' the naming scheme for pairlists and node-like objects.
126#'
127#' @param x An object to coerce.
128#' @export
129as_pairlist <- function(x) {
130  if (! typeof(x) %in% c(atomic_types, "list", "pairlist", "NULL")) {
131    abort_coercion(x, "pairlist")
132  }
133  as.vector(x, "pairlist")
134}
135
136#' Is object a node or pairlist?
137#'
138#' @description
139#'
140#' * `is_pairlist()` checks that `x` has type `pairlist`.
141#'
142#' * `is_node()` checks that `x` has type `pairlist` or `language`.
143#'    It tests whether `x` is a node that has a CAR and a CDR,
144#'    including callable nodes (language objects).
145#'
146#' * `is_node_list()` checks that `x` has type `pairlist` or `NULL`.
147#'   `NULL` is the empty node list.
148#'
149#'
150#' @section Life cycle:
151#'
152#' These functions are experimental. We are still figuring out a good
153#' naming convention to refer to the different lisp-like lists in R.
154#'
155#' @param x Object to test.
156#' @seealso [is_call()] tests for language nodes.
157#' @keywords internal
158#' @export
159is_pairlist <- function(x) {
160  typeof(x) == "pairlist"
161}
162#' @rdname is_pairlist
163#' @export
164is_node <- function(x) {
165  typeof(x) %in% c("pairlist", "language")
166}
167#' @rdname is_pairlist
168#' @export
169is_node_list <- function(x) {
170  typeof(x) %in% c("pairlist", "NULL")
171}
172
173# Shallow copy of node trees
174node_tree_clone <- function(x) {
175  .Call(rlang_node_tree_clone, x);
176}
177
178node_walk <- function(.x, .f, ...) {
179  cur <- .x
180  while (!is.null(cur)) {
181    .f(cur, ...)
182    cur <- node_cdr(cur)
183  }
184  NULL
185}
186node_walk_nonnull <- function(.x, .f, ...) {
187  cur <- .x
188  out <- NULL
189  while (!is.null(cur) && is.null(out)) {
190    out <- .f(cur, ...)
191    cur <- node_cdr(cur)
192  }
193  out
194}
195node_walk_last <- function(.x, .f, ...) {
196  cur <- .x
197  while (!is.null(node_cdr(cur))) {
198    cur <- node_cdr(cur)
199  }
200  .f(cur, ...)
201}
202
203node_append <- function(.x, .y) {
204  node_walk_last(.x, function(l) node_poke_cdr(l, .y))
205  .x
206}
207
208node_list_reverse <- function(x) {
209  .Call(rlang_pairlist_rev, x)
210}
211
212
213#' Create a new call from components
214#'
215#' @param car The head of the call. It should be a
216#'   [callable][is_callable] object: a symbol, call, or literal
217#'   function.
218#' @param cdr The tail of the call, i.e. a [node list][node] of
219#'   arguments.
220#'
221#' @keywords internal
222#' @export
223new_call <- function(car, cdr = NULL) {
224  .Call(rlang_new_call, car, cdr)
225}
226