1tryCatch <- function(expr, ..., finally) { 2 base::tryCatch( 3 withCallingHandlers( 4 expr, 5 error = function(e) { 6 promiseDomain$onError(e) 7 } 8 ), 9 ..., 10 finally = finally 11 ) 12} 13 14spliceOnFinally <- function(onFinally) { 15 list( 16 onFulfilled = finallyToFulfilled(onFinally), 17 onRejected = finallyToRejected(onFinally) 18 ) 19} 20 21finallyToFulfilled <- function(onFinally) { 22 force(onFinally) 23 function(value, .visible) { 24 onFinally() 25 if (.visible) 26 value 27 else 28 invisible(value) 29 } 30} 31 32finallyToRejected <- function(onFinally) { 33 force(onFinally) 34 function(reason) { 35 onFinally() 36 stop(reason) 37 } 38} 39 40promiseDomain <- list( 41 onThen = function(onFulfilled, onRejected, onFinally) { 42 force(onFulfilled) 43 force(onRejected) 44 force(onFinally) 45 46 # Verify that if onFinally is non-NULL, onFulfilled and onRejected are NULL 47 if (!is.null(onFinally) && (!is.null(onFulfilled) || !is.null(onRejected))) { 48 stop("A single `then` call cannot combine `onFinally` with `onFulfilled`/`onRejected`") 49 } 50 51 # TODO: All wrapped functions should also be rewritten to reenter the domain 52 # jcheng 2019-07-26: Actually, this seems not to be necessary--the domain 53 # is getting reentered during callbacks. But I can't figure out now how it's 54 # happening. 55 56 domain <- current_promise_domain() 57 58 shouldWrapFinally <- !is.null(onFinally) && !is.null(domain) && !is.null(domain$wrapOnFinally) 59 60 newOnFinally <- if (shouldWrapFinally) { 61 domain$wrapOnFinally(onFinally) 62 } else { 63 onFinally 64 } 65 66 if (!is.null(newOnFinally)) { 67 spliced <- spliceOnFinally(newOnFinally) 68 onFulfilled <- spliced$onFulfilled 69 onRejected <- spliced$onRejected 70 } 71 72 shouldWrapFulfilled <- !is.null(onFulfilled) && !is.null(domain) && !shouldWrapFinally 73 shouldWrapRejected <- !is.null(onRejected) && !is.null(domain) && !shouldWrapFinally 74 75 results <- list( 76 onFulfilled = if (shouldWrapFulfilled) domain$wrapOnFulfilled(onFulfilled) else onFulfilled, 77 onRejected = if (shouldWrapRejected) domain$wrapOnRejected(onRejected) else onRejected 78 ) 79 results[!vapply(results, is.null, logical(1))] 80 }, 81 onError = function(error) { 82 domain <- current_promise_domain() 83 if (is.null(domain)) 84 return() 85 domain$onError(error) 86 } 87) 88 89globals <- new.env(parent = emptyenv()) 90 91current_promise_domain <- function() { 92 globals$domain 93} 94 95#' Promise domains 96#' 97#' Promise domains are used to temporarily set up custom environments that 98#' intercept and influence the registration of callbacks. Create new promise 99#' domain objects using `new_promise_domain`, and temporarily activate a promise 100#' domain object (for the duration of evaluating a given expression) using 101#' `with_promise_domain`. 102#' 103#' While `with_promise_domain` is on the call stack, any calls to [then()] (or 104#' higher level functions or operators, like [catch()] or the various [pipes]) 105#' will belong to the promise domain. In addition, when a `then` callback that 106#' belongs to a promise domain is invoked, then any new calls to `then` will 107#' also belong to that promise domain. In other words, a promise domain 108#' "infects" not only the immediate calls to `then`, but also to "nested" calls 109#' to `then`. 110#' 111#' For more background, read the 112#' [original design doc](https://gist.github.com/jcheng5/b1c87bb416f6153643cd0470ac756231). 113#' 114#' For examples, see the source code of the Shiny package, which uses promise 115#' domains extensively to manage graphics devices and reactivity. 116#' 117#' @param domain A promise domain object to install while `expr` is evaluated. 118#' @param expr Any R expression, to be evaluated under the influence of 119#' `domain`. 120#' @param replace If `FALSE`, then the effect of the `domain` will be added 121#' to the effect of any currently active promise domain(s). If `TRUE`, then 122#' the current promise domain(s) will be ignored for the duration of the 123#' `with_promise_domain` call. 124#' 125#' @export 126with_promise_domain <- function(domain, expr, replace = FALSE) { 127 oldval <- current_promise_domain() 128 if (replace) 129 globals$domain <- domain 130 else 131 globals$domain <- compose_domains(oldval, domain) 132 on.exit(globals$domain <- oldval) 133 134 if (!is.null(domain)) 135 domain$wrapSync(expr) 136 else 137 force(expr) 138} 139 140# Like with_promise_domain, but doesn't include the wrapSync call. 141reenter_promise_domain <- function(domain, expr, replace = FALSE) { 142 oldval <- current_promise_domain() 143 if (replace) 144 globals$domain <- domain 145 else 146 globals$domain <- compose_domains(oldval, domain) 147 on.exit(globals$domain <- oldval) 148 149 force(expr) 150} 151 152#' @param wrapOnFulfilled A function that takes a single argument: a function 153#' that was passed as an `onFulfilled` argument to [then()]. The 154#' `wrapOnFulfilled` function should return a function that is suitable for 155#' `onFulfilled` duty. 156#' @param wrapOnRejected A function that takes a single argument: a function 157#' that was passed as an `onRejected` argument to [then()]. The 158#' `wrapOnRejected` function should return a function that is suitable for 159#' `onRejected` duty. 160#' @param wrapSync A function that takes a single argument: a (lazily evaluated) 161#' expression that the function should [force()]. This expression represents 162#' the `expr` argument passed to [with_promise_domain()]; `wrapSync` allows 163#' the domain to manipulate the environment before/after `expr` is evaluated. 164#' @param onError A function that takes a single argument: an error. `onError` 165#' will be called whenever an exception occurs in a domain (that isn't caught 166#' by a `tryCatch`). Providing an `onError` callback doesn't cause errors to 167#' be caught, necessarily; instead, `onError` callbacks behave like calling 168#' handlers. 169#' @param ... Arbitrary named values that will become elements of the promise 170#' domain object, and can be accessed as items in an environment (i.e. using 171#' `[[` or `$`). 172#' @param wrapOnFinally A function that takes a single argument: a function 173#' that was passed as an `onFinally` argument to [then()]. The 174#' `wrapOnFinally` function should return a function that is suitable for 175#' `onFinally` duty. If `wrapOnFinally` is `NULL` (the default), then the 176#' domain will use both `wrapOnFulfilled` and `wrapOnRejected` to wrap the 177#' `onFinally`. If it's important to distinguish between normal 178#' fulfillment/rejection handlers and finally handlers, then be sure to 179#' provide `wrapOnFinally`, even if it's just [base::identity()]. 180#' @rdname with_promise_domain 181#' @export 182new_promise_domain <- function( 183 wrapOnFulfilled = identity, 184 wrapOnRejected = identity, 185 wrapSync = force, 186 onError = force, 187 ..., 188 wrapOnFinally = NULL 189) { 190 list2env(list( 191 wrapOnFulfilled = wrapOnFulfilled, 192 wrapOnRejected = wrapOnRejected, 193 wrapOnFinally = wrapOnFinally, 194 wrapSync = wrapSync, 195 onError = onError, 196 ... 197 ), parent = emptyenv()) 198} 199 200 201compose_domains <- function(base, new) { 202 if (is.null(base)) { 203 return(new) 204 } 205 206 list( 207 wrapOnFulfilled = function(onFulfilled) { 208 # Force eager evaluation of base$wrapOnFulfilled(onFulfilled) 209 base <- base$wrapOnFulfilled(onFulfilled) 210 new$wrapOnFulfilled(base) 211 }, 212 wrapOnRejected = function(onRejected) { 213 # Force eager evaluation of base$wrapOnRejected(onRejected) 214 base <- base$wrapOnRejected(onRejected) 215 new$wrapOnRejected(base) 216 }, 217 # Only include the new wrapSync, assuming that we've already applied the 218 # base domain's wrapSync. This assumption won't hold if we either export 219 # compose_domains in the future, or if we use it in cases where the base 220 # domain isn't currently active. 221 wrapSync = new$wrapSync, 222 onError = function(e) { 223 base$onError(e) 224 new$onError(e) 225 } 226 ) 227} 228 229without_promise_domain <- function(expr) { 230 with_promise_domain(NULL, expr, replace = TRUE) 231} 232