Use new xml_nodes_to_lint() in existing codebase (#964)

Author: MichaelChirico

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.")
     )
   })
 }

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")
+  })
 }

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")
-}

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")
-}

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.<k>(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.<k>(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

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")
-}

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.<t>(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.<t>(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.<type> form, e.g. 'any' or

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()."
+    )
+  }
 }