Use make_linter_from_xpath() to generate simple linters

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'
@@ -181,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

NAMESPACE

@@ -89,6 +89,7 @@ export(lint_package)
 export(linters_with_defaults)
 export(linters_with_tags)
 export(literal_coercion_linter)
+export(make_linter_from_xpath)
 export(matrix_apply_linter)
 export(missing_argument_linter)
 export(missing_package_linter)

NEWS.md

@@ -12,6 +12,8 @@
 ## New and improved features
 
 * New exclusion sentinel `# nolint next` to signify the next line should skip linting (#1791, @MichaelChirico). The usual rules apply for excluding specific linters, e.g. `# nolint next: assignment_linter.`. The exact string used to match a subsequent-line exclusion is controlled by the `exclude_next` config entry or R option `"lintr.exclude_next"`.
+* New `xp_call_name()` helper to facilitate writing custom linters (#2023, @MichaelChirico). This helper converts a matched XPath to the R function to which it corresponds. This is useful for including the "offending" function in the lint's message.
+* New `make_linter_from_xpath()` to facilitate making simple linters directly from a single XPath (#2064, @MichaelChirico). This is especially helpful for making on-the-fly/exploratory linters, but also extends to any case where the linter can be fully defined from a static lint message and single XPath.
 * `fixed_regex_linter()`
   + Is pipe-aware, in particular removing false positives arong piping into {stringr} functions like `x |> str_replace(fixed("a"), "b")` (#1811, @MichaelChirico).
   + Gains an option `allow_unescaped` (default `FALSE`) to toggle linting regexes not requiring any escapes or character classes (#1689, @MichaelChirico). Thus `fixed_regex_linter(allow_unescaped = TRUE)` would lint on `grepl("[$]", x)` but not on `grepl("a", x)` since the latter does not use any regex special characters.
@@ -36,7 +38,6 @@
 * `paste_linter()` gains detection for file paths that are better constructed with `file.path()`, e.g. `paste0(dir, "/", file)` would be better as `file.path(dir, file)` (part of #884, #2082, @MichaelChirico). What exactly gets linted here can be fine-tuned with the `allow_file_path` option (`"double_slash"` by default, with alternatives `"never"` and `"always"`). When `"always"`, these rules are ignored. When `"double_slash"`, paths appearing to construct a URL that have consecutive forward slashes (`/`) are skipped. When `"never"`, even URLs should be construced with `file.path()`.
 * `paste_linter()` gains detection for file paths that are better constructed with `file.path()`, e.g. `paste0(dir, "/", file)` would be better as `file.path(dir, file)` (part of #884, @MichaelChirico).
 * `seq_linter()` recommends `rev()` in the lint message for lints like `nrow(x):1` (#1542, @MichaelChirico).
-* New `xp_call_name()` helper to facilitate writing custom linters (#2023, @MichaelChirico). This helper converts a matched XPath to the R function to which it corresponds. This is useful for including the "offending" function in the lint's message.
 * `function_argument_linter()` detects usage of `missing()` for the linted argument (#1546, @MichaelChirico). The simplest fix for `function_argument_linter()` lints is typically to set that argument to `NULL` by default, in which case it's usually preferable to update function logic checking `missing()` to check `is.null()` instead.
 * `equals_na_linter()` checks for `x %in% NA`, which is a more convoluted form of `is.na(x)` (#2088, @MichaelChirico).
 * `commas_linter()` gains an option `allow_trailing` (default `FALSE`) to allow trailing commas while indexing. (#2104, @MEO265)

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/make_linter_from_xpath.R

@@ -0,0 +1,43 @@
+#' Create a linter from an XPath
+#'
+#' @inheritParams xml_nodes_to_lints
+#' @inheritParams is_lint_level
+#' @param xpath Character string, an XPath identifying R code to lint.
+#'   See [xmlparsedata::xml_parse_data()] and [get_source_expressions()].
+#'
+#' @examples
+#' number_linter <- make_linter_from_xpath("//NUM_CONST", "This is a number.")
+#' lint(text = "1 + 2", linters = number_linter())
+#' @export
+make_linter_from_xpath <- function(xpath,
+                                   lint_message,
+                                   type = c("warning", "style", "error"),
+                                   level = c("expression", "file")) {
+  type <- match.arg(type)
+  level <- match.arg(level)
+
+  stopifnot(
+    "xpath should be a character string" = is.character(xpath) && length(xpath) == 1L && !is.na(xpath)
+  )
+
+  xml_key <- if (level == "expression") "xml_parsed_content" else "full_xml_parsed_content"
+
+  function() {
+    Linter(function(source_expression) {
+      if (!is_lint_level(source_expression, level)) {
+        return(list())
+      }
+
+      xml <- source_expression[[xml_key]]
+
+      expr <- xml_find_all(xml, xpath)
+
+      xml_nodes_to_lints(
+        expr,
+        source_expression = source_expression,
+        lint_message = lint_message,
+        type = type
+      )
+    })
+  }
+}

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