Add wrapOnFinally to promise domains

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: promises
 Type: Package
 Title: Abstractions for Promise-Based Asynchronous Programming
-Version: 1.0.1.9001
+Version: 1.0.1.9002
 Authors@R: c(
       person("Joe", "Cheng", email = "joe@rstudio.com", role = c("aut", "cre")),
       person("RStudio", role = c("cph", "fnd"))

NEWS.md

@@ -1,9 +1,12 @@
-promises 1.0.1.9001
-================
+promises 1.0.1.9002
+===================
 
 * Fixed [#49](https://github.com/rstudio/promises/issues/49): `promise_all()` previously did not handle `NULL` values correctly. ([#50](https://github.com/rstudio/promises/pull/50))
 
+* `new_promise_domain` now takes a `wrapOnFinally` argument, which can be used to intercept registration of `finally()`. Previous versions treated `finally` as passing the same callback to `then(onFulfilled=..., onRejected=...)`, and ignoring the result; for backward compatibility, promise domains will still treat `finally` that way by default (i.e. if `wrapOnFinally` is `NULL`, then `finally` will result in `wrapOnFulfilled` and `wrapOnRejected` being called, but if `wrapOnFinally` is provided then only `wrapOnFinally` will be called). ([#43](https://github.com/rstudio/promises/pull/43))
+
+
 promises 1.0.1
-================
+==============
 
 * Initial CRAN release

R/domains.R

@@ -11,29 +11,72 @@ tryCatch <- function(expr, ..., finally) {
   )
 }
 
+spliceOnFinally <- function(onFinally) {
+  list(
+    onFulfilled = finallyToFulfilled(onFinally),
+    onRejected = finallyToRejected(onFinally)
+  )
+}
+
+finallyToFulfilled <- function(onFinally) {
+  force(onFinally)
+  function(value, .visible) {
+    onFinally()
+    if (.visible)
+      value
+    else
+      invisible(value)
+  }
+}
+
+finallyToRejected <- function(onFinally) {
+  force(onFinally)
+  function(reason) {
+    onFinally()
+    stop(reason)
+  }
+}
+
 promiseDomain <- list(
-  onThen = function(onFulfilled, onRejected) {
+  onThen = function(onFulfilled, onRejected, onFinally) {
+    force(onFulfilled)
+    force(onRejected)
+    force(onFinally)
+
+    # Verify that if onFinally is non-NULL, onFulfilled and onRejected are NULL
+    if (!is.null(onFinally) && (!is.null(onFulfilled) || !is.null(onRejected))) {
+      stop("A single `then` call cannot combine `onFinally` with `onFulfilled`/`onRejected`")
+    }
+
+    # TODO: All wrapped functions should also be rewritten to reenter the domain
+    # jcheng 2019-07-26: Actually, this seems not to be necessary--the domain
+    # is getting reentered during callbacks. But I can't figure out now how it's
+    # happening.
+
     domain <- current_promise_domain()
 
-    if (is.null(domain))
-      return()
-    if (is.null(onFulfilled) && is.null(onRejected))
-      return()
+    shouldWrapFinally <- !is.null(onFinally) && !is.null(domain) && !is.null(domain$wrapOnFinally)
 
-    results <- list()
-    if (!is.null(onFulfilled)) {
-      newOnFulfilled <- domain$wrapOnFulfilled(onFulfilled)
-      results$onFulfilled <- function(...) {
-        reenter_promise_domain(domain, newOnFulfilled(...))
-      }
+    newOnFinally <- if (shouldWrapFinally) {
+      domain$wrapOnFinally(onFinally)
+    } else {
+      onFinally
     }
-    if (!is.null(onRejected)) {
-      newOnRejected <- domain$wrapOnRejected(onRejected)
-      results$onRejected <- function(...) {
-        reenter_promise_domain(domain, newOnRejected(...))
-      }
+
+    if (!is.null(newOnFinally)) {
+      spliced <- spliceOnFinally(newOnFinally)
+      onFulfilled <- spliced$onFulfilled
+      onRejected <- spliced$onRejected
     }
-    results
+
+    shouldWrapFulfilled <- !is.null(onFulfilled) && !is.null(domain) && !shouldWrapFinally
+    shouldWrapRejected <- !is.null(onRejected) && !is.null(domain) && !shouldWrapFinally
+
+    results <- list(
+      onFulfilled = if (shouldWrapFulfilled) domain$wrapOnFulfilled(onFulfilled) else onFulfilled,
+      onRejected = if (shouldWrapRejected) domain$wrapOnRejected(onRejected) else onRejected
+    )
+    results[!vapply(results, is.null, logical(1))]
   },
   onError = function(error) {
     domain <- current_promise_domain()
@@ -88,7 +131,10 @@ with_promise_domain <- function(domain, expr, replace = FALSE) {
     globals$domain <- compose_domains(oldval, domain)
   on.exit(globals$domain <- oldval)
 
-  globals$domain$wrapSync(expr)
+  if (!is.null(domain))
+    domain$wrapSync(expr)
+  else
+    force(expr)
 }
 
 # Like with_promise_domain, but doesn't include the wrapSync call.
@@ -123,18 +169,28 @@ reenter_promise_domain <- function(domain, expr, replace = FALSE) {
 #' @param ... Arbitrary named values that will become elements of the promise
 #'   domain object, and can be accessed as items in an environment (i.e. using
 #'   `[[` or `$`).
+#' @param wrapOnFinally A function that takes a single argument: a function
+#'   that was passed as an `onFinally` argument to [then()]. The
+#'   `wrapOnFinally` function should return a function that is suitable for
+#'   `onFinally` duty. If `wrapOnFinally` is `NULL` (the default), then the
+#'   domain will use both `wrapOnFulfilled` and `wrapOnRejected` to wrap the
+#'   `onFinally`. If it's important to distinguish between normal
+#'   fulfillment/rejection handlers and finally handlers, then be sure to
+#'   provide `wrapOnFinally`, even if it's just [base::identity()].
 #' @rdname with_promise_domain
 #' @export
 new_promise_domain <- function(
   wrapOnFulfilled = identity,
   wrapOnRejected = identity,
   wrapSync = force,
   onError = force,
-  ...
+  ...,
+  wrapOnFinally = NULL
 ) {
   list2env(list(
     wrapOnFulfilled = wrapOnFulfilled,
     wrapOnRejected = wrapOnRejected,
+    wrapOnFinally = wrapOnFinally,
     wrapSync = wrapSync,
     onError = onError,
     ...
@@ -169,3 +225,7 @@ compose_domains <- function(base, new) {
     }
   )
 }
+
+without_promise_domain <- function(expr) {
+  with_promise_domain(NULL, expr, replace = TRUE)
+}

R/promise.R

@@ -29,21 +29,31 @@ Promise <- R6::R6Class("Promise",
         if (identical(self, attr(value, "promise_impl", exact = TRUE))) {
           return(private$doReject(simpleError("Chaining cycle detected for promise")))
         }
-        value$then(
-          private$doResolve,
-          private$doReject
-        )
+        # This then() call doesn't need promise domains; semantically, it doesn't
+        # really exist, as it's just a convenient way to implement the new promise
+        # inhabiting the old promise's corpse.
+        without_promise_domain({
+          value$then(
+            private$doResolve,
+            private$doReject
+          )
+        })
       } else {
         private$doResolveFinalValue(value, visible)
       }
     },
     doReject = function(reason) {
       if (is.promising(reason)) {
         reason <- as.promise(reason)
-        reason$then(
-          private$doResolve,
-          private$doReject
-        )
+        # This then() call doesn't need promise domains; semantically, it doesn't
+        # really exist, as it's just a convenient way to implement the new promise
+        # inhabiting the old promise's corpse.
+        without_promise_domain({
+          reason$then(
+            private$doResolve,
+            private$doReject
+          )
+        })
       } else {
         private$doRejectFinalReason(reason)
       }
@@ -129,13 +139,16 @@ Promise <- R6::R6Class("Promise",
 
       invisible()
     },
-    then = function(onFulfilled = NULL, onRejected = NULL) {
+    then = function(onFulfilled = NULL, onRejected = NULL, onFinally = NULL) {
       onFulfilled <- normalizeOnFulfilled(onFulfilled)
       onRejected <- normalizeOnRejected(onRejected)
+      if (!is.function(onFinally)) {
+        onFinally <- NULL
+      }
 
       promise2 <- promise(function(resolve, reject) {
+          res <- promiseDomain$onThen(onFulfilled, onRejected, onFinally)
 
-          res <- promiseDomain$onThen(onFulfilled, onRejected)
           if (!is.null(res)) {
             onFulfilled <- res$onFulfilled
             onRejected <- res$onRejected
@@ -187,14 +200,7 @@ Promise <- R6::R6Class("Promise",
     },
     finally = function(onFinally) {
       invisible(self$then(
-        onFulfilled = function(value) {
-          onFinally()
-          value
-        },
-        onRejected = function(reason) {
-          onFinally()
-          stop(reason)
-        }
+        onFinally = onFinally
       ))
     },
     format = function() {
@@ -212,7 +218,7 @@ Promise <- R6::R6Class("Promise",
 
 normalizeOnFulfilled <- function(onFulfilled) {
   if (!is.function(onFulfilled))
-    return(onFulfilled)
+    return(NULL)
 
   args <- formals(onFulfilled)
   arg_count <- length(args)
@@ -232,7 +238,7 @@ normalizeOnFulfilled <- function(onFulfilled) {
 
 normalizeOnRejected <- function(onRejected) {
   if (!is.function(onRejected))
-    return(onRejected)
+    return(NULL)
 
   args <- formals(onRejected)
   arg_count <- length(args)

tests/testthat/common.R

@@ -54,3 +54,67 @@ squelch_unhandled_promise_error <- function(promise) {
   # Detect unexpected "Unhandled promise error" warnings.
   wait_for_it()
 }
+
+create_counting_domain <- function(trackFinally = FALSE) {
+  counts <- list2env(parent = emptyenv(), list(
+    onFulfilledBound = 0L,
+    onFulfilledCalled = 0L,
+    onFulfilledActive = 0L,
+    onRejectedBound = 0L,
+    onRejectedCalled = 0L,
+    onRejectedActive = 0L
+  ))
+
+  incr <- function(field) {
+    field <- as.character(substitute(field))
+    counts[[field]] <- counts[[field]] + 1L
+  }
+
+  decr <- function(field) {
+    field <- as.character(substitute(field))
+    counts[[field]] <- counts[[field]] - 1L
+  }
+
+  pd <- new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      incr(onFulfilledBound)
+      function(...) {
+        incr(onFulfilledCalled)
+        incr(onFulfilledActive)
+        on.exit(decr(onFulfilledActive))
+
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      incr(onRejectedBound)
+      function(...) {
+        incr(onRejectedCalled)
+        incr(onRejectedActive)
+        on.exit(decr(onRejectedActive))
+
+        onRejected(...)
+      }
+    },
+    counts = counts
+  )
+
+  if (trackFinally) {
+    counts$onFinallyBound <- 0L
+    counts$onFinallyCalled <- 0L
+    counts$onFinallyActive <- 0L
+
+    pd$wrapOnFinally <- function(onFinally) {
+      incr(onFinallyBound)
+      function() {
+        incr(onFinallyCalled)
+        incr(onFinallyActive)
+        on.exit(incr(onFinallyActive))
+
+        onFinally()
+      }
+    }
+  }
+
+  pd
+}