diff --git a/DESCRIPTION b/DESCRIPTION index abde76ca..50c1644e 100644 --- a/DESCRIPTION +++ b/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', diff --git a/R/autoreload.r b/R/autoreload.r new file mode 100644 index 00000000..c4ec01bc --- /dev/null +++ b/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 +} diff --git a/R/env.r b/R/env.r index 42fef4f0..b9054e09 100644 --- a/R/env.r +++ b/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) { diff --git a/R/loaded.r b/R/loaded.r index 39d99e67..8a360753 100644 --- a/R/loaded.r +++ b/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 } diff --git a/R/map.r b/R/map.r index f68b9ee3..12e444ab 100644 --- a/R/map.r +++ b/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)) + } +} diff --git a/R/use.r b/R/use.r index 4bb0dce9..7863831c 100644 --- a/R/use.r +++ b/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) } diff --git a/tests/testthat/helper-debug.r b/tests/testthat/helper-debug.r index 2c8c63f6..b8315133 100644 --- a/tests/testthat/helper-debug.r +++ b/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 diff --git a/tests/testthat/test-autoreload.r b/tests/testthat/test-autoreload.r new file mode 100644 index 00000000..35cb9696 --- /dev/null +++ b/tests/testthat/test-autoreload.r @@ -0,0 +1,241 @@ +context('autoreload') + +tempfile_dir = function (...) { + file = tempfile() + dir.create(file) + file +} + +create_simple_test_module = function (dir) { + mod = file.path(dir, 'mod') + dir.create(mod) + a = file.path(mod, 'a.r') + writeLines(c( + 'box::use(stats)', + "#' @export", + 'f = function () 1L' + ), a) +} + +edit_simple_test_module = function (dir) { + # Ensure file modification timestamp is different. + Sys.sleep(0.001) + a = file.path(dir, 'mod', 'a.r') + writeLines(c("#' @export", 'f = function () 2L'), a) +} + +create_dependent_test_module = function (dir) { + mod = file.path(dir, 'mod') + dir.create(mod) + writeLines(c( + "#' @export", + 'box::use(b = ./b[f])', + "#' @export", + 'g = function () b$f()' + ), file.path(mod, 'a.r')) + writeLines(c("#' @export", 'f = function () 1L'), file.path(mod, 'b.r')) +} + +edit_dependent_test_module = function (dir) { + # Ensure file modification timestamp is different. + Sys.sleep(0.001) + mod = file.path(dir, 'mod') + writeLines(c("#' @export", 'f = function () 2L'), file.path(mod, 'b.r')) +} + +test_teardown(box:::autoreload$reset()) + +included = function (declaration) { + caller = parent.frame() + spec = parse_spec(substitute(declaration), '') + info = find_mod(spec, caller) + box:::autoreload$included(info) +} + +test_that('no name needs to be specified', { + expect_error(box::enable_autoreload(), NA) +}) + +test_that('a single name can be specified', { + expect_error(box::enable_autoreload(include = mod/a), NA) + expect_error(box::enable_autoreload(exclude = mod/b), NA) + + expect_error(box::autoreload_include(mod/a), NA) + expect_error(box::autoreload_exclude(mod/a), NA) +}) + +test_that('multiple names can be specified', { + expect_error(box::enable_autoreload(include = c(mod/a, mod/b)), NA) + expect_error(box::enable_autoreload(exclude = c(mod/a, mod/b)), NA) + + expect_error(box::autoreload_include(mod/a, mod/b), NA) + expect_error(box::autoreload_exclude(mod/a, mod/b), NA) +}) + +test_that('all names are included by default', { + box::enable_autoreload() + expect_true(included(mod/a)) + expect_true(included(mod/b)) + expect_true(included(mod/b/a)) + expect_true(included(mod/b/b)) +}) + +test_that('included names are excluded', { + box::enable_autoreload(include = c(mod/a, mod/b, mod/b/a)) + expect_true(included(mod/a)) + expect_true(included(mod/b)) + expect_true(included(mod/b/a)) + expect_false(included(mod/b/b)) +}) + +test_that('excluded names are not included', { + box::enable_autoreload(exclude = c(mod/a, mod/b, mod/b/a)) + expect_false(included(mod/a)) + expect_false(included(mod/b)) + expect_false(included(mod/b/a)) + expect_true(included(mod/b/b)) +}) + +test_that('names can be included after being excluded', { + box::enable_autoreload(exclude = c(mod/a, mod/b, mod/b/a)) + box::autoreload_include(mod/a, mod/b/a) + expect_true(included(mod/a)) + expect_false(included(mod/b)) + expect_true(included(mod/b/a)) + expect_true(included(mod/b/b)) +}) + +test_that('names can be excluded after being included', { + box::enable_autoreload(include = c(mod/a, mod/b, mod/b/a)) + box::autoreload_exclude(mod/a, mod/b/a) + expect_false(included(mod/a)) + expect_true(included(mod/b)) + expect_false(included(mod/b/a)) + expect_false(included(mod/b/b)) +}) + +test_that('auto-reloading simple modules works with `box::use`', { + dir = tempfile_dir() + on.exit(unlink(dir, recursive = TRUE)) + + old_path = options(box.path = dir) + on.exit(options(old_path), add = TRUE) + + create_simple_test_module(dir) + + box::enable_autoreload() + box::use(mod/a) + + expect_equal(a$f(), 1L) + + edit_simple_test_module(dir) + + box::use(mod/a) + + expect_equal(a$f(), 2L) +}) + +test_that('auto-reloading dependent modules works with `box::use`', { + dir = tempfile_dir() + on.exit(unlink(dir, recursive = TRUE)) + + old_path = options(box.path = dir) + on.exit(options(old_path), add = TRUE) + + create_dependent_test_module(dir) + + box::enable_autoreload() + box::use(mod/a) + + expect_equal(a$f(), 1L) + expect_equal(a$g(), 1L) + + + edit_dependent_test_module(dir) + + box::use(mod/a) + + expect_equal(a$f(), 2L) + expect_equal(a$g(), 2L) + +}) + +test_that('auto-reloading simple modules works with module name', { + dir = tempfile_dir() + on.exit(unlink(dir, recursive = TRUE)) + + old_path = options(box.path = dir) + on.exit(options(old_path), add = TRUE) + + create_simple_test_module(dir) + + box::enable_autoreload(on_access = TRUE) + box::use(mod/a) + + expect_equal(a$f(), 1L) + + edit_simple_test_module(dir) + + expect_equal(a$f(), 2L) +}) + +test_that('auto-reloading dependent modules works with module name', { + dir = tempfile_dir() + on.exit(unlink(dir, recursive = TRUE)) + + old_path = options(box.path = dir) + on.exit(options(old_path), add = TRUE) + + create_dependent_test_module(dir) + + box::enable_autoreload(on_access = TRUE) + box::use(mod/a) + + expect_equal(a$f(), 1L) + expect_equal(a$g(), 1L) + + edit_dependent_test_module(dir) + + expect_equal(a$f(), 2L) + expect_equal(a$g(), 2L) +}) + +test_that('auto-reloading simple modules works with attached name', { + dir = tempfile_dir() + on.exit(unlink(dir, recursive = TRUE)) + + old_path = options(box.path = dir) + on.exit(options(old_path), add = TRUE) + + create_simple_test_module(dir) + + box::enable_autoreload(on_access = TRUE) + box::use(mod/a[f]) + + expect_equal(f(), 1L) + + edit_simple_test_module(dir) + + expect_equal(f(), 2L) +}) + +test_that('auto-reloading dependent modules works with attached name', { + dir = tempfile_dir() + on.exit(unlink(dir, recursive = TRUE)) + + old_path = options(box.path = dir) + on.exit(options(old_path), add = TRUE) + + create_dependent_test_module(dir) + + box::enable_autoreload(on_access = TRUE) + box::use(mod/a[f, g]) + + expect_equal(f(), 1L) + expect_equal(g(), 1L) + + edit_dependent_test_module(dir) + + expect_equal(f(), 2L) + expect_equal(g(), 2L) +}) diff --git a/tests/testthat/test-reload.r b/tests/testthat/test-reload.r index d04b3e8f..0b93388b 100644 --- a/tests/testthat/test-reload.r +++ b/tests/testthat/test-reload.r @@ -4,11 +4,6 @@ is_module_loaded = function (path) { path %in% names(box:::loaded_mods) } -unload_all = function () { - modenv = box:::loaded_mods - rm(list = names(modenv), envir = modenv) -} - tempfile_dir = function (...) { file = tempfile() dir.create(file) @@ -28,10 +23,6 @@ edit_nested_test_module = function (dir) { } test_that('module can be reloaded', { - # Required since other tests have side-effects. - # Tear-down would be helpful here, but not supported by testthat. - unload_all() - box::use(mod/a) expect_equal(length(box:::loaded_mods), 1L) counter = a$get_counter()