still broken, progress on new modules and proxied mocksession

R/mock-session.R

@@ -69,6 +69,19 @@ extract <- function(promise) {
   stop("Single-bracket indexing of mockclientdata is not allowed.")
 }
 
+#' @noRd
+patchModuleFunction <- function(module) {
+  body(module) <- rlang::expr({
+    withr::with_options(base::list(`shiny.allowoutputreads` = TRUE), {
+      session$setEnv(base::environment())
+      session$setReturned({
+        !!!body(module)
+      })
+    })
+  })
+  module
+}
+
 #' Mock Shiny Session
 #'
 #' @description
@@ -80,7 +93,6 @@ extract <- function(promise) {
 MockShinySession <- R6Class(
   'MockShinySession',
   portable = FALSE,
-  class = FALSE,
   public = list(
     #' @field env The environment associated with the session.
     env = NULL,
@@ -101,7 +113,8 @@ MockShinySession <- R6Class(
     userData = NULL,
     #' @field progressStack A stack of progress objects
     progressStack = 'Stack',
-
+    #' @field TRUE when a moduleServer()-based module is under test
+    isModuleServer = FALSE,
     #' @description Create a new MockShinySession
     initialize = function() {
       private$.input <- ReactiveValues$new(dedupe = FALSE, label = "input")
@@ -381,16 +394,38 @@ MockShinySession <- R6Class(
     flushReact = function(){
       private$flush()
     },
+    setEnv = function(env) {
+      self$env <- env
+    },
+    setReturned = function(value) {
+      private$returnedVal <- value
+      private$flush()
+      value
+    },
     #' @description Create and return a namespace-specific session proxy.
     #' @param namespace Character vector indicating a namespace.
     makeScope = function(namespace) {
       ns <- NS(namespace)
-      createSessionProxy(
+      proxy <- createSessionProxy(
         self,
         input = .createReactiveValues(private$.input, readonly = TRUE, ns = ns),
         output = structure(.createOutputWriter(self, ns = ns), class = "shinyoutput"),
-        makeScope = function(namespace) self$makeScope(ns(namespace))
+        makeScope = function(namespace) self$makeScope(ns(namespace)),
+        env = NULL,
+        returned = NULL,
+        setEnv = function(env) assign("env", env, envir = proxy),
+        setReturned = function(value) {
+          assign("returned", value, envir = proxy)
+          private$flush()
+          value
+        },
+        setInputs = function(...) {
+          args <- list(...)
+          names(args) <- ns(names(args))
+          do.call(self$setInputs, args)
+        }
       )
+      proxy
     }
   ),
   private = list(

R/modules.R

@@ -121,15 +121,33 @@ createSessionProxy <- function(parentSession, ...) {
 #'
 #' @export
 moduleServer <- function(id, module, session = getDefaultReactiveDomain()) {
-  callModule(module, id, session = session)
+  if (inherits(sessionFor(session), "MockShinySession")) {
+    module <- patchModuleFunction(module)
+    isolate(callModule(module, id, session = session))
+  } else {
+    callModule(module, id, session = session)
+  }
 }
 
+#' @noRd
+sessionFor <- function(session) {
+  if (inherits(session, c("MockShinySession", "ShinySession")))
+    return(session)
+
+  if (!inherits(session, "session_proxy"))
+    stop("session must be a ShinySession, MockShinySession, or session_proxy object.")
+
+  while (inherits(session, "session_proxy"))
+    session <- session$parent
+
+  session
+}
 
 #' @rdname moduleServer
 #' @export
 callModule <- function(module, id, ..., session = getDefaultReactiveDomain()) {
-  if (!inherits(session, "ShinySession") && !inherits(session, "session_proxy")) {
-    stop("session must be a ShinySession or session_proxy object.")
+  if (!inherits(session, c("ShinySession", "MockShinySession", "session_proxy"))) {
+    stop("session must be a ShinySession, MockShinySession, or session_proxy object.")
   }
   childScope <- session$makeScope(id)
 

R/test-module.R

@@ -64,38 +64,27 @@ testModule <- function(module, expr, ...) {
   )
 }
 
-#' @noRd
-#' @importFrom withr with_options
-.testModule <- function(module, quosure, dots, env) {
-  # Modify the module function locally by inserting `session$env <-
-  # environment()` at the beginning of its body. The dynamic environment of the
-  # module function is saved so that it may be referenced after the module
-  # function has returned. The saved dynamic environment is the basis for the
-  # `data` argument of tidy_eval() when used below to evaluate `quosure`, the
-  # test code expression.
-  body(module) <- rlang::expr({
-    session$env <- base::environment()
-    !!!body(module)
-  })
+isOldModule <- function(func) {
+  stopifnot(is.function(func))
+  required <- c("input", "output", "session")
+  declared <- names(formals(func))
+  setequal(required, intersect(required, declared))
+}
 
+#' @noRd
+.testModule <- function(module, quosure, dots, env) {
   session <- MockShinySession$new()
   on.exit(if (!session$isClosed()) session$close())
-  args <- append(dots, list(input = session$input, output = session$output, session = session))
 
-  isolate(
-    withReactiveDomain(
-      session,
-      withr::with_options(list(`shiny.allowoutputreads`=TRUE), {
-        # Assigning to `$returned` causes a flush to happen automatically.
-        session$returned <- do.call(module, args)
-      })
-    )
-  )
+  if (isOldModule(module)) {
+    module <- patchModuleFunction(module)
+    args <- append(dots, list(input = session$input, output = session$output, session = session))
+  } else {
+    args <- dots
+  }
+
+  isolate(withReactiveDomain(session, do.call(module, args)))
 
-  # Evaluate `quosure` in a reactive context, and in the provided `env`, but
-  # with `env` masked by a shallow view of `session$env`, the environment that
-  # was saved when the module function was invoked. flush is not needed before
-  # entering the loop because the first expr executed is `{`.
   isolate({
     withReactiveDomain(
       session,

inst/_pkgdown.yml

@@ -207,7 +207,7 @@ reference:
     desc: Functions for modularizing Shiny apps
     contents:
       - NS
-      - callModule
+      - moduleServer
   - title: Embedding
     desc: Functions that are intended for third-party packages that embed Shiny applications.
     contents:

tests/testthat/test-test-moduleServer.R

@@ -0,0 +1,23 @@
+context("testModule-moduleServer")
+
+test_that("New-style modules work", {
+  counterServer <- local({
+    function(id) {
+      moduleServer(id, function(input, output, session) {
+        count <- reactiveVal(0)
+        observeEvent(input$button, {
+          count(count() + 1)
+        })
+        output$out <- renderText({
+          count()
+        })
+        count
+      })
+    }
+  })
+  testModule(counterServer, {
+    input$setInputs(button = 0)
+    input$setInputs(button = 1)
+    expect_equal(count(), 1)
+  }, id = "foob")
+})