1# Given a list of quosures, return a function that will evaluate them and return
2# a list of resulting values. If the list contains a single expression, unwrap
3# it from the list.
4quos_to_func <- function(qs) {
5  if (length(qs) == 0) {
6    stop("Need at least one item in `...` to use as cache key or event.")
7  }
8
9  if (length(qs) == 1) {
10    # Special case for one quosure. This is needed for async to work -- that is,
11    # when the quosure returns a promise. It needs to not be wrapped into a list
12    # for the hybrid_chain stuff to detect that it's a promise. (Plus, it's not
13    # even clear what it would mean to mix promises and non-promises in the
14    # key.)
15    qs <- qs[[1]]
16    function() {
17      eval_tidy(qs)
18    }
19
20  } else {
21    function() {
22      lapply(qs, eval_tidy)
23    }
24  }
25}
26
27# Given a list of quosures, return a string representation of the expressions.
28#
29# qs <- list(quo(a+1), quo({ b+2; b + 3 }))
30# quos_to_label(qs)
31# #> [1] "a + 1, {\n    b + 2\n    b + 3\n}"
32quos_to_label <- function(qs) {
33  res <- lapply(qs, function(q) {
34    paste(deparse(get_expr(q)), collapse = "\n")
35  })
36
37  paste(res, collapse = ", ")
38}
39
40# Get the formals and body for a function, without source refs. This is used for
41# consistent hashing of the function.
42formalsAndBody <- function(x) {
43  if (is.null(x)) {
44    return(list())
45  }
46
47  list(
48    formals = formals(x),
49    body = body(zap_srcref(x))
50  )
51}
52
53
54#' @describeIn createRenderFunction convert a quosure to a function.
55#' @param q Quosure of the expression `x`. When capturing expressions to create
56#'   your quosure, it is recommended to use [`enquo0()`] to not unquote the
57#'   object too early. See [`enquo0()`] for more details.
58#' @inheritParams installExprFunction
59#' @export
60quoToFunction <- function(
61  q,
62  label = sys.call(-1)[[1]],
63  ..stacktraceon = FALSE
64) {
65  func <- quoToSimpleFunction(as_quosure(q))
66  wrapFunctionLabel(func, updateFunctionLabel(label), ..stacktraceon = ..stacktraceon, dots = FALSE)
67}
68
69updateFunctionLabel <- function(label) {
70  badFnName <- "anonymous"
71  if (all(is.language(label))) {
72    # Prevent immediately invoked functions like as.language(a()())
73    if (is.language(label) && length(label) > 1) {
74      return(badFnName)
75    }
76    label <- deparse(label, width.cutoff = 500L)
77  }
78  label <- as.character(label)
79  # Prevent function calls that are over one line; (Assignments are hard to perform)
80    # Prevent immediately invoked functions like "a()()"
81  if (length(label) > 1 || grepl("(", label, fixed = TRUE)) {
82    return(badFnName)
83  }
84  if (label == "NULL") {
85    return(badFnName)
86  }
87  label
88}
89
90quoToSimpleFunction <- function(q) {
91  # Should not use `new_function(list(), get_expr(q), get_env(q))` as extra logic
92  # is done by rlang to convert the quosure to a function within `as_function(q)`
93  fun <- as_function(q)
94
95  # If the quosure is empty, then the returned function can not be called.
96  # https://github.com/r-lib/rlang/issues/1244
97  if (quo_is_missing(q)) {
98    fn_body(fun) <- quote({})
99  }
100
101  # `as_function()` returns a function that takes `...`. We need one that takes no
102  # args.
103  fn_fmls(fun) <- list()
104
105  fun
106}
107
108
109#' Convert an expression to a function
110#'
111#' `r lifecycle::badge("superseded")` Please use [`installExprFunction()`] for a better
112#' debugging experience (Shiny 0.8.0). If the `expr` and `quoted` parameters are not needed, please see
113#' [`quoToFunction()`] (Shiny 1.6.0).
114#'
115#' Similar to [installExprFunction()] but doesn't register debug hooks.
116#'
117#' @param expr A quoted or unquoted expression, or a quosure.
118#' @param env The desired environment for the function. Defaults to the
119#'   calling environment two steps back.
120#' @param quoted Is the expression quoted?
121#' @seealso [`installExprFunction()`] for the modern approach to converting an expression to a function
122#' @export
123#' @keywords internal
124exprToFunction <- function(expr, env = parent.frame(), quoted = FALSE) {
125  # If `expr` is a raw quosure, must say `quoted = TRUE`; (env is ignored)
126  # If `inject()` a quosure, env is ignored, and quoted should be FALSE (aka ignored).
127  # Make article of usage
128  # * (by joe)
129
130  if (!quoted) {
131    expr <- eval(substitute(substitute(expr)), parent.frame())
132  }
133  # MUST call with `quoted = TRUE` as exprToQuo() will not reach high enough
134  q <- exprToQuo(expr, env, quoted = TRUE)
135
136  # MUST call `as_function()`. Can NOT call `new_function()`
137  # rlang has custom logic for handling converting a quosure to a function
138  quoToSimpleFunction(q)
139}
140# For internal use only; External users should be using `exprToFunction()` or `installExprFunction()`
141# MUST be the exact same logic as `exprToFunction()`, but without the `quoToSimpleFunction()` call
142exprToQuo <- function(expr, env = parent.frame(), quoted = FALSE) {
143  if (!quoted) {
144    expr <- eval(substitute(substitute(expr)), parent.frame())
145  }
146  q <-
147    if (is_quosure(expr)) {
148      # inject()ed quosure
149      # do nothing
150      expr
151    } else if (is.language(expr) || rlang::is_atomic(expr) || is.null(expr)) {
152      # Most common case...
153      new_quosure(expr, env = env)
154    } else {
155      stop("Don't know how to convert '", class(expr)[1], "' to a function; a quosure or quoted expression was expected")
156    }
157  q
158}
159
160#' @describeIn createRenderFunction converts a user's reactive `expr` into a
161#'   function that's assigned to a `name` in the `assign.env`.
162#'
163#' @param name The name the function should be given
164#' @param eval.env The desired environment for the function. Defaults to the
165#'   calling environment two steps back.
166#' @param assign.env The environment in which the function should be assigned.
167#' @param label A label for the object to be shown in the debugger. Defaults to
168#'   the name of the calling function.
169#' @param wrappedWithLabel,..stacktraceon Advanced use only. For stack manipulation purposes; see
170#'   [stacktrace()].
171#' @inheritParams exprToFunction
172#' @export
173installExprFunction <- function(expr, name, eval.env = parent.frame(2),
174                                quoted = FALSE,
175                                assign.env = parent.frame(1),
176                                label = sys.call(-1)[[1]],
177                                wrappedWithLabel = TRUE,
178                                ..stacktraceon = FALSE) {
179  if (!quoted) {
180    quoted <- TRUE
181    expr <- eval(substitute(substitute(expr)), parent.frame())
182  }
183
184  func <- exprToFunction(expr, eval.env, quoted)
185  if (length(label) > 1) {
186    # Just in case the deparsed code is more complicated than we imagine. If we
187    # have a label with length > 1 it causes warnings in wrapFunctionLabel.
188    label <- paste0(label, collapse = "\n")
189  }
190  wrappedWithLabel <- isTRUE(wrappedWithLabel)
191  if (wrappedWithLabel) {
192    func <- wrapFunctionLabel(func, updateFunctionLabel(label), ..stacktraceon = ..stacktraceon, dots = FALSE)
193  }
194  assign(name, func, envir = assign.env)
195  if (!wrappedWithLabel) {
196    registerDebugHook(name, assign.env, label)
197  }
198
199  invisible(func)
200}
201
202# Utility function for creating a debugging label, given an expression.
203# `expr` is a quoted expression.
204# `function_name` is the name of the calling function.
205# `label` is an optional user-provided label. If NULL, it will be inferred.
206exprToLabel <- function(expr, function_name, label = NULL) {
207  srcref <- attr(expr, "srcref", exact = TRUE)
208  if (is.null(label)) {
209    label <- rexprSrcrefToLabel(
210      srcref[[1]],
211      simpleExprToFunction(expr, function_name)
212    )
213  }
214  if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
215  attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
216  label
217}
218simpleExprToFunction <- function(expr, function_name) {
219  sprintf('%s(%s)', function_name, paste(deparse(expr), collapse='\n'))
220}
221
222installedFuncExpr <- function(func) {
223  fn_body(attr(func, "wrappedFunc", exact = TRUE))
224}
225
226funcToLabelBody <- function(func) {
227  paste(deparse(installedFuncExpr(func)), collapse='\n')
228}
229funcToLabel <- function(func, functionLabel, label = NULL) {
230  if (!is.null(label)) return(label)
231
232  sprintf(
233    '%s(%s)',
234    functionLabel,
235    funcToLabelBody(func)
236  )
237}
238quoToLabelBody <- function(q) {
239  paste(deparse(quo_get_expr(q)), collapse='\n')
240}
241quoToLabel <- function(q, functionLabel, label = NULL) {
242  if (!is.null(label)) return(label)
243
244  sprintf(
245    '%s(%s)',
246    functionLabel,
247    quoToLabelBody(q)
248  )
249}
250