extend infix_spaces_linter to be more flexible & correct (#931)

* extend infix_spaces_linter to be more flexible & correct

* git mangled

* clarifying comments

* test of grouped exclusion by %%

* missed ~ in docs

* use angle brackets for external URL

* remove linter from DB & document()

* sAF=FALSE for R<4

* sQuote version issue

* more tests

* switch from with() usage to appease object_usage_linter

* mini-edit to create a commit

* roxygenize

* roxygenize

* fix new lintr lints caught by the improvement

Co-authored-by: AshesITR <alexander.rosenstock@web.de>

Author: MichaelChirico

.gitignore

@@ -9,3 +9,4 @@ script.R
 
 *.Rcheck
 lintr_*.tar.gz
+testthat-problems.rds

DESCRIPTION

@@ -50,7 +50,6 @@ Collate:
     'actions.R'
     'addins.R'
     'assignment_linter.R'
-    'assignment_spaces_linter.R'
     'backport_linter.R'
     'cache.R'
     'closed_curly_linter.R'

NAMESPACE

@@ -14,7 +14,6 @@ export(absolute_path_linter)
 export(all_undesirable_functions)
 export(all_undesirable_operators)
 export(assignment_linter)
-export(assignment_spaces_linter)
 export(available_linters)
 export(backport_linter)
 export(checkstyle_output)

NEWS.md

@@ -10,7 +10,6 @@
   format specifiers (#472, @russHyde)
 * New style SNAKE_CASE for `object_name_linter()` (#494, @AshesITR)
 * RStudio source markers are cleared when there are no lints (#520, @AshesITR)
-* New `assignment_spaces()` lintr. (#538, @f-ritter)
 * `seq_linter()`'s lint message is clearer about the reason for linting. (#522, @michaelchirico)
 * New `missing_package_linter()` (#536, #547, @renkun-ken)
 * New `namespace_linter()` (#548, #551, @renkun-ken)
@@ -95,6 +94,8 @@ function calls. (#850, #851, @renkun-ken)
    + `expect_true_false_linter()` Require usage of `expect_true(x)` over `expect_equal(x, TRUE)` and similar
    * `expect_length_linter()` Require usage of `expect_length(x, n)` over `expect_equal(length(x), n)` and similar
 * `assignment_linter()` now lints right assignment (`->` and `->>`) and gains two arguments. `allow_cascading_assign` (`TRUE` by default) toggles whether to lint `<<-` and `->>`; `allow_right_assign` toggles whether to lint `->` and `->>` (#915, @michaelchirico)
+* `infix_spaces_linter()` gains argument `exclude_operators` to disable lints on selected infix operators. By default, all "low-precedence" operators throw lints; see `?infix_spaces_linter` for an enumeration of these. (#914 @michaelchirico)
+* `infix_spaces_linter()` now throws a lint on `a~b` and `function(a=1) {}` (#930, @michaelchirico)
 
 # lintr 2.0.1
 

R/assignment_spaces_linter.R

@@ -1,43 +1,81 @@
-# names: xml tags; values: getParseData tokens
-# these can be used as unary operators; treat separately
-unary_infix_tokens <- c(
-  "OP-PLUS" = "'+'",               # +        : unary plus
-  "OP-MINUS" = "'-'",              # -        : unary minus
+# some metadata about infix operators on the R parse tree.
+#   xml_tag gives the XML tag as returned by xmlparsedata::xml_parse_data().
+#   r_string gives the operator as you would write it in R code.
+# NB: this metadata is used elsewhere in lintr, e.g. spaces_left_parentheses_linter.
+#   because of that, even though some rows of this table are currently unused, but
+#   we keep them around because it's useful to keep this info in one place.
+infix_metadata <- data.frame(stringsAsFactors = FALSE, matrix(byrow = TRUE, ncol = 2L, c(
+  "OP-PLUS", "+",
+  "OP-MINUS", "-",
+  "OP-TILDE", "~",
+  "GT", ">",
+  "GE", ">=",
+  "LT", "<",
+  "LE", "<=",
+  "EQ", "==",
+  "NE", "!=",
+  "AND", "&",
+  "OR", "|",
+  "AND2", "&&",
+  "OR2", "||",
+  "LEFT_ASSIGN", "<-",  # also includes := and <<-
+  "RIGHT_ASSIGN", "->", # also includes ->>
+  "EQ_ASSIGN", "=",
+  "EQ_SUB", "=",        # in calls: foo(x = 1)
+  "EQ_FORMALS", "=",    # in definitions: function(x = 1)
+  "SPECIAL", "%%",
+  "OP-SLASH", "/",
+  "OP-STAR", "*",
+  "OP-COMMA", ",",
+  "OP-CARET", "^",      # also includes **
+  "OP-AT", "@",
+  "OP-EXCLAMATION", "!",
+  "OP-COLON", ":",
+  "NS_GET", "::",
+  "NS_GET_INT", ":::",
+  "OP-LEFT-BRACE", "{",
+  "OP-LEFT-BRACKET", "[",
+  "LBB", "[[",
+  "OP-LEFT-PAREN", "(",
+  "OP-QUESTION", "?",
   NULL
+)))
+names(infix_metadata) <- c("xml_tag", "string_value")
+# utils::getParseData()'s designation for the tokens wouldn't be valid as XML tags
+infix_metadata$parse_tag <- ifelse(
+  startsWith(infix_metadata$xml_tag, "OP-"),
+  # NB: sQuote(x, "'") doesn't work on older R versions
+  paste0("'", infix_metadata$string_value, "'"),
+  infix_metadata$xml_tag
 )
-binary_infix_tokens <- c(
-
-  "GT" = "GT",                     # >        : greater than
-  "GE" = "GE",                     # <=       : greater than or equal to
-  "LT" = "LT",                     # <        : less than
-  "LE" = "LE",                     # <=       : less than or equal to
-  "EQ" = "EQ",                     # ==       : vector equality
-  "NE" = "NE",                     # !=       : not equal
-  "AND" = "AND",                   # &        : vector boolean and
-  "OR" = "OR",                     # |        : vector boolean or
-  "AND2" = "AND2",                 # &&       : scalar boolean and
-  "OR2" = "OR2",                   # ||       : scalar boolean or
-  "LEFT_ASSIGN" = "LEFT_ASSIGN",   # <- or := : left assignment
-  "RIGHT_ASSIGN" = "RIGHT_ASSIGN", # ->       : right assignment
-  "EQ_ASSIGN" = "EQ_ASSIGN",       # =        : equal assignment
-  "EQ_SUB" = "EQ_SUB",             # =        : keyword assignment
-  "SPECIAL" = "SPECIAL",           # %[^%]*%  : infix operators
-  "OP-SLASH" = "'/'",              # /        : unary division
-  "OP-STAR" = "'*'",               # *        : unary multiplication
-
-  NULL
+# treated separately because spacing rules are different for unary operators
+infix_metadata$unary <- infix_metadata$xml_tag %in% c("OP-PLUS", "OP-MINUS", "OP-TILDE")
+# high-precedence operators are ignored by this linter; see
+#   https://style.tidyverse.org/syntax.html#infix-operators
+infix_metadata$low_precedence <- infix_metadata$string_value %in% c(
+  "+", "-", "~", ">", ">=", "<", "<=", "==", "!=", "&", "&&", "|", "||", "<-", "->", "=", "%%", "/", "*"
 )
-infix_tokens <- c(unary_infix_tokens, binary_infix_tokens)
 
 #' Infix spaces linter
 #'
-#' Check that infix operators are surrounded by spaces.
+#' Check that infix operators are surrounded by spaces. Enforces the corresponding Tidyverse style guide rule;
+#'   see <https://style.tidyverse.org/syntax.html#infix-operators>.
 #'
+#' @param exclude_operators Character vector of operators to exlude from consideration for linting.
+#'   Default is to include the following "low-precedence" operators:
+#'   `+`, `-`, `~`, `>`, `>=`, `<`, `<=`, `==`, `!=`, `&`, `&&`, `|`, `||`, `<-`, `:=`, `<<-`, `->`, `->>`,
+#'   `=`, `/`, `*`, and any infix operator (exclude infixes by passing `"%%"`). Note that `<-`, `:=`, and `<<-`
+#'   are included/excluded as a group (indicated by passing `"<-"`), as are `->` and `->>` (_viz_, `"->"`),
+#'   and that `=` for assignment and for setting arguments in calls are treated the same.
 #' @evalRd rd_tags("infix_spaces_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-infix_spaces_linter <- function() {
+infix_spaces_linter <- function(exclude_operators = NULL) {
   Linter(function(source_file) {
+    infix_tokens <- infix_metadata[
+      infix_metadata$low_precedence & !infix_metadata$string_value %in% exclude_operators,
+      "parse_tag"
+    ]
     lapply(
       ids_with_token(source_file, infix_tokens, fun = `%in%`),
       function(id) {

R/infix_spaces_linter.R

@@ -129,7 +129,7 @@ names.lints <- function(x, ...) {
 }
 
 #' @export
-split.lints <- function(x, f=NULL, ...) {
+split.lints <- function(x, f = NULL, ...) {
   if (is.null(f)) f <- names(x)
   splt <- split.default(x, f)
   for (i in names(splt)) class(splt[[i]]) <- "lints"

R/methods.R

@@ -59,7 +59,7 @@ is_path <- function(path) {
   re_matches(path, path_regex)
 }
 
-is_valid_path <- function(path, lax=FALSE) {
+is_valid_path <- function(path, lax = FALSE) {
   # Given a character vector of paths, return FALSE for directory or file having valid characters.
   # On Windows, invalid chars are all control chars and: * ? " < > | :
   # On Unix, all characters are valid, except when lax=TRUE (use same invalid chars as Windows).
@@ -91,7 +91,7 @@ is_long_path <- function(path) {
   )
 }
 
-is_valid_long_path <- function(path, lax=FALSE) {
+is_valid_long_path <- function(path, lax = FALSE) {
   # Convenience function to avoid linting short paths and those unlikely to be valid paths
   ret <- is_valid_path(path, lax)
   if (lax) {
@@ -101,7 +101,7 @@ is_valid_long_path <- function(path, lax=FALSE) {
 }
 
 
-split_path <- function(path, sep="/|\\\\") {
+split_path <- function(path, sep = "/|\\\\") {
   if (!is.character(path)) {
     stop("argument 'path' should be a character vector")
   }

R/path_linters.R

@@ -29,9 +29,12 @@ spaces_left_parentheses_linter <- function() {
       for_cond <- "@start - 1 = parent::forcond/preceding-sibling::FOR/@end"
 
       # see infix_spaces_linter.R; preceding-sibling::* is needed for unary operators where '-(a)' is ok
-      unary_nodes <- c(names(unary_infix_tokens), "OP-TILDE")
+      unary_nodes <- infix_metadata[infix_metadata$unary, "xml_tag"]
       unary_selves <- paste0("self::", unary_nodes, "[preceding-sibling::*]", collapse = " or ")
-      binary_nodes <- c(names(binary_infix_tokens), "EQ_FORMALS", "OP-COMMA", "OP-LEFT-BRACE", "ELSE", "IN")
+      binary_nodes <- c(
+        infix_metadata[infix_metadata$low_precedence & !infix_metadata$unary, "xml_tag"],
+        "OP-COMMA", "OP-LEFT-BRACE", "ELSE", "IN"
+      )
       binary_selves <- paste0("self::", binary_nodes, collapse = " or ")
       # preceding-symbol::* catches (1) function definitions and (2) function calls
       # ancestor::expr needed for nested RHS expressions, e.g. 'y1<-(abs(yn)>90)*1'

R/spaces_left_parentheses_linter.R

@@ -163,7 +163,7 @@ viapply <- function(x, ...) vapply(x, ..., FUN.VALUE = integer(1))
 # imitate sQuote(x, q) [requires R>=3.6]
 quote_wrap <- function(x, q) paste0(q, x, q)
 
-unquote <- function(str, q="`") {
+unquote <- function(str, q = "`") {
   # Remove surrounding quotes (select either single, double or backtick) from given character vector
   # and unescape special characters.
   str <- re_substitutes(str, rex(start, q, capture(anything), q, end), "\\1")
@@ -185,7 +185,7 @@ escape_chars <- c(
   #"\\`"  --> "`"   # ASCII grave accent (backtick)
 )
 
-unescape <- function(str, q="`") {
+unescape <- function(str, q = "`") {
   names(q) <- paste0("\\", q)
   my_escape_chars <- c(escape_chars, q)
   res <- gregexpr(text = str, pattern = rex(or(names(my_escape_chars))))

R/utils.R

@@ -1,7 +1,6 @@
 linter,tags
 absolute_path_linter,robustness best_practices configurable
 assignment_linter,style consistency default
-assignment_spaces_linter,style readability
 backport_linter,robustness configurable package_development
 closed_curly_linter,style readability default configurable
 commas_linter,style readability default