From 8673452132a721a0b2c8610a17d4ac79996e0f32 Mon Sep 17 00:00:00 2001 From: Thomas Mailund Date: Fri, 23 Mar 2018 09:18:39 +0100 Subject: [PATCH] Cleanup run... --- R/callbacks.R | 47 ++++++++++++++---------- R/depth-first-traversals.R | 18 ++++++--- R/helpers.R | 1 - R/static-analysis.R | 4 +- tests/testthat/test-condition-handling.R | 31 ++++++++-------- tests/testthat/test-static-analysis.R | 24 ++++++------ 6 files changed, 70 insertions(+), 55 deletions(-) diff --git a/R/callbacks.R b/R/callbacks.R index bb8b88e..4f2e2f9 100644 --- a/R/callbacks.R +++ b/R/callbacks.R @@ -162,7 +162,8 @@ add_call_callback <- function(callbacks, fn, cb) { call_name <- as.character(expr[[1]]) if (call_name %in% names(params)) { return(next_cb( - expr, env = env, params = params, wflags = wflags, ... + expr, + env = env, params = params, wflags = wflags, ... )) } # The same goes for other bound variables, if we have annotated @@ -178,18 +179,20 @@ add_call_callback <- function(callbacks, fn, cb) { )) } return(next_cb( - expr, env = env, params = params, wflags = wflags, ... + expr, + env = env, params = params, wflags = wflags, ... )) } # now try to get the actual function by evaluating it err_fun <- function(e) { - if (wflags$warn_on_unknown_function) - warning(paste0( - "The function ", call_name, - " could not be evaluated to an actual function in ", - "this scope." - )) + if (wflags$warn_on_unknown_function) { + warning(paste0( + "The function ", call_name, + " could not be evaluated to an actual function in ", + "this scope." + )) + } NULL } fun <- tryCatch(eval(expr[[1]], env), error = err_fun) @@ -202,7 +205,8 @@ add_call_callback <- function(callbacks, fn, cb) { } else { # default for closure: try the next in line next_cb( - expr, env = env, params = params, wflags = wflags, ... + expr, + env = env, params = params, wflags = wflags, ... ) } } @@ -245,7 +249,8 @@ add_topdown_callback <- function(callbacks, fn, cb) { call_name <- as.character(expr[[1]]) if (call_name %in% names(params)) { return(next_cb( - expr, env = env, params = params, wflags = wflags, ... + expr, + env = env, params = params, wflags = wflags, ... )) } # The same goes for other bound variables, if we have annotated @@ -261,30 +266,34 @@ add_topdown_callback <- function(callbacks, fn, cb) { )) } return(next_cb( - expr, env = env, params = params, wflags = wflags, ... + expr, + env = env, params = params, wflags = wflags, ... )) } # now try to get the actual function by evaluating it err_fun <- function(e) { - if (wflags$warn_on_unknown_function) - warning(paste0( - "The function ", call_name, - " could not be evaluated to an actual function in ", - "this scope." - )) + if (wflags$warn_on_unknown_function) { + warning(paste0( + "The function ", call_name, + " could not be evaluated to an actual function in ", + "this scope." + )) + } NULL } fun <- tryCatch(eval(expr[[1]], env), error = err_fun) if (!is.null(fun) && identical(fun, fn)) { return(cb( - expr, env = env, params = params, + expr, + env = env, params = params, next_cb = next_cb, wflags = wflags, ... )) } else { # default for closure: try the next in line next_cb( - expr, env = env, params = params, + expr, + env = env, params = params, wflags = wflags, ... ) } diff --git a/R/depth-first-traversals.R b/R/depth-first-traversals.R index 023c764..7ea70a2 100644 --- a/R/depth-first-traversals.R +++ b/R/depth-first-traversals.R @@ -20,22 +20,26 @@ depth_first_rewrite_expr <- function(expr, callbacks, topdown, wflags, ...) { if (rlang::is_atomic(expr)) { return(callbacks$atomic( - expr, topdown = topdown, wflags = wflags, ... + expr, + topdown = topdown, wflags = wflags, ... )) } if (rlang::is_pairlist(expr)) { return(callbacks$pairlist( - expr, topdown = topdown, wflags = wflags, ... + expr, + topdown = topdown, wflags = wflags, ... )) } if (rlang::is_symbol(expr)) { return(callbacks$symbol( - expr, topdown = topdown, wflags = wflags, ... + expr, + topdown = topdown, wflags = wflags, ... )) } if (rlang::is_primitive(expr)) { return(callbacks$primitive( - expr, topdown = topdown, wflags = wflags, ... + expr, + topdown = topdown, wflags = wflags, ... )) } @@ -45,7 +49,8 @@ depth_first_rewrite_expr <- function(expr, callbacks, topdown, wflags, skip <- function() escape(expr) # skip means leaving the body unchanged # collect topdown info. topdown <- callbacks$topdown( - expr, topdown = topdown, wflags = wflags, skip = skip, ... + expr, + topdown = topdown, wflags = wflags, skip = skip, ... ) # handle depth first @@ -60,7 +65,8 @@ depth_first_rewrite_expr <- function(expr, callbacks, topdown, wflags, # then handle the actual call callbacks$call( - expr, topdown = topdown, wflags = wflags, ... + expr, + topdown = topdown, wflags = wflags, ... ) }) } diff --git a/R/helpers.R b/R/helpers.R index f7d3cb9..a6f3e0d 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -57,4 +57,3 @@ collect_from_args <- function(expr, attribute, } collected } - diff --git a/R/static-analysis.R b/R/static-analysis.R index 50f8d9a..0367bd2 100644 --- a/R/static-analysis.R +++ b/R/static-analysis.R @@ -150,8 +150,8 @@ propagate_assigned_symbols_callback <- function(expr, ...) { collect_bound_variables_callback <- function(expr, topdown, ...) { bound <- c(topdown, attr(expr, "assigned_symbols")) if (expr[[1]] == "function") { - bound <- c(names(expr[[2]]), bound) - } + bound <- c(names(expr[[2]]), bound) + } bound # passed as `topdown` to the rewrite callback } diff --git a/tests/testthat/test-condition-handling.R b/tests/testthat/test-condition-handling.R index 4a5ec78..af357cd 100644 --- a/tests/testthat/test-condition-handling.R +++ b/tests/testthat/test-condition-handling.R @@ -1,22 +1,21 @@ context("Error and warning handling") test_that("we can set and unset warning flags", { - wflags <- warning_flags() - expect_true(wflags$warn_on_unknown_function) - expect_true(wflags$warn_on_local_function) + wflags <- warning_flags() + expect_true(wflags$warn_on_unknown_function) + expect_true(wflags$warn_on_local_function) - wflags <- warning_flags() %>% unset_warn_on_unknown_function() - expect_false(wflags$warn_on_unknown_function) - expect_true(wflags$warn_on_local_function) - wflags <- wflags %>% set_warn_on_unknown_function() - expect_true(wflags$warn_on_unknown_function) - expect_true(wflags$warn_on_local_function) - - wflags <- warning_flags() %>% unset_warn_on_local_function() - expect_true(wflags$warn_on_unknown_function) - expect_false(wflags$warn_on_local_function) - wflags <- wflags %>% set_warn_on_local_function() - expect_true(wflags$warn_on_unknown_function) - expect_true(wflags$warn_on_local_function) + wflags <- warning_flags() %>% unset_warn_on_unknown_function() + expect_false(wflags$warn_on_unknown_function) + expect_true(wflags$warn_on_local_function) + wflags <- wflags %>% set_warn_on_unknown_function() + expect_true(wflags$warn_on_unknown_function) + expect_true(wflags$warn_on_local_function) + wflags <- warning_flags() %>% unset_warn_on_local_function() + expect_true(wflags$warn_on_unknown_function) + expect_false(wflags$warn_on_local_function) + wflags <- wflags %>% set_warn_on_local_function() + expect_true(wflags$warn_on_unknown_function) + expect_true(wflags$warn_on_local_function) }) diff --git a/tests/testthat/test-static-analysis.R b/tests/testthat/test-static-analysis.R index 2921f49..3a46bc6 100644 --- a/tests/testthat/test-static-analysis.R +++ b/tests/testthat/test-static-analysis.R @@ -157,15 +157,15 @@ test_that("we can annotate with the symbols in a simple function", { test_that("we hande `=` assignments as well", { f <- function() { - x = 42 + x <- 42 } res <- annotate_bound_symbols_in_function(f) expect_equal(attr(body(res), "assigned_symbols"), "x") expect_equal(attr(body(res), "bound"), "x") f <- function() { - x = 42 - y = 24 + x <- 42 + y <- 24 x + y } res <- annotate_bound_symbols_in_function(f) @@ -175,7 +175,7 @@ test_that("we hande `=` assignments as well", { # when there is a formal parameter, that is also a bound variable # although it is not an assigned symbol. f <- function(x = 42) { - y = 24 + y <- 24 x + y } res <- annotate_bound_symbols_in_function(f) @@ -187,8 +187,8 @@ test_that("we hande `=` assignments as well", { # of this function, we do assign to `x`, so we include it in # the annotation. It defintely belongs in the bound variables. f <- function(x = 42) { - x = 42 - y = 24 + x <- 42 + y <- 24 x + y } res <- annotate_bound_symbols_in_function(f) @@ -197,9 +197,9 @@ test_that("we hande `=` assignments as well", { # we shouldn't include duplications f <- function(x = 42) { - y = x - x = 42 - y = x + 2 + y <- x + x <- 42 + y <- x + 2 x + y } res <- annotate_bound_symbols_in_function(f) @@ -335,7 +335,9 @@ test_that("we can handle local functions", { g <- function() stop("outer") cb <- rewrite_callbacks() %>% add_call_callback(g, function(expr, ...) stop("don't call this")) - expect_warning(res <- depth_first_rewrite_function(f_an, cb), - "The function g is not processed .*") + expect_warning( + res <- depth_first_rewrite_function(f_an, cb), + "The function g is not processed .*" + ) expect_equal(body(f_an), body(res)) })