Experimental support for hook functions [#172] [ci skip]

NEWS

@@ -1,7 +1,7 @@
 Package: future
 ===============
 
-Version: 1.19.1-9000 [2020-10-03]
+Version: 1.19.1-9000 [2020-10-07]
 
 SIGNIFICANT CHANGES:
 
@@ -17,6 +17,14 @@ SIGNIFICANT CHANGES:
    will give an informative deprecation warning when 'multiprocess' is used.
    This warning is given only once per R session.
 
+BETA FEATURES:
+
+ * Added experimental support for hook functions that are called when entering
+   and exiting any S3 methods for a Future class.  To enable it, set options
+   'future.hooks' or environment variable 'R_FUTURE_HOOKS' to TRUE *prior* to
+   loading the 'future' package.  It is not possible to enable them afterward.
+   When not set, the hook function framework will cause no overhead.
+
 BUG FIXES:
 
  * The Mandelbrot demo would produce random numbers without declaring so.

R/hooks.R

@@ -0,0 +1,75 @@
+setFutureHook <- function(fcn, generic, class, event, action = c("append", "prepend", "replace")) {
+  stop_if_not(is.function(fcn))
+  action <- match.arg(action)
+  hookName <- paste("futureEvent", generic, class, event, sep = "-")
+  setHook(hookName, value = fcn, action = action)
+}
+
+getFutureHooks <- function(generic, class, event) {
+  hookName <- paste("futureEvent", generic, class, event, sep = "-")
+  getHook(hookName)
+}
+
+
+callFutureHook <- function(future, generic, class, event, package) {
+  debug <- getOption("future.debug", TRUE)
+  hooks <- getFutureHooks(generic = generic, class = class, event = event)
+
+  if (debug) {
+    msg <- sprintf("Calling %d hook functions for event %s in generic %s for class %s of package = %s ...", length(hooks), sQuote(event), sQuote(generic), sQuote(class), sQuote(package))
+    t <- Sys.time()
+    message(sprintf("[%s] %s", format(t, format = "%FT%T%z"), msg))
+    on.exit({
+      t <- Sys.time()
+      message(sprintf("[%s] %s done", format(t, format = "%FT%T%z"), msg))
+    })
+  }
+
+  for (kk in seq_along(hooks)) {
+    hook <- hooks[[kk]]
+    stop_if_not(is.function(hook))
+    hook(future, time = t)
+  }
+}
+
+
+injectFutureHooks <- function(envir = topenv(), package = environmentName(envir), debug = getOption("future.debug", TRUE)) {
+  if (debug) {
+    mdebug("Adding hook functions to future methods ...")
+    on.exit(mdebug("Adding hook functions to future methods ... done"))
+  }
+
+  names <- ls(envir = envir, all.names = TRUE)
+  pattern <- "^(.*)[.](([A-Z][a-z]*)*Future)$"
+  methods <- grep(pattern, names, value = TRUE)
+  if (debug) mdebug(" - methods: ", paste(sQuote(methods), collapse = ", "))
+  for (kk in seq_along(methods)) {
+    method <- methods[kk]
+    if (!exists(method, mode = "function", envir = envir, inherits = FALSE))
+      next
+    fcn <- get(method, mode = "function", envir = envir, inherits = FALSE)
+    generic <- unique(gsub(pattern, "\\1", method))
+    class <- unique(gsub(pattern, "\\2", method))
+    body <- body(fcn)
+   ## Is first argument named 'future'?  If not, workaround it
+    args <- formals(fcn)
+    if (length(args) == 0L) next ## Shouldn't really happen
+    first <- names(args)[1]
+    if (first == "...") {
+      first <- substitute(...future <- ..1)
+    } else {
+      first <- bquote(...future <- .(as.symbol(first)))
+    }
+    body <- bquote({
+      .(first)
+      callFutureHook(future = ...future, generic = .(generic), class = .(class), event = "onEnter", package = .(package))
+      res <- withVisible(.(body))
+      callFutureHook(future = ...future, generic = .(generic), class = .(class), event = "onExit", package = .(package))
+      if (res$visible) res$value else invisible(res$value)
+    })
+    body(fcn) <- body
+    assign(method, value = fcn, envir = envir, inherits = FALSE)
+    body <- fcn <- NULL
+    if (debug) mdebug(" - added hook functions to ", sQuote(method))
+  }
+}

R/zzz.R

@@ -3,7 +3,13 @@
   debug <- isTRUE(as.logical(Sys.getenv("R_FUTURE_DEBUG", FALSE)))
   if (debug) options(future.debug = TRUE)
   debug <- getOption("future.debug", debug)
-
+
+  ## Enable hook functions throughout the future ecosystem?
+  hooks <- isTRUE(as.logical(Sys.getenv("R_FUTURE_HOOKS", FALSE)))
+  if (hooks) options(future.hooks = TRUE)
+  hooks <- getOption("future.hooks", hooks)
+  if (hooks) injectFutureHooks()
+
   ## Automatically play nice when 'R CMD check' runs?
   if (isTRUE(as.logical(Sys.getenv("R_FUTURE_R_CMD_CHECK_NICE", TRUE))) && inRCmdCheck()) {
     if (debug) mdebug("Detected 'R CMD check':\n - adjusting defaults to be a good citizen")