1as.lazy <- function(x, env = baseenv()) UseMethod("as.lazy")
2as.lazy.lazy <- function(x, env = baseenv()) x
3as.lazy.formula <- function(x, env = baseenv()) lazy_(x[[2]], environment(x))
4as.lazy.character <- function(x, env = baseenv()) lazy_(parse(text = x)[[1]], env)
5as.lazy.call <- function(x, env = baseenv()) lazy_(x, env)
6as.lazy.name <- function(x, env = baseenv()) lazy_(x, env)
7as.lazy.numeric <- function(x, env = baseenv()) {
8  if (length(x) > 1) {
9    warning("Truncating vector to length 1", call. = FALSE)
10    x <- x[1]
11  }
12  lazy_(x, env)
13}
14as.lazy.logical <- as.lazy.numeric
15as.lazy_dots <- function(x, env) UseMethod("as.lazy_dots")
16as.lazy_dots.NULL <- function(x, env = baseenv()) {
17  structure(list(), class = "lazy_dots")
18}
19as.lazy_dots.list <- function(x, env = baseenv()) {
20  structure(lapply(x, as.lazy, env = env), class = "lazy_dots")
21}
22as.lazy_dots.name <- function(x, env = baseenv()) {
23  structure(list(as.lazy(x, env)), class = "lazy_dots")
24}
25as.lazy_dots.formula <- as.lazy_dots.name
26as.lazy_dots.call <- as.lazy_dots.name
27as.lazy_dots.lazy <- function(x, env = baseenv()) {
28  structure(list(x), class = "lazy_dots")
29}
30as.lazy_dots.character <- function(x, env = baseenv()) {
31  structure(lapply(x, as.lazy, env = env), class = "lazy_dots")
32}
33as.lazy_dots.lazy_dots <- function(x, env = baseenv()) {
34  x
35}
36all_dots <- function(.dots, ..., all_named = FALSE) {
37  dots <- as.lazy_dots(list(...))
38  if (!missing(.dots)) {
39    dots2 <- as.lazy_dots(.dots)
40    dots <- c(dots, dots2)
41  }
42
43  if (all_named) {
44    dots <- auto_name(dots)
45  }
46
47  dots
48
49}
50lazy_eval <- function(x, data = NULL) {
51  if (is.lazy_dots(x)) {
52    return(lapply(x, lazy_eval, data = data))
53  }
54
55  x <- as.lazy(x)
56
57  if (!is.null(data)) {
58    eval(x$expr, data, x$env)
59  } else {
60    eval(x$expr, x$env, emptyenv())
61  }
62}
63interp <- function(`_obj`, ..., .values) {
64  UseMethod("interp")
65}
66interp.call <- function(`_obj`, ..., .values) {
67  values <- all_values(.values, ...)
68
69  substitute_(`_obj`, values)
70}
71interp.name <- function(`_obj`, ..., .values) {
72  values <- all_values(.values, ...)
73
74  substitute_(`_obj`, values)
75}
76interp.formula <- function(`_obj`, ..., .values) {
77  values <- all_values(.values, ...)
78
79  `_obj`[[2]] <- substitute_(`_obj`[[2]], values)
80  `_obj`
81}
82interp.lazy <- function(`_obj`, ..., .values) {
83  values <- all_values(.values, ...)
84
85  `_obj`$expr <-  substitute_(`_obj`$expr, values)
86  `_obj`
87}
88interp.character <- function(`_obj`, ..., .values) {
89  values <- all_values(.values, ...)
90
91  expr1 <- parse(text = `_obj`)[[1]]
92  expr2 <- substitute_(expr1, values)
93  deparse(expr2)
94}
95substitute_ <- function(x, env) {
96  call <- substitute(substitute(x, env), list(x = x))
97  eval(call)
98}
99all_values <- function(.values, ...) {
100  if (missing(.values)) {
101    values <- list(...)
102  } else if (identical(.values, globalenv())) {
103    # substitute doesn't want to replace in globalenv
104    values <- as.list(globalenv())
105  } else {
106    values <- .values
107  }
108  # Replace lazy objects with their expressions
109  is_lazy <- vapply(values, is.lazy, logical(1))
110  values[is_lazy] <- lapply(values[is_lazy], `[[`, "expr")
111
112  values
113}
114missing_arg <- function() {
115  quote(expr = )
116}
117lazy_dots <- function(..., .follow_symbols = FALSE) {
118  if (nargs() == 0 || (nargs() == 1 &&  ! missing(.follow_symbols))) {
119    return(structure(list(), class = "lazy_dots"))
120  }
121
122  .Call(C_make_lazy_dots, environment(), .follow_symbols)
123}
124is.lazy_dots <- function(x) inherits(x, "lazy_dots")
125`[.lazy_dots` <- function(x, i) {
126  structure(NextMethod(), class = "lazy_dots")
127}
128`$<-.lazy_dots` <- function(x, i, value) {
129  value <- as.lazy(value, parent.frame())
130  x[[i]] <- value
131  x
132}
133`[<-.lazy_dots` <- function(x, i, value) {
134  value <- lapply(value, as.lazy, env = parent.frame())
135  NextMethod()
136}
137c.lazy_dots <- function(..., recursive = FALSE) {
138  structure(NextMethod(), class = "lazy_dots")
139}
140lazy_ <- function(expr, env) {
141  stopifnot(is.call(expr) || is.name(expr) || is.atomic(expr))
142
143  structure(list(expr = expr, env = env), class = "lazy")
144}
145lazy <- function(expr, env = parent.frame(), .follow_symbols = TRUE) {
146  .Call(C_make_lazy, quote(expr), environment(), .follow_symbols)
147}
148is.lazy <- function(x) inherits(x, "lazy")
149print.lazy <- function(x, ...) {
150  code <- deparse(x$expr)
151  if (length(code) > 1) {
152    code <- paste(code[[1]], "...")
153  }
154
155  cat("<lazy>\n")
156  cat("  expr: ", code, "\n", sep = "")
157  cat("  env:  ", format(x$env), "\n", sep = "")
158}
159make_call <- function(fun, args) {
160  stopifnot(is.call(fun) || is.name(fun))
161  args <- as.lazy_dots(args)
162  expr <- lapply(args, `[[`, "expr")
163
164  lazy_(
165    as.call(c(fun, expr)),
166    common_env(args)
167  )
168}
169common_env <- function(dots) {
170  if (!is.list(dots)) stop("dots must be a list", call. = FALSE)
171  if (length(dots) == 0) return(baseenv())
172
173  dots <- as.lazy_dots(dots)
174  env <- dots[[1]]$env
175  if (length(dots) == 1) return(env)
176
177  for (i in 2:length(dots)) {
178    if (!identical(env, dots[[i]]$env)) {
179      return(baseenv())
180    }
181  }
182  env
183}
184eval_call <- function(fun, dots, env = parent.frame()) {
185
186  vars <- paste0("x", seq_along(dots))
187  names(vars) <- names(dots)
188
189  # Create environment containing promises
190  env <- new.env(parent = env)
191  for(i in seq_along(dots)) {
192    dot <- dots[[i]]
193
194    assign_call <- substitute(
195      delayedAssign(vars[i], expr, dot$env, assign.env = env),
196      list(expr = dot$expr)
197    )
198    eval(assign_call)
199  }
200
201  args <- lapply(vars, as.symbol)
202  call <- as.call(c(fun, args))
203
204  eval(call, env)
205}
206auto_name <- function(x, max_width = 40) {
207  names(x) <- auto_names(x, max_width = max_width)
208  x
209}
210auto_names <- function(x, max_width = 40) {
211  x <- as.lazy_dots(x)
212
213  nms <- names(x) %||% rep("", length(x))
214
215  missing <- nms == ""
216  expr <- lapply(x[missing], `[[`, "expr")
217  nms[missing] <- vapply(expr, deparse_trunc, width = max_width,
218    FUN.VALUE = character(1), USE.NAMES = FALSE)
219
220  nms
221}
222deparse_trunc <- function(x, width = getOption("width")) {
223  if (is.symbol(x)) {
224    return(as.character(x))
225  }
226
227  text <- deparse(x, width.cutoff = width)
228  if (length(text) == 1 && nchar(text) < width) return(text)
229
230  paste0(substr(text[1], 1, width - 3), "...")
231}
232promise_expr <- function(prom) {
233  .Call(C_promise_expr_, prom)
234}
235
236promise_env <- function(prom) {
237  .Call(C_promise_env_, prom)
238}
239as.lazy.promise <- function(x, ...) {
240  lazy_(promise_expr(x), promise_env(x))
241}
242"%||%" <- function(x, y) if(is.null(x)) y else x
243