diff --git a/R/T_and_F_symbol_linter.R b/R/T_and_F_symbol_linter.R index b1e6a6643..e71f5eb88 100644 --- a/R/T_and_F_symbol_linter.R +++ b/R/T_and_F_symbol_linter.R @@ -36,28 +36,23 @@ T_and_F_symbol_linter <- function() { # nolint: object_name_linter. bad_exprs <- xml2::xml_find_all(source_file$xml_parsed_content, xpath) bad_assigns <- xml2::xml_find_all(source_file$xml_parsed_content, xpath_assignment) + replacement_map <- c(T = "TRUE", F = "FALSE") make_lint <- function(expr, fmt) { - symbol <- xml2::xml_text(expr) - replacement <- switch(symbol, "T" = "TRUE", "F" = "FALSE") - message <- sprintf(fmt, replacement, symbol) xml_nodes_to_lint( xml = expr, source_file = source_file, - lint_message = message, + lint_message = function(expr) { + symbol <- xml2::xml_text(expr) + sprintf(fmt, replacement_map[[symbol]], symbol) + }, type = "style", offset = 1L ) } c( - lapply( - bad_exprs, make_lint, - fmt = "Use %s instead of the symbol %s." - ), - lapply( - bad_assigns, make_lint, - fmt = "Don't use %2$s as a variable name, as it can break code relying on %2$s being %1$s." - ) + lapply(bad_exprs, make_lint, fmt = "Use %s instead of the symbol %s."), + lapply(bad_assigns, make_lint, fmt = "Don't use %2$s as a variable name, as it can break code relying on %2$s being %1$s.") ) }) } diff --git a/R/assignment_linter.R b/R/assignment_linter.R index f07b3093c..64e164c5a 100644 --- a/R/assignment_linter.R +++ b/R/assignment_linter.R @@ -27,19 +27,22 @@ assignment_linter <- function(allow_cascading_assign = TRUE, allow_right_assign )) bad_expr <- xml2::xml_find_all(xml, xpath) - lapply(bad_expr, gen_assignment_lint, source_file) - }) -} - -gen_assignment_lint <- function(expr, source_file) { - operator <- xml2::xml_text(expr) - if (operator %in% c("<<-", "->>")) { - message <- sprintf( - "%s can have hard-to-predict behavior; prefer assigning to a specific environment instead (with assign() or <-).", - operator + lapply( + bad_expr, + xml_nodes_to_lint, + source_file, + function(expr) { + operator <- xml2::xml_text(expr) + if (operator %in% c("<<-", "->>")) { + sprintf( + "%s can have hard-to-predict behavior; prefer assigning to a specific environment instead (with assign() or <-).", + operator + ) + } else { + sprintf("Use <-, not %s, for assignment.", operator) + } + }, + type = "style" ) - } else { - message <- sprintf("Use <-, not %s, for assignment.", operator) - } - xml_nodes_to_lint(expr, source_file, message, type = "style") + }) } diff --git a/R/expect_length_linter.R b/R/expect_length_linter.R index ee147d4c8..9c67b488b 100644 --- a/R/expect_length_linter.R +++ b/R/expect_length_linter.R @@ -25,12 +25,15 @@ expect_length_linter <- function() { ]") bad_expr <- xml2::xml_find_all(xml, xpath) - return(lapply(bad_expr, gen_expect_length_lint, source_file)) + return(lapply( + bad_expr, + xml_nodes_to_lint, + source_file, + function(expr) { + matched_function <- xml2::xml_text(xml2::xml_find_first(expr, "SYMBOL_FUNCTION_CALL")) + sprintf("expect_length(x, n) is better than %s(length(x), n)", matched_function) + }, + type = "warning" + )) }) } - -gen_expect_length_lint <- function(expr, source_file) { - matched_function <- xml2::xml_text(xml2::xml_find_first(expr, "SYMBOL_FUNCTION_CALL")) - lint_msg <- sprintf("expect_length(x, n) is better than %s(length(x), n)", matched_function) - xml_nodes_to_lint(expr, source_file, lint_msg, type = "warning") -} diff --git a/R/expect_null_linter.R b/R/expect_null_linter.R index 7849f3e4c..9aef26539 100644 --- a/R/expect_null_linter.R +++ b/R/expect_null_linter.R @@ -34,16 +34,19 @@ expect_null_linter <- function() { bad_expr <- xml2::xml_find_all(xml, xpath) - lapply(bad_expr, gen_expect_null_lint, source_file) + lapply( + bad_expr, + xml_nodes_to_lint, + source_file, + function(expr) { + matched_function <- xml2::xml_text(xml2::xml_find_first(expr, "SYMBOL_FUNCTION_CALL")) + if (matched_function %in% c("expect_equal", "expect_identical")) { + sprintf("expect_null(x) is better than %s(x, NULL)", matched_function) + } else { + "expect_null(x) is better than expect_true(is.null(x))" + } + }, + type = "warning" + ) }) } - -gen_expect_null_lint <- function(expr, source_file) { - matched_function <- xml2::xml_text(xml2::xml_find_first(expr, "SYMBOL_FUNCTION_CALL")) - if (matched_function %in% c("expect_equal", "expect_identical")) { - lint_msg <- sprintf("expect_null(x) is better than %s(x, NULL)", matched_function) - } else { - lint_msg <- "expect_null(x) is better than expect_true(is.null(x))" - } - xml_nodes_to_lint(expr, source_file, lint_msg, type = "warning") -} diff --git a/R/expect_s3_class_linter.R b/R/expect_s3_class_linter.R index ac4f9f73b..88dcfd16d 100644 --- a/R/expect_s3_class_linter.R +++ b/R/expect_s3_class_linter.R @@ -33,7 +33,21 @@ expect_s3_class_linter <- function() { ]") bad_expr <- xml2::xml_find_all(xml, xpath) - return(lapply(bad_expr, gen_expect_s3_class_lint, source_file)) + return(lapply( + bad_expr, + xml_nodes_to_lint, + source_file, + function(expr) { + matched_function <- xml2::xml_text(xml2::xml_find_first(expr, "SYMBOL_FUNCTION_CALL")) + if (matched_function %in% c("expect_equal", "expect_identical")) { + lint_msg <- sprintf("expect_s3_class(x, k) is better than %s(class(x), k).", matched_function) + } else { + lint_msg <- "expect_s3_class(x, k) is better than expect_true(is.(x)) or expect_true(inherits(x, k))." + } + paste(lint_msg, "Note also expect_s4_class() available for testing S4 objects.") + }, + type = "warning" + )) }) } @@ -55,17 +69,6 @@ is_s3_class_calls <- paste0("is.", c( "mts", "stepfun", "ts", "tskernel" )) -gen_expect_s3_class_lint <- function(expr, source_file) { - matched_function <- xml2::xml_text(xml2::xml_find_first(expr, "SYMBOL_FUNCTION_CALL")) - if (matched_function %in% c("expect_equal", "expect_identical")) { - lint_msg <- sprintf("expect_s3_class(x, k) is better than %s(class(x), k).", matched_function) - } else { - lint_msg <- "expect_s3_class(x, k) is better than expect_true(is.(x)) or expect_true(inherits(x, k))." - } - lint_msg <- paste(lint_msg, "Note also expect_s4_class() available for testing S4 objects.") - xml_nodes_to_lint(expr, source_file, lint_msg, type = "warning") -} - #' Require usage of expect_s4_class(x, k) over expect_true(is(x, k)) #' #' [testthat::expect_s4_class()] exists specifically for testing the class diff --git a/R/expect_true_false_linter.R b/R/expect_true_false_linter.R index 2d5dd1d09..c7f84ec42 100644 --- a/R/expect_true_false_linter.R +++ b/R/expect_true_false_linter.R @@ -22,18 +22,21 @@ expect_true_false_linter <- function() { ]]" bad_expr <- xml2::xml_find_all(xml, xpath) - return(lapply(bad_expr, gen_expect_true_false_lint, source_file)) + return(lapply( + bad_expr, + xml_nodes_to_lint, + source_file, + function(expr) { + # NB: use expr/$node, not expr[$node], to exclude other things (especially ns:: parts of the call) + call_name <- xml2::xml_text(xml2::xml_find_first(expr, "expr/SYMBOL_FUNCTION_CALL[starts-with(text(), 'expect_')]")) + truth_value <- xml2::xml_text(xml2::xml_find_first(expr, "expr/NUM_CONST[text() = 'TRUE' or text() = 'FALSE']")) + if (truth_value == "TRUE") { + sprintf("expect_true(x) is better than %s(x, TRUE)", call_name) + } else { + sprintf("expect_false(x) is better than %s(x, FALSE)", call_name) + } + }, + type = "warning" + )) }) } - -gen_expect_true_false_lint <- function(expr, source_file) { - # NB: use expr/$node, not expr[$node], to exclude other things (especially ns:: parts of the call) - call_name <- xml2::xml_text(xml2::xml_find_first(expr, "expr/SYMBOL_FUNCTION_CALL[starts-with(text(), 'expect_')]")) - truth_value <- xml2::xml_text(xml2::xml_find_first(expr, "expr/NUM_CONST[text() = 'TRUE' or text() = 'FALSE']")) - if (truth_value == "TRUE") { - lint_msg <- sprintf("expect_true(x) is better than %s(x, TRUE)", call_name) - } else { - lint_msg <- sprintf("expect_false(x) is better than %s(x, FALSE)", call_name) - } - xml_nodes_to_lint(expr, source_file, lint_msg, type = "warning") -} diff --git a/R/expect_type_linter.R b/R/expect_type_linter.R index 9281d2cce..eca4be394 100644 --- a/R/expect_type_linter.R +++ b/R/expect_type_linter.R @@ -31,21 +31,23 @@ expect_type_linter <- function() { ]") bad_expr <- xml2::xml_find_all(xml, xpath) - return(lapply(bad_expr, gen_expect_type_lint, source_file)) + return(lapply( + bad_expr, + xml_nodes_to_lint, + source_file, + function(expr) { + matched_function <- xml2::xml_text(xml2::xml_find_first(expr, "SYMBOL_FUNCTION_CALL")) + if (matched_function %in% c("expect_equal", "expect_identical")) { + sprintf("expect_type(x, t) is better than %s(typeof(x), t)", matched_function) + } else { + "expect_type(x, t) is better than expect_true(is.(x))" + } + }, + type = "warning" + )) }) } -gen_expect_type_lint <- function(expr, source_file) { - matched_function <- xml2::xml_text(xml2::xml_find_first(expr, "SYMBOL_FUNCTION_CALL")) - if (matched_function %in% c("expect_equal", "expect_identical")) { - lint_msg <- sprintf("expect_type(x, t) is better than %s(typeof(x), t)", matched_function) - } else { - lint_msg <- "expect_type(x, t) is better than expect_true(is.(x))" - } - xml_nodes_to_lint(expr, source_file, lint_msg, type = "warning") -} - - # NB: the full list of values that can arise from `typeof(x)` is available # in ?typeof (or, slightly more robustly, in the R source: src/main/util.c. # Not all of them are available in is. form, e.g. 'any' or diff --git a/R/package_hooks_linter.R b/R/package_hooks_linter.R index eba3f3ac6..3621b89f4 100644 --- a/R/package_hooks_linter.R +++ b/R/package_hooks_linter.R @@ -52,7 +52,7 @@ package_hooks_linter <- function() { bad_msg_call_lints <- function(hook) { xpath <- sprintf(bad_msg_call_xpath_fmt, hook, xp_text_in_table(bad_calls[[hook]])) bad_expr <- xml2::xml_find_all(xml, xpath) - lapply(bad_expr, make_bad_call_lint, source_file, hook) + lapply(bad_expr, xml_nodes_to_lint, source_file, make_bad_call_lint_msg(hook), type = "warning") } onload_bad_msg_call_lints <- bad_msg_call_lints(".onLoad") @@ -77,13 +77,13 @@ package_hooks_linter <- function() { load_arg_name_lints <- lapply( load_arg_name_expr, - function(expr) { - message <- sprintf( - "%s() should take two arguments, with the first starting with 'lib' and the second starting with 'pkg'.", - get_hook(expr) - ) - xml_nodes_to_lint(expr, source_file, message, type = "warning") - } + xml_nodes_to_lint, + source_file, + function(expr) sprintf( + "%s() should take two arguments, with the first starting with 'lib' and the second starting with 'pkg'.", + get_hook(expr) + ), + type = "warning" ) # (3) .onLoad() and .onAttach() shouldn't call require(), library(), or installed.packages() @@ -100,16 +100,18 @@ package_hooks_linter <- function() { library_require_lints <- lapply( library_require_expr, + xml_nodes_to_lint, + source_file, function(expr) { bad_call <- xml2::xml_text(expr) hook <- get_hook(expr) if (bad_call == "installed.packages") { - message <- sprintf("Don't slow down package load by running installed.packages() in %s().", hook) + sprintf("Don't slow down package load by running installed.packages() in %s().", hook) } else { - message <- sprintf("Don't alter the search() path in %s() by calling %s().", hook, bad_call) + sprintf("Don't alter the search() path in %s() by calling %s().", hook, bad_call) } - xml_nodes_to_lint(expr, source_file, message, type = "warning") - } + }, + type = "warning" ) # (4) .Last.lib() and .onDetach() shouldn't call library.dynam.unload() @@ -123,10 +125,10 @@ package_hooks_linter <- function() { bad_unload_call_lints <- lapply( bad_unload_call_expr, - function(expr) { - message <- sprintf("Use library.dynam.unload() calls in .onUnload(), not %s().", get_hook(expr)) - xml_nodes_to_lint(expr, source_file, message, type = "warning") - } + xml_nodes_to_lint, + source_file, + function(expr) sprintf("Use library.dynam.unload() calls in .onUnload(), not %s().", get_hook(expr)), + type = "warning" ) # (5) .Last.lib() and .onDetach() should take one arguments with name matching ^lib @@ -145,13 +147,10 @@ package_hooks_linter <- function() { unload_arg_name_lints <- lapply( unload_arg_name_expr, - function(expr) { - message <- sprintf( - "%s() should take one argument starting with 'lib'.", - get_hook(expr) - ) - xml_nodes_to_lint(expr, source_file, message, type = "warning") - } + xml_nodes_to_lint, + source_file, + function(expr) sprintf("%s() should take one argument starting with 'lib'.", get_hook(expr)), + type = "warning" ) return(c( @@ -165,16 +164,17 @@ package_hooks_linter <- function() { }) } -make_bad_call_lint <- function(expr, source_file, hook) { - call_name <- xml2::xml_text(expr) - message <- switch( - call_name, - cat = , - message = , - print = , - writeLines = sprintf("Don't use %s() in %s().", call_name, hook), - packageStartupMessage = "Put packageStartupMessage() calls in .onAttach(), not .onLoad().", - library.dynam = "Put library.dynam() calls in .onLoad, not .onAttach()." - ) - xml_nodes_to_lint(expr, source_file, message, type = "warning") +make_bad_call_lint_msg <- function(hook) { + function(expr) { + call_name <- xml2::xml_text(expr) + switch( + call_name, + cat = , + message = , + print = , + writeLines = sprintf("Don't use %s() in %s().", call_name, hook), + packageStartupMessage = "Put packageStartupMessage() calls in .onAttach(), not .onLoad().", + library.dynam = "Put library.dynam() calls in .onLoad, not .onAttach()." + ) + } }