Some refactoring to clarify logic in complicated linters

NEWS.md

@@ -35,7 +35,7 @@
 * `assignment_linter()` lints the {magrittr} assignment pipe `%<>%` (#2008, @MichaelChirico). This can be deactivated by setting the new argument `allow_pipe_assign` to `TRUE`.
 * `object_usage_linter()`:
   + assumes `glue()` is `glue::glue()` when `interpret_glue=TRUE` (#2032, @MichaelChirico).
-  + finds function usages inside `glue()` calls to avoid false positives for "unused objects" (#2029, @MichaelChirico).
+  + finds function usages, including infix usage, inside `glue()` calls to avoid false positives for "unused objects" (#2029 and #2069, @MichaelChirico).
 * `object_name_linter()` no longer attempts to lint strings in function calls on the LHS of assignments (#1466, @MichaelChirico).
 
 # lintr 3.1.0

R/namespace_linter.R

@@ -123,74 +123,59 @@ namespace_linter <- function(check_exports = TRUE, check_nonexports = TRUE) {
   })
 }
 
-get_all_exports <- function(namespace) {
-  c(getNamespaceExports(namespace), names(.getNamespaceInfo(namespace, "lazydata")))
+namespace_symbols <- function(ns, exported = TRUE) {
+  if (exported) {
+    c(getNamespaceExports(ns), names(.getNamespaceInfo(ns, "lazydata")))
+  } else {
+    ls(ns, all.names = TRUE)
+  }
+}
+is_in_pkg <- function(symbols, namespaces, exported = TRUE) {
+  vapply(
+    seq_along(symbols),
+    function(ii) symbols[[ii]] %in% namespace_symbols(namespaces[[ii]], exported = exported),
+    logical(1L)
+  )
 }
 
 build_ns_get_int_lints <- function(packages, symbols, symbol_nodes, namespaces, source_expression) {
-  lints <- list()
-
   ## Case 2: foo does not exist in pkg:::foo
-
-  non_symbols <- !vapply(
-    seq_along(symbols),
-    function(ii) symbols[[ii]] %in% ls(namespaces[[ii]], all.names = TRUE),
-    logical(1L)
+  non_symbols <- !is_in_pkg(symbols, namespaces, exported = FALSE)
+  non_symbols_lints <- xml_nodes_to_lints(
+    symbol_nodes[non_symbols],
+    source_expression = source_expression,
+    lint_message = sprintf("'%s' does not exist in {%s}.", symbols[non_symbols], packages[non_symbols]),
+    type = "warning"
   )
-  if (any(non_symbols)) {
-    lints <- c(lints, xml_nodes_to_lints(
-      symbol_nodes[non_symbols],
-      source_expression = source_expression,
-      lint_message = sprintf("'%s' does not exist in {%s}.", symbols[non_symbols], packages[non_symbols]),
-      type = "warning"
-    ))
-
-    packages <- packages[!non_symbols]
-    symbols <- symbols[!non_symbols]
-    symbol_nodes <- symbol_nodes[!non_symbols]
-  }
 
-  ## Case 3: foo is already exported pkg:::foo
+  packages <- packages[!non_symbols]
+  symbols <- symbols[!non_symbols]
+  symbol_nodes <- symbol_nodes[!non_symbols]
+  namespaces <- namespaces[!non_symbols]
 
-  exported <- vapply(
-    seq_along(symbols),
-    function(ii) symbols[[ii]] %in% get_all_exports(namespaces[[ii]]),
-    logical(1L)
+  ## Case 3: foo is already exported pkg:::foo
+  exported <- is_in_pkg(symbols, namespaces)
+  exported_lints <- xml_nodes_to_lints(
+    symbol_nodes[exported],
+    source_expression = source_expression,
+    lint_message =
+      sprintf("'%1$s' is exported from {%2$s}. Use %2$s::%1$s instead.", symbols[exported], packages[exported]),
+    type = "warning"
   )
-  if (any(exported)) {
-    lints <- c(lints, xml_nodes_to_lints(
-      symbol_nodes[exported],
-      source_expression = source_expression,
-      lint_message =
-        sprintf("'%1$s' is exported from {%2$s}. Use %2$s::%1$s instead.", symbols[exported], packages[exported]),
-      type = "warning"
-    ))
-  }
 
-  lints
+  c(non_symbols_lints, exported_lints)
 }
 
 build_ns_get_lints <- function(packages, symbols, symbol_nodes, namespaces, source_expression) {
-  lints <- list()
-
   # strip backticked symbols; `%>%` is the same as %>% (#1752).
   symbols <- gsub("^`(.*)`$", "\\1", symbols)
 
   ## Case 4: foo is not an export in pkg::foo
-
-  unexported <- !vapply(
-    seq_along(symbols),
-    function(ii) symbols[[ii]] %in% get_all_exports(namespaces[[ii]]),
-    logical(1L)
+  unexported <- !is_in_pkg(symbols, namespaces)
+  xml_nodes_to_lints(
+    symbol_nodes[unexported],
+    source_expression = source_expression,
+    lint_message = sprintf("'%s' is not exported from {%s}.", symbols[unexported], packages[unexported]),
+    type = "warning"
   )
-  if (any(unexported)) {
-    lints <- c(lints, xml_nodes_to_lints(
-      symbol_nodes[unexported],
-      source_expression = source_expression,
-      lint_message = sprintf("'%s' is not exported from {%s}.", symbols[unexported], packages[unexported]),
-      type = "warning"
-    ))
-  }
-
-  lints
 }

R/object_usage_linter.R

@@ -35,16 +35,13 @@ object_usage_linter <- function(interpret_glue = TRUE, skip_with = TRUE) {
   # NB: the repeated expr[2][FUNCTION] XPath has no performance impact, so the different direct assignment XPaths are
   #   split for better readability, see PR#1197
   # TODO(#1106): use //[...] to capture assignments in more scopes
-  xpath_function_assignment <- paste(
-    # direct assignments
-    "expr[LEFT_ASSIGN or EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]",
-    "expr_or_assign_or_help[EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]",
-    "equal_assign[EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]",
-    # assign() and setMethod() assignments
-    "//SYMBOL_FUNCTION_CALL[text() = 'assign']/parent::expr/following-sibling::expr[2][FUNCTION or OP-LAMBDA]",
-    "//SYMBOL_FUNCTION_CALL[text() = 'setMethod']/parent::expr/following-sibling::expr[3][FUNCTION or OP-LAMBDA]",
-    sep = " | "
-  )
+  xpath_function_assignment <- "
+    expr[LEFT_ASSIGN or EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]
+    | expr_or_assign_or_help[EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]
+    | equal_assign[EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]
+    | //SYMBOL_FUNCTION_CALL[text() = 'assign']/parent::expr/following-sibling::expr[2][FUNCTION or OP-LAMBDA]
+    | //SYMBOL_FUNCTION_CALL[text() = 'setMethod']/parent::expr/following-sibling::expr[3][FUNCTION or OP-LAMBDA]
+  "
 
   # not all instances of linted symbols are potential sources for the observed violations -- see #1914
   symbol_exclude_cond <- "preceding-sibling::OP-DOLLAR or preceding-sibling::OP-AT or ancestor::expr[OP-TILDE]"
@@ -61,22 +58,13 @@ object_usage_linter <- function(interpret_glue = TRUE, skip_with = TRUE) {
     }
 
     pkg_name <- pkg_name(find_package(dirname(source_expression$filename)))
-    # run the following at run-time, not "compile" time to allow package structure to change
-    env <- make_check_env(pkg_name)
 
     declared_globals <- try_silently(utils::globalVariables(package = pkg_name %||% globalenv()))
 
     xml <- source_expression$full_xml_parsed_content
 
-    symbols <- c(
-      get_assignment_symbols(xml),
-      get_imported_symbols(xml)
-    )
-
-    # Just assign them an empty function
-    for (symbol in symbols) {
-      assign(symbol, function(...) invisible(), envir = env)
-    }
+    # run the following at run-time, not "compile" time to allow package structure to change
+    env <- make_check_env(pkg_name, xml)
 
     fun_assignments <- xml_find_all(xml, xpath_function_assignment)
 
@@ -93,7 +81,7 @@ object_usage_linter <- function(interpret_glue = TRUE, skip_with = TRUE) {
       if (inherits(fun, "try-error")) {
         return()
       }
-      known_used_symbols <- get_used_symbols(fun_assignment, interpret_glue = interpret_glue)
+      known_used_symbols <- extract_glued_symbols(fun_assignment, interpret_glue = interpret_glue)
       res <- parse_check_usage(
         fun,
         known_used_symbols = known_used_symbols,
@@ -141,19 +129,31 @@ object_usage_linter <- function(interpret_glue = TRUE, skip_with = TRUE) {
   })
 }
 
-make_check_env <- function(pkg_name) {
+make_check_env <- function(pkg_name, xml) {
   if (!is.null(pkg_name)) {
     parent_env <- try_silently(getNamespace(pkg_name))
   }
   if (is.null(pkg_name) || inherits(parent_env, "try-error")) {
     parent_env <- globalenv()
   }
   env <- new.env(parent = parent_env)
-  return(env)
-}
 
+  symbols <- c(
+    get_assignment_symbols(xml),
+    get_imported_symbols(xml)
+  )
+
+  # Just assign them an empty function
+  for (symbol in symbols) {
+    assign(symbol, function(...) invisible(), envir = env)
+  }
+  env
+}
 
-extract_glued_symbols <- function(expr) {
+extract_glued_symbols <- function(expr, interpret_glue) {
+  if (!isTRUE(interpret_glue)) {
+    return(character())
+  }
   # TODO support more glue functions
   # Package glue:
   #  - glue_sql
@@ -166,63 +166,47 @@ extract_glued_symbols <- function(expr) {
   #
   # Package stringr:
   #  - str_interp
-  glue_calls <- xml_find_all(
-    expr,
-    xpath = paste0(
-      "descendant::SYMBOL_FUNCTION_CALL[text() = 'glue']/", # a glue() call
-      "parent::expr[",
-      # without .envir or .transform arguments
-      "not(following-sibling::SYMBOL_SUB[text() = '.envir' or text() = '.transform']) and",
-      # argument that is not a string constant
-      "not(following-sibling::expr[not(STR_CONST)])",
-      "]/",
-      # get the complete call
-      "parent::expr"
-    )
-  )
-
-  if (length(glue_calls) == 0L) {
-    return(character())
-  }
+  # NB: position() > 1 because position=1 is <expr><SYMBOL_FUNCTION_CALL>
+  glue_call_xpath <- "
+    descendant::SYMBOL_FUNCTION_CALL[text() = 'glue']
+      /parent::expr
+      /parent::expr[
+        not(SYMBOL_SUB[text() = '.envir' or text() = '.transform'])
+        and not(expr[position() > 1 and not(STR_CONST)])
+      ]
+  "
+  glue_calls <- xml_find_all(expr, glue_call_xpath)
 
   unexpected_error <- function(cond) {
     stop("Unexpected failure to parse glue call, please report: ", conditionMessage(cond)) # nocov
   }
+  parse_failure_warning <- function(cond) {
+    warning(
+      "Evaluating glue expression while testing for local variable usage failed: ",
+      conditionMessage(cond), "\nPlease ensure correct glue syntax, e.g., matched delimiters.",
+      call. = FALSE
+    )
+    NULL
+  }
+
   glued_symbols <- new.env(parent = emptyenv())
   for (glue_call in glue_calls) {
     # TODO(michaelchirico): consider dropping tryCatch() here if we're more confident in our logic
     parsed_call <- tryCatch(xml2lang(glue_call), error = unexpected_error, warning = unexpected_error)
     parsed_call[[".envir"]] <- glued_symbols
     parsed_call[[".transformer"]] <- symbol_extractor
     # #1459: syntax errors in glue'd code are ignored with warning, rather than crashing lint
-    tryCatch(
-      eval(parsed_call),
-      error = function(cond) {
-        warning(
-          "Evaluating glue expression while testing for local variable usage failed: ",
-          conditionMessage(cond), "\nPlease ensure correct glue syntax, e.g., matched delimiters.",
-          call. = FALSE
-        )
-        NULL
-      }
-    )
+    tryCatch(eval(parsed_call), error = parse_failure_warning)
   }
   names(glued_symbols)
 }
 
 symbol_extractor <- function(text, envir, data) {
-  parsed_text <- tryCatch(
-    parse(text = text, keep.source = TRUE),
+  symbols <- tryCatch(
+    all.vars(parse(text = text), functions = TRUE),
     error = function(...) NULL,
     warning = function(...) NULL
   )
-  if (length(parsed_text) == 0L) {
-    return("")
-  }
-  parse_data <- utils::getParseData(parsed_text)
-
-  # strip backticked symbols; `x` is the same as x.
-  symbols <- gsub("^`(.*)`$", "\\1", parse_data$text[parse_data$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL")])
   for (sym in symbols) {
     assign(sym, NULL, envir = envir)
   }
@@ -241,30 +225,30 @@ get_assignment_symbols <- function(xml) {
   ))
 }
 
+get_check_usage_results <- function(expression, known_used_symbols, declared_globals, skip_with) {
+  report_env <- new.env(parent = emptyenv())
+  report_env$vals <- character()
+  report <- function(x) report_env$vals <- c(report_env$vals, x)
+  withr::local_options(list(useFancyQuotes = FALSE))
+  try(
+    codetools::checkUsage(
+      expression,
+      report = report,
+      suppressLocalUnused = known_used_symbols,
+      suppressUndefined = declared_globals,
+      skipWith = skip_with
+    )
+  )
+  report_env$vals
+}
+
 parse_check_usage <- function(expression,
                               known_used_symbols = character(),
                               declared_globals = character(),
                               start_line = 1L,
                               end_line = 1L,
                               skip_with = TRUE) {
-  vals <- list()
-
-  report <- function(x) {
-    vals[[length(vals) + 1L]] <<- x
-  }
-
-  withr::with_options(
-    list(useFancyQuotes = FALSE),
-    code = {
-      try(codetools::checkUsage(
-        expression,
-        report = report,
-        suppressLocalUnused = known_used_symbols,
-        suppressUndefined = declared_globals,
-        skipWith = skip_with
-      ))
-    }
-  )
+  vals <- get_check_usage_results(expression, known_used_symbols, declared_globals, skip_with)
 
   function_name <- rex(anything, ": ")
   line_info <- rex(
@@ -322,35 +306,23 @@ parse_check_usage <- function(expression,
 get_imported_symbols <- function(xml) {
   import_exprs_xpath <- "
   //SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require']
-  /parent::expr
-  /parent::expr[
-    not(SYMBOL_SUB[
-      text() = 'character.only' and
-      following-sibling::expr[1][NUM_CONST[text() = 'TRUE'] or SYMBOL[text() = 'T']]
-    ])
-    or expr[2][STR_CONST]
-  ]
-  /expr[STR_CONST or SYMBOL][1]
+    /parent::expr
+    /parent::expr[
+      not(SYMBOL_SUB[
+        text() = 'character.only' and
+        following-sibling::expr[1][NUM_CONST[text() = 'TRUE'] or SYMBOL[text() = 'T']]
+      ])
+      or expr[2][STR_CONST]
+    ]
+    /expr[STR_CONST or SYMBOL][1]
   "
   import_exprs <- xml_find_all(xml, import_exprs_xpath)
-  if (length(import_exprs) == 0L) {
-    return(character())
-  }
   imported_pkgs <- get_r_string(import_exprs)
 
   unlist(lapply(imported_pkgs, function(pkg) {
     tryCatch(
       getNamespaceExports(pkg),
-      error = function(e) {
-        character()
-      }
+      error = function(e) character()
     )
   }))
 }
-
-get_used_symbols <- function(expr, interpret_glue) {
-  if (!isTRUE(interpret_glue)) {
-    return(character())
-  }
-  extract_glued_symbols(expr)
-}