withReactiveDomain now acts as a promise domain

Without this change, async handlers won't return any
value for getDefaultReactiveDomain().

    library(shiny)
    library(promises)

    ui <- fluidPage(
      p("This app tests if async handlers have reactive domains. You'll get a yes/no answer below."),
      h3(
        "Does it work?",
        textOutput("answer", inline = TRUE)
      )
    )

    server <- function(input, output, session) {
      output$answer <- renderText({
        promise_resolve(TRUE) %...>% {
          if (!is.null(getDefaultReactiveDomain()))
            "Yes!"
          else
            "No :("
        }
      })
    }

    shinyApp(ui, server)

R/reactive-domains.R

@@ -95,11 +95,7 @@ getDefaultReactiveDomain <- function() {
 #' @rdname domains
 #' @export
 withReactiveDomain <- function(domain, expr) {
-  oldValue <- .globals$domain
-  .globals$domain <- domain
-  on.exit(.globals$domain <- oldValue)
-
-  expr
+  promises::with_promise_domain(createVarPromiseDomain(.globals, "domain", domain), expr)
 }
 
 #

R/utils.R

@@ -1674,3 +1674,37 @@ setVisible <- function(value, visible) {
     (value)
   }
 }
+
+createVarPromiseDomain <- function(env, name, value) {
+  force(env)
+  force(name)
+  force(value)
+  
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      function(...) {
+        orig <- env[[name]]
+        env[[name]] <- value
+        on.exit(env[[name]] <- orig)
+        
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      function(...) {
+        orig <- env[[name]]
+        env[[name]] <- value
+        on.exit(env[[name]] <- orig)
+        
+        onRejected(...)
+      }
+    },
+    wrapSync = function(expr) {
+      orig <- env[[name]]
+      env[[name]] <- value
+      on.exit(env[[name]] <- orig)
+
+      force(expr)
+    }
+  )
+}

tests/testthat/test-reactivity.r

@@ -1127,3 +1127,20 @@ test_that("debounce/throttle work properly (with priming)", {
 test_that("debounce/throttle work properly (without priming)", {
   run_debounce_throttle(FALSE)
 })
+
+test_that("reactive domain works across async handlers", {
+  obj <- new.env()
+  hasReactiveDomain <- NULL
+  withReactiveDomain(obj, {
+    promises::then(
+      promises::promise_resolve(TRUE),
+      ~{hasReactiveDomain <<- identical(getDefaultReactiveDomain(), obj)}
+    )
+  })
+  
+  while (is.null(hasReactiveDomain) && !later::loop_empty()) {
+    later::run_now()
+  }
+  
+  testthat::expect_true(hasReactiveDomain)
+})

tests/testthat/test-stacks.R

@@ -51,44 +51,48 @@ test_that("integration tests", {
   df <- causeError(full = FALSE)
   # dumpTests(df)
 
-  expect_equal(df$num, c(50L, 49L, 48L, 35L, 34L, 33L, 32L,
-    31L, 30L, 29L, 28L, 27L))
-  expect_equal(df$call, c("A", "B", "<reactive:C>", "C", "renderTable",
-    "func", "force", "withVisible", "withCallingHandlers", "globals$domain$wrapSync",
+  expect_equal(df$num, c(56L, 55L, 54L, 38L, 37L, 36L, 35L, 
+    34L, 33L, 32L, 31L, 30L))
+  expect_equal(df$call, c("A", "B", "<reactive:C>", "C", "renderTable", 
+    "func", "force", "withVisible", "withCallingHandlers", "globals$domain$wrapSync", 
     "promises::with_promise_domain", "captureStackTraces"))
-  expect_equal(nzchar(df$loc), c(TRUE, TRUE, TRUE, FALSE, TRUE,
+  expect_equal(nzchar(df$loc), c(TRUE, TRUE, TRUE, FALSE, TRUE, 
     FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE))
-
+  
   df <- causeError(full = TRUE)
   # dumpTests(df)
 
-  expect_equal(df$num, c(53L, 52L, 51L, 50L, 49L, 48L, 47L,
-    46L, 45L, 44L, 43L, 42L, 41L, 40L, 39L, 38L, 37L, 36L, 35L,
-    34L, 33L, 32L, 31L, 30L, 29L, 28L, 27L, 26L, 25L, 24L, 23L,
-    22L, 21L, 20L, 19L, 18L, 17L, 16L, 15L, 14L, 13L, 12L, 11L,
-    10L, 9L, 8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L))
-  expect_equal(df$call, c("h", ".handleSimpleError", "stop",
-    "A", "B", "<reactive:C>", "..stacktraceon..", ".func", "withVisible",
-    "withCallingHandlers", "contextFunc", "env$runWith", "withReactiveDomain",
-    "globals$domain$wrapSync", "promises::with_promise_domain",
-    "ctx$run", "self$.updateValue", "..stacktraceoff..", "C",
-    "renderTable", "func", "force", "withVisible", "withCallingHandlers",
-    "globals$domain$wrapSync", "promises::with_promise_domain",
-    "captureStackTraces", "doTryCatch", "tryCatchOne", "tryCatchList",
-    "tryCatch", "do", "hybrid_chain", "origRenderFunc", "renderTable({     C() }, server = FALSE)",
-    "..stacktraceon..", "contextFunc", "env$runWith", "withReactiveDomain",
-    "globals$domain$wrapSync", "promises::with_promise_domain",
-    "ctx$run", "..stacktraceoff..", "isolate", "withCallingHandlers",
-    "globals$domain$wrapSync", "promises::with_promise_domain",
-    "captureStackTraces", "doTryCatch", "tryCatchOne", "tryCatchList",
+  expect_equal(df$num, c(59L, 58L, 57L, 56L, 55L, 54L, 53L, 
+    52L, 51L, 50L, 49L, 48L, 47L, 46L, 45L, 44L, 43L, 42L, 41L, 
+    40L, 39L, 38L, 37L, 36L, 35L, 34L, 33L, 32L, 31L, 30L, 29L, 
+    28L, 27L, 26L, 25L, 24L, 23L, 22L, 21L, 20L, 19L, 18L, 17L, 
+    16L, 15L, 14L, 13L, 12L, 11L, 10L, 9L, 8L, 7L, 6L, 5L, 4L, 
+    3L, 2L, 1L))
+  expect_equal(df$call, c("h", ".handleSimpleError", "stop", 
+    "A", "B", "<reactive:C>", "..stacktraceon..", ".func", "withVisible", 
+    "withCallingHandlers", "contextFunc", "env$runWith", "force", 
+    "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "withReactiveDomain", "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "ctx$run", "self$.updateValue", "..stacktraceoff..", "C", 
+    "renderTable", "func", "force", "withVisible", "withCallingHandlers", 
+    "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "captureStackTraces", "doTryCatch", "tryCatchOne", "tryCatchList", 
+    "tryCatch", "do", "hybrid_chain", "origRenderFunc", "renderTable({     C() }, server = FALSE)", 
+    "..stacktraceon..", "contextFunc", "env$runWith", "force", 
+    "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "withReactiveDomain", "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "ctx$run", "..stacktraceoff..", "isolate", "withCallingHandlers", 
+    "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "captureStackTraces", "doTryCatch", "tryCatchOne", "tryCatchList", 
     "tryCatch", "try"))
-  expect_equal(nzchar(df$loc), c(FALSE, FALSE, FALSE, TRUE,
-    TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
-    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE,
-    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
-    FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE,
-    FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE,
-    FALSE, FALSE, FALSE, FALSE))
+  expect_equal(nzchar(df$loc), c(FALSE, FALSE, FALSE, TRUE, 
+    TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 
+    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 
+    TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 
+    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, 
+    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 
+    FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, 
+    FALSE))
 })
 
 test_that("shiny.error", {