Use make_linter_from_xpath() to generate simple linters (#2128)

DESCRIPTION

@@ -58,9 +58,11 @@ Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 Collate:
-    'T_and_F_symbol_linter.R'
+    'make_linter_from_xpath.R'
+    'xp_utils.R'
     'utils.R'
-    'aaa.R'
+    'AAA.R'
+    'T_and_F_symbol_linter.R'
     'absolute_path_linter.R'
     'actions.R'
     'addins.R'
@@ -126,7 +128,6 @@ Collate:
     'lintr-package.R'
     'literal_coercion_linter.R'
     'make_linter_from_regex.R'
-    'make_linter_from_xpath.R'
     'matrix_apply_linter.R'
     'methods.R'
     'missing_argument_linter.R'
@@ -182,7 +183,6 @@ Collate:
     'with.R'
     'with_id.R'
     'xml_nodes_to_lints.R'
-    'xp_utils.R'
     'yoda_test_linter.R'
     'zzz.R'
 Language: en-US

R/aaa.R → R/AAA.R

@@ -1,4 +1,6 @@
 #' @include utils.R
+#' @include xp_utils.R
+#' @include make_linter_from_xpath.R
 NULL
 
 #' Available linters

R/empty_assignment_linter.R

@@ -30,33 +30,16 @@
 #' @evalRd rd_tags("empty_assignment_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-empty_assignment_linter <- function() {
+empty_assignment_linter <- make_linter_from_xpath(
   # for some reason, the parent in the `=` case is <equal_assign>, not <expr>, hence parent::expr
-  xpath <- "
+  xpath = "
   //OP-LEFT-BRACE[following-sibling::*[1][self::OP-RIGHT-BRACE]]
     /parent::expr[
       preceding-sibling::LEFT_ASSIGN
       or preceding-sibling::EQ_ASSIGN
       or following-sibling::RIGHT_ASSIGN
     ]
     /parent::*
-  "
-
-  Linter(function(source_expression) {
-    if (!is_lint_level(source_expression, "expression")) {
-      return(list())
-    }
-
-    xml <- source_expression$xml_parsed_content
-
-    bad_expr <- xml_find_all(xml, xpath)
-
-    xml_nodes_to_lints(
-      bad_expr,
-      source_expression = source_expression,
-      lint_message =
-        "Assign NULL explicitly or, whenever possible, allocate the empty object with the right type and size.",
-      type = "warning"
-    )
-  })
-}
+  ",
+  lint_message = "Assign NULL explicitly or, whenever possible, allocate the empty object with the right type and size."
+)

R/expect_not_linter.R

@@ -22,28 +22,12 @@
 #' @evalRd rd_tags("expect_not_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-expect_not_linter <- function() {
-  xpath <- "
+expect_not_linter <- make_linter_from_xpath(
+  xpath = "
   //SYMBOL_FUNCTION_CALL[text() = 'expect_true' or text() = 'expect_false']
     /parent::expr
     /following-sibling::expr[OP-EXCLAMATION]
     /parent::expr
-  "
-
-  Linter(function(source_expression) {
-    if (!is_lint_level(source_expression, "expression")) {
-      return(list())
-    }
-
-    xml <- source_expression$xml_parsed_content
-
-    bad_expr <- xml_find_all(xml, xpath)
-
-    xml_nodes_to_lints(
-      bad_expr,
-      source_expression = source_expression,
-      lint_message = "expect_false(x) is better than expect_true(!x), and vice versa.",
-      type = "warning"
-    )
-  })
-}
+  ",
+  lint_message = "expect_false(x) is better than expect_true(!x), and vice versa."
+)

R/for_loop_index_linter.R

@@ -29,30 +29,14 @@
 #' @evalRd rd_tags("for_loop_index_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-for_loop_index_linter <- function() {
-  xpath <- "
+for_loop_index_linter <- make_linter_from_xpath(
+  xpath = "
   //forcond
     /SYMBOL[text() =
       following-sibling::expr
         //SYMBOL[not(parent::expr[OP-DOLLAR or OP-AT or preceding-sibling::OP-LEFT-BRACKET])]
         /text()
     ]
-  "
-
-  Linter(function(source_expression) {
-    if (!is_lint_level(source_expression, "expression")) {
-      return(list())
-    }
-
-    xml <- source_expression$xml_parsed_content
-
-    bad_expr <- xml_find_all(xml, xpath)
-
-    xml_nodes_to_lints(
-      bad_expr,
-      source_expression = source_expression,
-      lint_message = "Don't re-use any sequence symbols as the index symbol in a for loop.",
-      type = "warning"
-    )
-  })
-}
+  ",
+  lint_message = "Don't re-use any sequence symbols as the index symbol in a for loop."
+)

R/function_return_linter.R

@@ -55,26 +55,10 @@
 #' @evalRd rd_tags("function_return_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-function_return_linter <- function() {
-  xpath <- "
+function_return_linter <- make_linter_from_xpath(
+  xpath = "
   //SYMBOL_FUNCTION_CALL[text() = 'return']
     /parent::expr/parent::expr/expr[LEFT_ASSIGN or RIGHT_ASSIGN]
-  "
-
-  Linter(function(source_expression) {
-    if (!is_lint_level(source_expression, "expression")) {
-      return(list())
-    }
-
-    xml <- source_expression$xml_parsed_content
-
-    bad_expr <- xml_find_all(xml, xpath)
-
-    xml_nodes_to_lints(
-      bad_expr,
-      source_expression = source_expression,
-      lint_message = "Move the assignment outside of the return() clause, or skip assignment altogether.",
-      type = "warning"
-    )
-  })
-}
+  ",
+  lint_message = "Move the assignment outside of the return() clause, or skip assignment altogether."
+)

R/length_levels_linter.R

@@ -18,28 +18,12 @@
 #' @evalRd rd_tags("length_levels_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-length_levels_linter <- function() {
-  xpath <- "
+length_levels_linter <- make_linter_from_xpath(
+  xpath = "
   //SYMBOL_FUNCTION_CALL[text() = 'levels']
     /parent::expr
     /parent::expr
     /parent::expr[expr/SYMBOL_FUNCTION_CALL[text() = 'length']]
-  "
-
-  Linter(function(source_expression) {
-    if (!is_lint_level(source_expression, "expression")) {
-      return(list())
-    }
-
-    xml <- source_expression$xml_parsed_content
-
-    bad_expr <- xml_find_all(xml, xpath)
-
-    xml_nodes_to_lints(
-      bad_expr,
-      source_expression = source_expression,
-      lint_message = "nlevels(x) is better than length(levels(x)).",
-      type = "warning"
-    )
-  })
-}
+  ",
+  lint_message = "nlevels(x) is better than length(levels(x))."
+)

R/lengths_linter.R

@@ -30,28 +30,14 @@
 #' @evalRd rd_tags("lengths_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-lengths_linter <- function() {
+lengths_linter <- local({
   loop_funs <- c("sapply", "vapply", "map_int", "map_dbl")
-  xpath <- glue("
-  //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(loop_funs)} ]
-    /parent::expr
-    /parent::expr[expr/SYMBOL[text() = 'length']]
-  ")
-
-  Linter(function(source_expression) {
-    if (!is_lint_level(source_expression, "expression")) {
-      return(list())
-    }
-
-    xml <- source_expression$xml_parsed_content
-
-    bad_expr <- xml_find_all(xml, xpath)
-
-    xml_nodes_to_lints(
-      bad_expr,
-      source_expression = source_expression,
-      lint_message = "Use lengths() to find the length of each element in a list.",
-      type = "warning"
-    )
-  })
-}
+  make_linter_from_xpath(
+    xpath = glue("
+    //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(loop_funs)} ]
+      /parent::expr
+      /parent::expr[expr/SYMBOL[text() = 'length']]
+    "),
+    lint_message = "Use lengths() to find the length of each element in a list."
+  )
+})

R/numeric_leading_zero_linter.R

@@ -29,28 +29,12 @@
 #' @evalRd rd_tags("numeric_leading_zero_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-numeric_leading_zero_linter <- function() {
+numeric_leading_zero_linter <- make_linter_from_xpath(
   # NB:
   #  1. negative constants are split to two components:
   #    OP-MINUS, NUM_CONST
   #  2. complex constants are split to three components:
   #    NUM_CONST, OP-PLUS/OP-MINUS, NUM_CONST
-  xpath <- "//NUM_CONST[starts-with(text(), '.')]"
-
-  Linter(function(source_expression) {
-    if (!is_lint_level(source_expression, "expression")) {
-      return(list())
-    }
-
-    xml <- source_expression$xml_parsed_content
-
-    bad_expr <- xml_find_all(xml, xpath)
-
-    xml_nodes_to_lints(
-      bad_expr,
-      source_expression = source_expression,
-      lint_message = "Include the leading zero for fractional numeric constants.",
-      type = "warning"
-    )
-  })
-}
+  xpath = "//NUM_CONST[starts-with(text(), '.')]",
+  lint_message = "Include the leading zero for fractional numeric constants."
+)

R/paren_body_linter.R

@@ -21,13 +21,13 @@
 #' - [linters] for a complete list of linters available in lintr.
 #' - <https://style.tidyverse.org/syntax.html#parentheses>
 #' @export
-paren_body_linter <- function() {
+paren_body_linter <- make_linter_from_xpath(
   # careful to do recursive search to the less common OP-RIGHT-PAREN
   #   and forcond nodes (vs. //expr) for performance -- there can
   #   be O(100K) <expr> nodes but in all but pathological examples,
   #   these other nodes will only be a small fraction of this amount.
   # note also that <forcond> only has one following-sibling::expr.
-  xpath <- "
+  xpath = "
   //OP-RIGHT-PAREN[
     @end = following-sibling::expr[1]/@start - 1
     and @line1 = following-sibling::expr[1]/@line1
@@ -45,20 +45,7 @@ paren_body_linter <- function() {
     and OP-RIGHT-PAREN/@col1 = following-sibling::expr/@col1 - 1
   ]
     /following-sibling::expr
-  "
-
-  Linter(function(source_expression) {
-    if (!is_lint_level(source_expression, "expression")) {
-      return(list())
-    }
-
-    xml <- source_expression$xml_parsed_content
-    matched_expressions <- xml_find_all(xml, xpath)
-
-    xml_nodes_to_lints(
-      matched_expressions,
-      source_expression = source_expression,
-      lint_message = "There should be a space between a right parenthesis and a body expression."
-    )
-  })
-}
+  ",
+  lint_message = "There should be a space between a right parenthesis and a body expression.",
+  type = "style"
+)

R/routine_registration_linter.R

@@ -31,29 +31,15 @@
 #' - <https://cran.r-project.org/doc/manuals/r-release/R-exts.html#Registering-native-routines>
 #'
 #' @export
-routine_registration_linter <- function() {
+routine_registration_linter <- local({
   native_routine_callers <- c(".C", ".Call", ".Fortran", ".External")
-  xpath <- glue("
-  //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(native_routine_callers)} ]
-    /parent::expr
-    /following-sibling::expr[1]/STR_CONST
-    /parent::expr
-  ")
-
-  Linter(function(source_expression) {
-    if (!is_lint_level(source_expression, "expression")) {
-      return(list())
-    }
-
-    xml <- source_expression$xml_parsed_content
-
-    bad_expr <- xml_find_all(xml, xpath)
-
-    xml_nodes_to_lints(
-      bad_expr,
-      source_expression = source_expression,
-      lint_message = "Register your native code routines with useDynLib and R_registerRoutines().",
-      type = "warning"
-    )
-  })
-}
+  make_linter_from_xpath(
+    xpath = glue("
+    //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(native_routine_callers)} ]
+      /parent::expr
+      /following-sibling::expr[1]/STR_CONST
+      /parent::expr
+    "),
+    lint_message = "Register your native code routines with useDynLib and R_registerRoutines()."
+  )
+})