still broken, progress on new modules and proxied mocksession

Small changes to testModule()/testServer() semantics

.travis.yml

@@ -5,6 +5,7 @@ matrix:
       r: release
       r_packages:
         - devtools
+        - rprojroot
       script: ./tools/checkDocsCurrent.sh
     - name: "Javascript check"
       language: node_js
@@ -25,7 +26,3 @@ notifications:
   email:
     on_success: change
     on_failure: change
-  slack:
-    on_success: change
-    secure: QoM0+hliVC4l2HYv126AkljG/uFvgwayW9IpuB5QNqjSukM122MhMDL7ZuMB9a2vWP24juzOTXiNIymgEspfnvvAMnZwYRBNWkuot2m8HIR2B9UjQLiztFnN1EAT+P+thz8Qax9TV2SOfXb2S2ZOeZmRTVkJctxkL8heAZadIC4=
-    on_pull_requests: false

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.4.0.9001
+Version: 1.4.0.9002
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),

NEWS.md

@@ -17,6 +17,8 @@ shiny 1.4.0.9001
 
 * Added a label to observer that auto-reloads `R/` directory to avoid confusion when using `reactlog`. ([#58](https://github.com/rstudio/reactlog/issues/58))
 
+* `getDefaultReactiveDomain()` can now be called inside a `session$onSessionEnded` callback and will return the calling `session` information. ([#2757](https://github.com/rstudio/shiny/pull/2757))
+
 ### Bug fixes
 
 * Fixed [#2606](https://github.com/rstudio/shiny/issues/2606): `debounce()` would not work properly if the code in the reactive expression threw an error on the first run. ([#2652](https://github.com/rstudio/shiny/pull/2652))

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,14 +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")) {
+  if (!inherits(session, c("ShinySession", "MockShinySession", "session_proxy"))) {
-    stop("session must be a ShinySession or session_proxy object.")
+    stop("session must be a ShinySession, MockShinySession, or session_proxy object.")
   }
   childScope <- session$makeScope(id)
 

R/shiny.R

@@ -962,7 +962,9 @@ ShinySession <- R6Class(
         output$suspend()
       }
       # ..stacktraceon matches with the top-level ..stacktraceoff..
-      private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
+      withReactiveDomain(self, {
+        private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
+      })
     },
     isClosed = function() {
       return(self$closed)

R/test-module.R

@@ -14,6 +14,7 @@
 #' @param ... Additional arguments to pass to the module function. These
 #'   arguments are processed with [rlang::list2()] and so are
 #'   _[dynamic][rlang::dyn-dots]_.
+#' @return The result of evaluating `expr`.
 #' @include mock-session.R
 #' @rdname testModule
 #' @examples
@@ -55,53 +56,47 @@
 #' }, !!multiplier_arg_name := 2, !!!more_args)
 #' @export
 testModule <- function(module, expr, ...) {
-  expr <- substitute(expr)
+  .testModule(
-  .testModule(module, expr, ...)
+    module,
+    quosure = rlang::enquo(expr),
+    dots = rlang::list2(...),
+    env = rlang::caller_env()
+  )
+}
+
+isOldModule <- function(func) {
+  stopifnot(is.function(func))
+  required <- c("input", "output", "session")
+  declared <- names(formals(func))
+  setequal(required, intersect(required, declared))
 }
 
 #' @noRd
-#' @importFrom withr with_options
+.testModule <- function(module, quosure, dots, env) {
-.testModule <- function(module, expr, ...) {
-  # Capture the environment from the module
-  # Inserts `session$env <- environment()` at the top of the function
-  body(module) <- rlang::expr({
-    session$env <- environment()
-    !!!body(module)
-  })
-
-  # Create a mock session
   session <- MockShinySession$new()
+  on.exit(if (!session$isClosed()) session$close())
 
-  # Parse the additional arguments
+  if (isOldModule(module)) {
-  args <- rlang::list2(..., input = session$input, output = session$output, session = session)
+    module <- patchModuleFunction(module)
+    args <- append(dots, list(input = session$input, output = session$output, session = session))
+  } else {
+    args <- dots
+  }
 
-  # Initialize the module
+  isolate(withReactiveDomain(session, do.call(module, args)))
-  isolate(
-    withReactiveDomain(
-      session,
-      withr::with_options(list(`shiny.allowoutputreads`=TRUE), {
-        # Remember that invoking this module implicitly assigns to `session$env`
-        # Also, assigning to `$returned` will cause a flush to happen automatically.
-        session$returned <- do.call(module, args)
-      })
-    )
-  )
 
-  # Run the test expression in a reactive context and in the module's environment.
-  # We don't need to flush before entering the loop because the first expr that we execute is `{`.
-  # So we'll already flush before we get to the good stuff.
   isolate({
     withReactiveDomain(
       session,
       withr::with_options(list(`shiny.allowoutputreads`=TRUE), {
-        eval(expr, new.env(parent=session$env))
+        rlang::eval_tidy(
+          quosure,
+          data = rlang::as_data_mask(as.list(session$env)),
+          env = env
+        )
       })
     )
   })
-
-  if (!session$isClosed()){
-    session$close()
-  }
 }
 
 #' Test an app's server-side logic
@@ -130,8 +125,14 @@ testServer <- function(expr, appDir=NULL) {
     formals(server) <- fn_formals
   }
 
-  # Now test the server as we would a module
+  # Test the server function almost as if it were a module. `dots` is empty
-  .testModule(server, expr=substitute(expr))
+  # because server functions never take additional arguments.
+  .testModule(
+    server,
+    quosure = rlang::enquo(expr),
+    dots = list(),
+    env = rlang::caller_env()
+  )
 }
 
 findApp <- function(startDir="."){

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:

inst/www/shared/shiny.js

@@ -12,7 +12,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
   var exports = window.Shiny = window.Shiny || {};
 
-  exports.version = "1.4.0.9001"; // Version number inserted by Grunt
+  exports.version = "1.4.0.9002"; // Version number inserted by Grunt
 
   var origPushState = window.history.pushState;
   window.history.pushState = function () {

man/HTML.Rd

@@ -2,13 +2,18 @@
 \alias{HTML}
 \title{Mark Characters as HTML}
 \usage{
-HTML(text, ...)
+HTML(text, ..., .noWS = NULL)
 }
 \arguments{
 \item{text}{The text value to mark with HTML}
 
 \item{...}{Any additional values to be converted to character and
 concatenated together}
+
+\item{.noWS}{Character vector used to omit some of the whitespace that would
+normally be written around this HTML. Valid options include \code{before},
+\code{after}, and \code{outside} (equivalent to \code{before} and
+\code{end}).}
 }
 \value{
 The same value, but marked as HTML.

man/MockShinySession.Rd

@@ -618,10 +618,18 @@ Trigger a reactive flush right now.
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-makeScope"></a>}}
 \subsection{Method \code{makeScope()}}{
+Create and return a namespace-specific session proxy.
 \subsection{Usage}{
 \if{html}{\out{<div class="r">}}\preformatted{MockShinySession$makeScope(namespace)}\if{html}{\out{</div>}}
 }
 
+\subsection{Arguments}{
+\if{html}{\out{<div class="arguments">}}
+\describe{
+\item{\code{namespace}}{Character vector indicating a namespace.}
+}
+\if{html}{\out{</div>}}
+}
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-clone"></a>}}

man/testModule.Rd

@@ -25,6 +25,9 @@ arguments are processed with \code{\link[rlang:list2]{rlang::list2()}} and so ar
 will work up the directory hierarchy --- starting with the current directory ---
 looking for a directory that contains an \code{app.R} or \code{server.R} file.}
 }
+\value{
+The result of evaluating \code{expr}.
+}
 \description{
 Offer a way to test the reactive interactions in Shiny --- either in Shiny
 modules or in the server portion of a Shiny application. For more

man/validateCssUnit.Rd

@@ -29,6 +29,7 @@ If the number has a suffix, it must be valid: \code{px},
 \code{vmax}.
 If the number has no suffix, the suffix \code{"px"} is appended.
 
+
 Any other value will cause an error to be thrown.
 }
 \examples{

tests/testthat/test-test-module.R

@@ -525,6 +525,33 @@ test_that("testModule works with nested modules", {
   })
 })
 
+test_that("testModule calls can be nested", {
+  outerModule <- function(input, output, session) {
+    doubled <- reactive({ input$x * 2 })
+    innerModule <- function(input, output, session) {
+      quadrupled <- reactive({ doubled() * 2 })
+    }
+  }
+
+  testModule(outerModule, {
+    session$setInputs(x = 1)
+    expect_equal(doubled(), 2)
+    testModule(innerModule, {
+      expect_equal(quadrupled(), 4)
+    })
+  })
+})
+
+test_that("testModule returns a meaningful result", {
+  result <- testModule(function(input, output, session) {
+    reactive({ input$x * 2 })
+  }, {
+    session$setInputs(x = 2)
+    session$returned()
+  })
+  expect_equal(result, 4)
+})
+
 test_that("assigning an output in a module function with a non-function errors", {
   module <- function(input, output, session) {
     output$someVar <- 123
@@ -556,10 +583,43 @@ test_that("testServer works", {
 test_that("testServer works when referencing external globals", {
   # If global is defined at the top of app.R outside of the server function.
   testServer({
-    expect_equal(global, 123)
+    expect_equal(get("global", session$env), 123)
   }, appDir=test_path("..", "test-modules", "06_tabsets"))
 })
 
+test_that("testModule allows lexical environment access through session$env", {
+  m <- local({
+    a_var <- 123
+    function(input, output, session) {
+      b_var <- 321
+    }
+  })
+  expect_false(exists("a_var", inherits = FALSE))
+  testModule(m, {
+    expect_equal(b_var, 321)
+    expect_equal(get("a_var", session$env), 123)
+  })
+})
+
+test_that("Module shadowing can be mitigated with unquote", {
+  i <- 0
+  inc <- function() i <<- i+1
+
+  m <- local({
+    function(input, output, session) {
+      inc <- function() stop("I should never be called")
+    }
+  })
+
+  testModule(m, {
+    expect_is(inc, "function")
+    expect_false(identical(inc, !!inc))
+    !!inc()
+  })
+
+  expect_equal(i, 1)
+})
+
 test_that("testModule handles invalidateLater", {
   module <- function(input, output, session) {
     rv <- reactiveValues(x = 0)

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")
+})

tests/testthat/test-timer.R

@@ -72,11 +72,11 @@ test_that("mockableTimer works", {
 })
 
 test_that("getDomainTimeMs works", {
-  start <- Sys.time()
+  start <- as.numeric(Sys.time()) * 1000
   t1 <- getDomainTimeMs(NULL)
   t2 <- getDomainTimeMs(list())
   t3 <- getDomainTimeMs(list(.now = function(){456}))
-  end <- Sys.time()
+  end <- as.numeric(Sys.time()) * 1000
 
   expect_gte(t1, start)
   expect_gte(t2, start)

tools/checkDocsCurrent.sh

@@ -14,3 +14,17 @@ then
 else
   echo "No difference detected; Roxygen docs are current."
 fi
+
+
+# Update htmltools docs
+Rscript './tools/updateHtmltoolsMan.R'
+
+if [ -n "$(git status --porcelain)" ]
+then
+  git status --porcelain
+  >&2 echo "Please generate the htmltools documentation and commit the updates."
+  >&2 echo "The above files changed when we generated the htmltools documentation. This most often occurs when the documentation re-exported by shiny does not match the htmltools documentation."
+  exit 1
+else
+  echo "No difference detected; re-exported htmltools docs are current."
+fi