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