From 7aee482e83a0a611923bcf31ed9b4b6827ac2765 Mon Sep 17 00:00:00 2001
From: AshesITR <alexander.rosenstock@web.de>
Date: Sun, 16 Oct 2022 18:42:02 +0200
Subject: [PATCH] Improve object_usage_linter() (#1715)

* improve location information

* small tweaks

* address review comments

Co-authored-by: Michael Chirico <chiricom@google.com>
---
 NEWS.md                                   |  2 ++
 R/object_usage_linter.R                   | 43 +++++++++++++----------
 tests/testthat/test-object_usage_linter.R | 20 ++++++++++-
 3 files changed, 45 insertions(+), 20 deletions(-)

diff --git a/NEWS.md b/NEWS.md
index 96d25251f..b4a73daa6 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -9,6 +9,8 @@
   
 * `assignment_linter()` no longer lints assignments in braces that include comments when `allow_trailing = FALSE` (#1701, @ashbaldry)
 
+* `object_usage_linter()` no longer silently ignores usage warnings that don't contain a quoted name (#1714, @AshesITR)
+
 ## Changes to defaults
 
 * Set the default for the `except` argument in `duplicate_argument_linter()` to `c("mutate", "transmute")`.
diff --git a/R/object_usage_linter.R b/R/object_usage_linter.R
index 8f73e3085..b1c94b3e6 100644
--- a/R/object_usage_linter.R
+++ b/R/object_usage_linter.R
@@ -122,9 +122,17 @@ object_usage_linter <- function(interpret_glue = TRUE, skip_with = TRUE) {
         },
         integer(1L)
       )
-
       nodes <- unclass(lintable_symbols)[matched_symbol]
-      nodes[is.na(matched_symbol)] <- list(fun_assignment)
+
+      # fallback to line based matching if no symbol is found
+      missing_symbol <- is.na(matched_symbol)
+      nodes[missing_symbol] <- lapply(which(missing_symbol), function(i) {
+        line_based_match <- xml2::xml_find_first(
+          fun_assignment,
+          glue::glue_data(res[i, ], "descendant::expr[@line1 = {line1} and @line2 = {line2}]")
+        )
+        if (is.na(line_based_match)) fun_assignment else line_based_match
+      })
 
       xml_nodes_to_lints(nodes, source_expression = source_expression, lint_message = res$message, type = "warning")
     })
@@ -268,32 +276,29 @@ parse_check_usage <- function(expression,
       function_name,
       capture(
         name = "message",
-        anything,
-        one_of(quote, "\u2018"),
-        capture(name = "name", anything),
-        one_of(quote, "\u2019"),
-        anything
+        zero_or_more(any, type = "lazy"),
+        maybe(
+          "'",
+          capture(name = "name", anything),
+          "'",
+          anything
+        )
       ),
       line_info
     )
   )
 
+  # nocov start
   missing <- is.na(res$message)
   if (any(missing)) {
-    res[missing, ] <- re_matches(
-      vals[missing],
-      rex(
-        function_name,
-        capture(
-          name = "message",
-          "possible error in ", capture(name = "name", anything), ": ", anything
-        ),
-        line_info
-      )
+    # TODO (AshesITR): Remove this in the future, if no bugs arise from this safeguard
+    warning(
+      "Possible bug in lintr: Couldn't parse usage message ", sQuote(vals[missing][[1L]]), ". ",
+      "Ignoring ", sum(missing), " usage warnings. Please report an issue at https://github.com/r-lib/lintr/issues."
     )
   }
-
-  res <- res[!is.na(res$message), ]
+  # nocov end
+  res <- res[!missing, ]
 
   res$line1 <- as.integer(res$line1) + start_line - 1L
   res$line2 <- ifelse(
diff --git a/tests/testthat/test-object_usage_linter.R b/tests/testthat/test-object_usage_linter.R
index 76e42aa05..195dd84f5 100644
--- a/tests/testthat/test-object_usage_linter.R
+++ b/tests/testthat/test-object_usage_linter.R
@@ -545,7 +545,8 @@ test_that("fallback works", {
     "),
     list(
       message = rex::rex("no visible global function definition for ", anything, "non_existing_assign<-"),
-      column_number = 6L
+      line_number = 2L,
+      column_number = 3L
     ),
     object_usage_linter()
   )
@@ -606,3 +607,20 @@ test_that("missing libraries don't cause issue", {
     object_usage_linter()
   )
 })
+
+test_that("messages without a quoted name are caught", {
+  # regression test for #1714
+  expect_lint(
+    trim_some("
+      foo <- function() {
+        a <- ...
+        a
+      }
+    "),
+    list(
+      message = "... may be used in an incorrect context",
+      line_number = 2L
+    ),
+    object_usage_linter()
+  )
+})