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