Simplify the object usage linter

It was getting quite confusing and had a bunch of false positives. This should at least help in making it less so... Fixes #27 Fixes #336 Fixes #91 Fixes #382
r-lib · Sep 27, 2019 · 103550b · 103550b
1 parent cd9d018
commit 103550b
Show file tree

Hide file tree

Showing 4 changed files with 42 additions and 79 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -1,4 +1,5 @@
 # lintr 1.0.3.9000 # 
+* `object_usage_linter()` has been changed to better detect lexical scoping of global variables (#27, #336, #91, #382)
 * `object_usage_linter()` now respects `utils::globalVariables()`, so it can be used to avoid false positive warnings due to non-standard evaluation (#352)
 * `seq_linter` is now one of the default linters (#316).
 * R Markdown files that do not contain chunks are no longer treated as code (#370).

diff --git a/R/get_source_expressions.R b/R/get_source_expressions.R
@@ -110,8 +110,9 @@ get_source_expressions <- function(filename) {
       filename = filename,
       file_lines = source_file$lines,
       content = source_file$lines,
+      full_parsed_content = parsed_content,
       xml_parsed_content = if (!is.null(parsed_content)) xml2::read_xml(xmlparsedata::xml_parse_data(parsed_content))
-      )
+    )
 
   list(expressions = expressions, error = e, lines = source_file$lines)
 }

diff --git a/R/object_usage_linter.R b/R/object_usage_linter.R
@@ -3,7 +3,11 @@
 #' \code{\link[base]{eval}} on the code, so do not use with untrusted code.
 #' @export
 object_usage_linter <-  function(source_file) {
-  # we need to evaluate each expression in order to use checkUsage on it.
+  # we only want to run on the full file
+  if (is.null(source_file$file_lines)) {
+    return()
+  }
+  source_file$parsed_content <- source_file$full_parsed_content
 
   pkg_name <- pkg_name(find_package(dirname(source_file$filename)))
   if (!is.null(pkg_name)) {
@@ -14,91 +18,48 @@ object_usage_linter <-  function(source_file) {
   }
   env <- new.env(parent = parent_env)
 
-  globals <- mget(".__global__",
-    parent_env,
-    ifnotfound = list(NULL))$`.__global__`
-
-  mapply(assign, globals, MoreArgs = list(value = function(...) NULL, envir = env))
-
-  # add file locals to the environment
-  try_silently(eval(source_file$parsed_content, envir = env))
+  # add file assignments to globals
+  try_silently(eval(source_file$file_lines, envir = env))
 
   declared_globals <- utils::globalVariables(package = pkg_name %||% globalenv())
 
   all_globals <- unique(recursive_ls(env))
 
-  lapply(ids_with_token(source_file, rex(start, "FUNCTION"), fun = re_matches),
-    function(loc) {
-      id <- source_file$parsed_content$id[loc]
+  try_silently(eval(
+      parse(
+        text = source_file$content,
+        keep.source = TRUE
+        ),
+      envir = env))
 
-      parent_ids <- parents(source_file$parsed_content, id, simplify = FALSE)
+  res <- parse_check_usage(env)
 
-      parent_has_assign <- "LEFT_ASSIGN" %in% source_file$parsed_content$token[source_file$parsed_content$parent == parent_ids[[2]]]
-
-      # not a top level function, so just return.
-      if (length(parent_ids) > 3L || !parent_has_assign) {
-        return(NULL)
-      }
+  lapply(which(!is.na(res$message)),
+    function(row_num) {
+      row <- res[row_num, ]
 
-      fun <- try_silently(eval(
-              parse(
-                text = source_file$content,
-                keep.source = TRUE
-                ),
-              envir = env))
-
-      if (inherits(fun, "try-error")) {
+      if (row$name %in% declared_globals) {
         return()
       }
 
-      res <- parse_check_usage(fun)
-
-      locals <- codetools::findFuncLocals(formals(fun), body(fun))
-
-      both <- c(locals, names(formals(fun)), all_globals)
-
-      lapply(which(!is.na(res$message)),
-        function(row_num) {
-          row <- res[row_num, ]
-
-          if (row$name %in% declared_globals) {
-            return()
-          }
-
-          # if a no visible binding message suggest an alternative
-          if (re_matches(row$message,
-              rex("no visible"))) {
-
-            suggestion <- try_silently(both[stringdist::amatch(row$name, both, maxDist = 2)])
-
-            if (!inherits(suggestion, "try-error") && !is.na(suggestion)) {
-              row$message <- paste0(row$message, ", Did you mean '", suggestion, "'?")
-            }
-
-          }
-
-          org_line_num <- as.integer(row$line_number) + as.integer(names(source_file$lines)[1]) - 1L
-
-          line <- source_file$lines[as.character(org_line_num)]
-
-          row$name <- re_substitutes(row$name, rex("<-"), "")
+      line <- source_file$content[as.integer(row$line_number)]
 
-          location <- re_matches(line,
-            rex(row$name),
-            locations = TRUE)
+      row$name <- re_substitutes(row$name, rex("<-"), "")
 
-          Lint(
-            filename = source_file$filename,
-            line_number = org_line_num,
-            column_number = location$start,
-            type = "warning",
-            message = row$message,
-            line = line,
-            ranges = list(c(location$start, location$end)),
-            linter = "object_usage_linter"
-            )
-        })
+      location <- re_matches(line,
+        rex(row$name),
+        locations = TRUE)
 
+      Lint(
+        filename = source_file$filename,
+        line_number = row$line_number,
+        column_number = location$start,
+        type = "warning",
+        message = row$message,
+        line = line,
+        ranges = list(c(location$start, location$end)),
+        linter = "object_usage_linter"
+      )
     })
 }
 
@@ -110,7 +71,7 @@ parse_check_usage <- function(expression) {
     vals[[length(vals) + 1L]] <<- x
   }
 
-  try(codetools::checkUsage(expression, report = report))
+  try(codetools::checkUsageEnv(expression, report = report))
 
   function_name <- rex(anything, ": ")
   line_info <- rex(" ", anything, ":", capture(name = "line_number", digits), ")")

diff --git a/tests/testthat/test-object_usage_linter.R b/tests/testthat/test-object_usage_linter.R
@@ -51,37 +51,37 @@ fun2 <- function(x) {
 }",
     list(
       rex("local variable", anything, "assigned but may not be used"),
-      rex("no visible binding for global variable ", anything, ", Did you mean")
+      rex("no visible binding for global variable ", anything)
       ),
     object_usage_linter)
 
   expect_lint(
 "fun <- function() {
   fnu(1)
 }",
-    rex("no visible global function definition for ", anything, ", Did you mean", anything),
+    rex("no visible global function definition for ", anything),
     object_usage_linter)
 
   expect_lint(
 "fun <- function(x) {
   n(1)
 }",
-    rex("no visible global function definition for ", anything, ", Did you mean", anything),
+    rex("no visible global function definition for ", anything),
     object_usage_linter)
 
   test_that("replace_functions_stripped", {
     expect_lint(
 "fun <- function(x) {
   n(x) = 1
 }",
-    rex("no visible global function definition for ", anything, ", Did you mean", anything),
+    rex("no visible global function definition for ", anything),
     object_usage_linter)
 
     expect_lint(
 "fun <- function(x) {
   n(x) <- 1
 }",
-    rex("no visible global function definition for ", anything, ", Did you mean", anything),
+    rex("no visible global function definition for ", anything),
     object_usage_linter)
   })