First draft of auto-reload functionality

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: box
 Title: Write Reusable, Composable and Modular R Code
-Version: 1.1.3
+Version: 1.1.3.9000
 Authors@R: c(
         person(
             'Konrad', 'Rudolph',

R/autoreload.r

@@ -0,0 +1,217 @@
+#' Auto-reloading of modules on change
+#'
+#' @usage \special{box::enable_autoreload(..., include, exclude, on_access = FALSE)}
+#' @param ... ignored; present to force naming arguments
+#' @param include vector of unevaluated, qualified module names to auto-reload
+#'  (optional)
+#' @param exclude vector of unevaluates, qualified module names to auto-reload
+#'  (optional)
+#' @param on_access logical value specifying whether to reload modules every
+#'  time they are used, or only when they are being loaded via \code{box::use}.
+#' @return \code{enable_autoreload} is called for its side effect and does not
+#'  return a value.
+#' @details
+#' \code{include} and \code{exclude}, when given, are either single,
+#' unevaluated, qualified module names (e.g. \code{./a}; \code{my/mod}) or
+#' vectors of such module names (e.g. \code{c(./a, my/mod)}).
+#' @name auto-reload
+#' @export
+enable_autoreload = function (..., include, exclude, on_access = FALSE) {
+    autoreload$init(on_access)
+    includes = spec_list(substitute(include))
+    excludes = spec_list(substitute(exclude))
+    caller = parent.frame()
+    map(autoreload$add_include, includes, list(caller))
+    map(autoreload$add_exclude, excludes, list(caller))
+    invisible()
+}
+
+#' @rdname auto-reload
+#' @export
+disable_autoreload = function () {
+    autoreload$reset()
+    invisible()
+}
+
+#' @rdname auto-reload
+#' @export
+autoreload_include = function (...) {
+    caller = parent.frame()
+    includes = match.call(expand.dots = FALSE)$...
+    map(autoreload$add_include, includes, list(caller))
+    invisible()
+}
+
+#' @rdname auto-reload
+#' @export
+autoreload_exclude = function (...) {
+    caller = parent.frame()
+    excludes = match.call(expand.dots = FALSE)$...
+    map(autoreload$add_exclude, excludes, list(caller))
+    invisible()
+}
+
+spec_list = function (specs) {
+    if (identical(specs, quote(expr =))) {
+        list()
+    } else if (is.call(specs) && identical(specs[[1L]], quote(c))) {
+        specs[-1L]
+    } else {
+        list(specs)
+    }
+}
+
+autoreload = local({
+    self = environment()
+    top = topenv()
+
+    init = function (on_access) {
+        reset()
+        if (on_access) {
+            self$export_env_class = export_env_class_reload
+            self$import_into_env = import_into_env_reload
+        }
+        self$is_mod_loaded = is_mod_loaded_reload
+    }
+
+    reset = function () {
+        self$includes = character()
+        self$excludes = character()
+        self$is_mod_loaded = is_mod_loaded_basic
+        self$export_env_class = export_env_class_basic
+        self$import_into_env = import_into_env_basic
+    }
+
+    add_include = function (spec, caller) {
+        spec = parse_spec(spec, '')
+        info = find_mod(spec, caller)
+
+        if (length(self$includes) > 0L) {
+            self$includes = c(self$includes, info$source_path)
+        } else if (length(self$excludes) > 0L) {
+            self$excludes = setdiff(self$excludes, info$source_path)
+        } else {
+            self$includes = info$source_path
+        }
+    }
+
+    add_exclude = function (spec, caller) {
+        spec = parse_spec(spec, '')
+        info = find_mod(spec, caller)
+
+        if (length(self$includes) > 0L) {
+            self$includes = setdiff(self$includes, info$source_path)
+        } else {
+            self$excludes = c(self$excludes, info$source_path)
+        }
+    }
+
+    included = function (info) {
+        path = info$source_path
+
+        if (length(includes) == 0L) {
+            ! path %in% excludes
+        } else {
+            path %in% includes
+        }
+    }
+
+    extract = function (e1, e2) {
+        ns = attr(e1, 'namespace')
+        info = namespace_info(ns, 'info')
+        new_mod = if (needs_reloading(info, ns)) {
+            spec = attr(e1, 'spec')
+            parent = attr(e1, 'parent')
+            load_and_register(spec, info, parent)
+            get(spec$alias, envir = parent, inherits = FALSE)
+        } else {
+            e1
+        }
+
+        strict_extract(new_mod, e2)
+    }
+
+    export_env_class_basic = function (info, ns) {
+        'box$mod'
+    }
+
+    export_env_class_reload = function (info) {
+        c(if (included(info)) 'box$autoreload', 'box$mod')
+    }
+
+    is_mod_loaded_basic = function (info) {
+        info$source_path %in% names(loaded_mods)
+    }
+
+    is_mod_loaded_reload = function (info) {
+        is_mod_loaded_basic(info) && ! needs_reloading(info, loaded_mod(info))
+    }
+
+    import_into_env_basic = function (spec, info, to_env, to_names, from_env, from_names) {
+        top$import_into_env(to_env, to_names, from_env, from_names)
+    }
+
+    import_into_env_reload = function (spec, info, to_env, to_names, from_env, from_names) {
+        foreach(function (from, to) {
+            fun = if (
+                exists(from, from_env, inherits = FALSE) &&
+                bindingIsActive(from, from_env) &&
+                ! inherits(active_binding_function(from, from_env), 'box$placeholder')
+            ) {
+                function (value) {
+                    new_env = if (needs_reloading(info, from_env)) {
+                        load_and_register(spec, info, to_env)
+                        loaded_mod(info)
+                    } else {
+                        from_env
+                    }
+
+                    fun = active_binding_function(from, new_env)
+                    fun(value)
+                }
+            } else {
+                function () {
+                    new_env = if (needs_reloading(info, from_env)) {
+                        load_and_register(spec, info, to_env)
+                        loaded_mod(info)
+                    } else {
+                        from_env
+                    }
+                    get(from, envir = new_env)
+                }
+            }
+            makeActiveBinding(to, fun, to_env)
+        }, from_names, to_names)
+    }
+
+    needs_reloading = function (info, ns) {
+        UseMethod('needs_reloading')
+    }
+
+    `needs_reloading.box$mod_info` = function (info, ns) {
+        included(info) && (
+            is_file_modified(info, ns) || {
+                imports = namespace_info(ns, 'imports')
+                any(map_lgl(function (x) needs_reloading(x$info, x$ns), imports))
+            }
+        )
+    }
+
+    `needs_reloading.box$pkg_info` = function (info, ns) {
+        FALSE
+    }
+
+    reset()
+
+    self
+})
+
+add_timestamp = function (info, ns) {
+    timestamp = file.mtime(info$source_path)
+    namespace_info(ns, 'timestamp') = timestamp
+}
+
+is_file_modified = function (info, ns) {
+    timestamp = namespace_info(ns, 'timestamp')
+    file.mtime(info$source_path) > timestamp
+}

R/env.r

@@ -153,13 +153,25 @@ make_export_env = function (info, spec, ns) {
     structure(
         new.env(parent = emptyenv()),
         name = paste0('mod:', spec_name(spec)),
-        class = 'box$mod',
+        class = export_env_class(info),
         spec = spec,
         info = info,
         namespace = ns
     )
 }
 
+export_env_class = function (info) {
+    UseMethod('export_env_class')
+}
+
+`export_env_class.box$mod_info` = function (info) {
+    autoreload$export_env_class(info)
+}
+
+`export_env_class.box$pkg_info` = function (info) {
+    'box$mod'
+}
+
 strict_extract = function (e1, e2) {
     # Implemented in C since this function is called very frequently and needs
     # to be fast, and the C implementation is about 270% faster than an R
@@ -176,6 +188,9 @@ strict_extract = function (e1, e2) {
 #' @export
 `$.box$ns` = strict_extract
 
+#' @export
+`$.box$autoreload` = autoreload$extract
+
 #' @export
 `print.box$mod` = function (x, ...) {
     spec = attr(x, 'spec')
@@ -212,17 +227,17 @@ find_import_env.environment = function (x, spec, info, mod_ns) {
 }
 
 import_into_env = function (to_env, to_names, from_env, from_names) {
-    for (i in seq_along(to_names)) {
+    foreach(function (from, to) {
         if (
-            exists(from_names[i], from_env, inherits = FALSE)
-            && bindingIsActive(from_names[i], from_env)
-            && ! inherits((fun = activeBindingFunction(from_names[i], from_env)), 'box$placeholder')
+            exists(from, from_env, inherits = FALSE)
+            && bindingIsActive(from, from_env)
+            && ! inherits((fun = activeBindingFunction(from, from_env)), 'box$placeholder')
         ) {
-            makeActiveBinding(to_names[i], fun, to_env)
+            makeActiveBinding(to, fun, to_env)
         } else {
-            assign(to_names[i], env_get(from_env, from_names[i]), envir = to_env)
+            assign(to, env_get(from_env, from), envir = to_env)
         }
-    }
+    }, from_names, to_names)
 }
 
 env_get = function (env, name) {

R/loaded.r

@@ -29,14 +29,19 @@ loaded_mods = new.env(parent = emptyenv())
 #' @param info the mod info of a module
 #' @rdname loaded
 is_mod_loaded = function (info) {
-    info$source_path %in% names(loaded_mods)
+    autoreload$is_mod_loaded(info)
 }
 
 #' @param mod_ns module namespace environment
 #' @rdname loaded
 register_mod = function (info, mod_ns) {
     loaded_mods[[info$source_path]] = mod_ns
-    attr(loaded_mods[[info$source_path]], 'loading') = TRUE
+    # The timestamp is saved *before* the source file is loaded to prevent race
+    # conditions in the presence of concurrent file modifications.
+    # At worst, this means loading the module redundantly in auto-reload mode.
+    # Doing it the other way round might cause file changes not to be noticed.
+    add_timestamp(info, mod_ns)
+    namespace_info(loaded_mods[[info$source_path]], 'loading') = TRUE
 }
 
 #' @rdname loaded
@@ -54,10 +59,10 @@ loaded_mod = function (info) {
 #' @rdname loaded
 is_mod_still_loading = function (info) {
     # pkg_info has no `source_path` but already finished loading anyway.
-    ! is.null(info$source_path) && attr(loaded_mods[[info$source_path]], 'loading')
+    ! is.null(info$source_path) && namespace_info(loaded_mods[[info$source_path]], 'loading')
 }
 
 #' @rdname loaded
 mod_loading_finished = function (info, mod_ns) {
-    attr(loaded_mods[[info$source_path]], 'loading') = FALSE
+    namespace_info(loaded_mods[[info$source_path]], 'loading') = FALSE
 }

R/map.r

@@ -8,6 +8,8 @@
 #' \sQuote{Examples}).
 #' \code{transpose} is a special \code{map} application that concatenates its
 #' inputs to compute a transposed list.
+#' \code{foreach} is a special \code{map} application that does not return a
+#' value; it is therefore expected that \code{.f} causes a side-effect.
 #' @param .f an n-ary function where n is the number of further arguments given
 #' @param \dots lists of arguments to map over in parallel
 #' @param .default the default value returned by \code{flatmap} for an empty
@@ -77,3 +79,12 @@ map_chr = function (.f, ...) {
 transpose = function (...) {
     map(c, ...)
 }
+
+#' @return \code{foreach} does not return any value.
+#' @rdname map
+foreach = function (.f, ...) {
+    args = list(...)
+    for (i in seq_along(..1)) {
+        do.call(.f, lapply(args, `[[`, i))
+    }
+}

R/use.r

@@ -455,7 +455,11 @@ attach_to_caller = function (spec, info, mod_exports, mod_ns, caller) {
 
     import_env = find_import_env(caller, spec, info, mod_ns)
     attr(mod_exports, 'attached') = environmentName(import_env)
-    import_into_env(import_env, names(attach_list), mod_exports, attach_list)
+    autoreload$import_into_env(
+        spec, info,
+        import_env, names(attach_list),
+        mod_ns, attach_list
+    )
 }
 
 #' @return \code{attach_list} returns a named character vector of the names in
@@ -499,6 +503,7 @@ assign_alias = function (spec, mod_exports, caller) {
     if (exists(spec$alias, caller, inherits = FALSE) && bindingIsLocked(spec$alias, caller)) {
         box_unlock_binding(spec$alias, caller)
     }
+    attr(mod_exports, 'parent') = caller
     assign(spec$alias, mod_exports, envir = caller)
 }
 

tests/testthat/helper-debug.r

@@ -2,6 +2,14 @@ clear_mods = function () {
     rm(list = names(box:::loaded_mods), envir = box:::loaded_mods)
 }
 
+# Undo “user-friendly” stack traces to make them more useful.
+utils::assignInNamespace(
+    'rethrow_on_error',
+    function (expr, call) expr,
+    ns = getNamespace('box'),
+    envir = getNamespace('box')
+)
+
 .setup_fun = NULL
 .teardown_fun = NULL