1#' Does an object inherit from a set of classes?
2#'
3#' @description
4#'
5#' * `inherits_any()` is like [base::inherits()] but is more explicit
6#'   about its behaviour with multiple classes. If `classes` contains
7#'   several elements and the object inherits from at least one of
8#'   them, `inherits_any()` returns `TRUE`.
9#'
10#' * `inherits_all()` tests that an object inherits from all of the
11#'   classes in the supplied order. This is usually the best way to
12#'   test for inheritance of multiple classes.
13#'
14#' * `inherits_only()` tests that the class vectors are identical. It
15#'   is a shortcut for `identical(class(x), class)`.
16#'
17#' @param x An object to test for inheritance.
18#' @param class A character vector of classes.
19#'
20#' @export
21#' @examples
22#' obj <- structure(list(), class = c("foo", "bar", "baz"))
23#'
24#' # With the _any variant only one class must match:
25#' inherits_any(obj, c("foobar", "bazbaz"))
26#' inherits_any(obj, c("foo", "bazbaz"))
27#'
28#' # With the _all variant all classes must match:
29#' inherits_all(obj, c("foo", "bazbaz"))
30#' inherits_all(obj, c("foo", "baz"))
31#'
32#' # The order of classes must match as well:
33#' inherits_all(obj, c("baz", "foo"))
34#'
35#' # inherits_only() checks that the class vectors are identical:
36#' inherits_only(obj, c("foo", "baz"))
37#' inherits_only(obj, c("foo", "bar", "baz"))
38inherits_any <- function(x, class) {
39  if (is_empty(class)) {
40    abort("`class` can't be empty")
41  }
42  inherits(x, class)
43}
44#' @rdname inherits_any
45#' @export
46inherits_all <- function(x, class) {
47  if (is_empty(class)) {
48    abort("`class` can't be empty")
49  }
50
51  idx <- inherits(x, class, which = TRUE)
52  cummax <- cummax(idx)
53
54  cummax[[1]] != 0L && all(idx == cummax)
55}
56#' @rdname inherits_any
57#' @export
58inherits_only <- function(x, class) {
59  identical(class(x), class)
60}
61
62#' Box a value
63#'
64#' `new_box()` is similar to [base::I()] but it protects a value by
65#' wrapping it in a scalar list rather than by adding an attribute.
66#' `unbox()` retrieves the boxed value. `is_box()` tests whether an
67#' object is boxed with optional class. `as_box()` ensures that a
68#' value is wrapped in a box. `as_box_if()` does the same but only if
69#' the value matches a predicate.
70#'
71#' @name box
72#' @param x,.x An R object.
73#' @param class For `new_box()`, an additional class for the
74#'   boxed value (in addition to `rlang_box`). For `is_box()`, a class
75#'   or vector of classes passed to [inherits_all()].
76#' @param ... Additional attributes passed to [base::structure()].
77#' @export
78#' @examples
79#' boxed <- new_box(letters, "mybox")
80#' is_box(boxed)
81#' is_box(boxed, "mybox")
82#' is_box(boxed, "otherbox")
83#'
84#' unbox(boxed)
85#'
86#' # as_box() avoids double-boxing:
87#' boxed2 <- as_box(boxed, "mybox")
88#' boxed2
89#' unbox(boxed2)
90#'
91#' # Compare to:
92#' boxed_boxed <- new_box(boxed, "mybox")
93#' boxed_boxed
94#' unbox(unbox(boxed_boxed))
95#'
96#' # Use `as_box_if()` with a predicate if you need to ensure a box
97#' # only for a subset of values:
98#' as_box_if(NULL, is_null, "null_box")
99#' as_box_if("foo", is_null, "null_box")
100new_box <- function(.x, class = NULL, ...) {
101  structure(
102    list(.x),
103    class = c(class, "rlang_box"),
104    ...
105  )
106}
107#' @rdname box
108#' @export
109is_box <- function(x, class = NULL) {
110  inherits_all(x, c(class, "rlang_box"))
111}
112#' @rdname box
113#' @param box A boxed value to unbox.
114#' @export
115unbox <- function(box) {
116  if (!inherits(box, "rlang_box")) {
117    abort("`box` must be a box")
118  }
119  box[[1]]
120}
121print.box <- function(x, ...) {
122  cat_line("<box>")
123  print(unbox(x))
124}
125
126#' Convert object to a box
127#'
128#' @description
129#'
130#' * `as_box()` boxes its input only if it is not already a box. The
131#'   class is also checked if supplied.
132#'
133#' * `as_box_if()` boxes its input only if it not already a box, or if
134#'   the predicate `.p` returns `TRUE`.
135#'
136#' @inheritParams box
137#' @param class,.class A box class. If the input is already a box of
138#'   that class, it is returned as is. If the input needs to be boxed,
139#'   `class` is passed to [new_box()].
140#'
141#' @export
142as_box <- function(x, class = NULL) {
143  if (is_box(x, class)) {
144    x
145  } else {
146    new_box(x, class)
147  }
148}
149#' @rdname as_box
150#' @param .p A predicate function.
151#' @param ... Arguments passed to `.p`.
152#' @export
153as_box_if <- function(.x, .p, .class = NULL, ...) {
154  .p <- as_predicate(.p)
155  if (is_box(.x, .class) || !.p(.x, ...)) {
156    .x
157  } else {
158    new_box(.x, .class)
159  }
160}
161
162#' Box a final value for early termination
163#'
164#' @description
165#'
166#' A value boxed with `done()` signals to its caller that it
167#' should stop iterating. Use it to shortcircuit a loop.
168#'
169#' @param x For `done()`, a value to box. For `is_done_box()`, a
170#'   value to test.
171#' @return A [boxed][new_box] value.
172#'
173#' @examples
174#' done(3)
175#'
176#' x <- done(3)
177#' is_done_box(x)
178#' @export
179done <- function(x) {
180  new_box(
181    maybe_missing(x),
182    class = "rlang_box_done",
183    empty = missing(x)
184  )
185}
186#' @rdname done
187#' @param empty Whether the box is empty. If `NULL`, `is_done_box()`
188#'   returns `TRUE` for all done boxes. If `TRUE`, it returns `TRUE`
189#'   only for empty boxes. Otherwise it returns `TRUE` only for
190#'   non-empty boxes.
191#' @export
192is_done_box <- function(x, empty = NULL) {
193  if (!inherits(x, "rlang_box_done")) {
194    return(FALSE)
195  }
196
197  if (is_null(empty)) {
198    return(TRUE)
199  }
200
201  attr(x, "empty") == empty
202}
203#' @export
204print.rlang_box_done <- function(x, ...) {
205  cat_line("<done>")
206  print(unbox(x))
207}
208
209#' Create zap objects
210#'
211#' @description
212#'
213#' `zap()` creates a sentinel object that indicates that an object
214#' should be removed. For instance, named zaps instruct [env_bind()]
215#' and [call_modify()] to remove those objects from the environment or
216#' the call.
217#'
218#' The advantage of zap objects is that they unambiguously signal the
219#' intent of removing an object. Sentinels like `NULL` or
220#' [missing_arg()] are ambiguous because they represent valid R
221#' objects.
222#'
223#' @param x An object to test.
224#'
225#' @export
226#' @examples
227#' # Create one zap object:
228#' zap()
229#'
230#' # Create a list of zaps:
231#' rep(list(zap()), 3)
232#' rep_named(c("foo", "bar"), list(zap()))
233zap <- function() {
234  `zap!`
235}
236#' @rdname zap
237#' @export
238is_zap <- function(x) {
239  inherits(x, "rlang_zap")
240}
241
242`zap!` <- structure(list(), class = "rlang_zap")
243
244#' @export
245print.rlang_zap <- function(x, ...) {
246  cat_line("<zap>")
247}
248