fix #942

NEWS.md

@@ -97,6 +97,7 @@ function calls. (#850, #851, @renkun-ken)
 * `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)
+* `object_usage_linter()` now detects usages inside `glue::glue()` constructs (#942, @AshesITR)
 
 # lintr 2.0.1
 

R/object_usage_linter.R

@@ -3,10 +3,13 @@
 #' Check that closures have the proper usage using [codetools::checkUsage()].
 #' Note that this runs [base::eval()] on the code, so do not use with untrusted code.
 #'
+#' @param interpret_glue If TRUE, interpret [glue::glue()] calls to avoid false positives caused by local variables
+#' which are only used in a glue expression.
+#'
 #' @evalRd rd_tags("object_usage_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-object_usage_linter <- function() {
+object_usage_linter <- function(interpret_glue = TRUE) {
   Linter(function(source_file) {
     # If there is no xml data just return
     if (is.null(source_file$full_xml_parsed_content)) return(list())
@@ -47,7 +50,13 @@ object_usage_linter <- function() {
       if (inherits(fun, "try-error")) {
         return()
       }
-      res <- parse_check_usage(fun)
+      if (isTRUE(interpret_glue)) {
+        known_used_symbols <- extract_glued_symbols(info$expr[[1L]])
+      } else {
+        known_used_symbols <- character()
+      }
+
+      res <- parse_check_usage(fun, known_used_symbols = known_used_symbols)
 
       lapply(
         which(!is.na(res$message)),
@@ -98,6 +107,51 @@ object_usage_linter <- function() {
   })
 }
 
+extract_glued_symbols <- function(expr) {
+  glue_calls <- xml2::xml_find_all(
+    expr,
+    xpath = paste0(
+      "descendant::SYMBOL_FUNCTION_CALL[text() = 'glue']/", # a glue() call
+      "preceding-sibling::NS_GET/preceding-sibling::SYMBOL_PACKAGE[text() = 'glue']/", # qualified with glue::
+      "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())
+  glued_symbols <- new.env(parent = emptyenv())
+  for (cl in glue_calls) {
+    parsed_cl <- tryCatch(
+      parse(text = xml2::xml_text(cl)),
+      error = function(...) NULL,
+      warning = function(...) NULL
+    )[[1L]]
+    if (is.null(parsed_cl)) next
+    parsed_cl[[".transformer"]] <- function(text, envir) {
+      parsed_text <- tryCatch(
+        parse(text = text),
+        error = function(...) NULL,
+        warning = function(...) NULL
+      )
+      parsed_xml <- safe_parse_to_xml(parsed_text)
+      if (is.null(parsed_xml)) return("")
+      symbols <- xml2::xml_text(xml2::xml_find_all(parsed_xml, "//SYMBOL"))
+      for (sym in symbols) {
+        assign(sym, NULL, envir = glued_symbols)
+      }
+      ""
+    }
+    eval(parsed_cl)
+  }
+  ls(envir = glued_symbols, all.names = TRUE)
+}
+
 get_assignment_symbols <- function(xml) {
   left_assignment_symbols <-
     xml2::xml_text(xml2::xml_find_all(xml, "expr[LEFT_ASSIGN]/expr[1]/SYMBOL[1]"))
@@ -140,24 +194,30 @@ get_function_assignments <- function(xml) {
 
   get_attr <- function(x, attr) as.integer(xml2::xml_attr(x, attr))
 
-  data.frame(
+  res <- data.frame(
     line1 = viapply(funs, get_attr, "line1"),
     line2 = viapply(funs, get_attr, "line2"),
     col1 = viapply(funs, get_attr, "col1"),
     col2 = viapply(funs, get_attr, "col2"),
     stringsAsFactors = FALSE
   )
+  res[["expr"]] <- funs
+  res
 }
 
-parse_check_usage <- function(expression) {
+parse_check_usage <- function(expression, known_used_symbols = character()) {
 
   vals <- list()
 
   report <- function(x) {
     vals[[length(vals) + 1L]] <<- x
   }
 
-  try(codetools::checkUsage(expression, report = report))
+  try(codetools::checkUsage(
+    expression,
+    report = report,
+    suppressLocalUnused = known_used_symbols
+  ))
 
   function_name <- rex(anything, ": ")
   line_info <- rex(" ", "(", capture(name = "path", non_spaces), ":",

tests/testthat/test-object_usage_linter.R

@@ -300,3 +300,36 @@ test_that("robust against errors", {
     object_usage_linter()
   )
 })
+
+test_that("interprets glue expressions", {
+  expect_lint(trim_some("
+    fun <- function() {
+      local_var <- 42
+      glue::glue('The answer is {local_var}.')
+    }
+  "), NULL, object_usage_linter())
+
+  # Steer clear of custom .transformer and .envir constructs
+  expect_lint(trim_some("
+    fun <- function() {
+      local_var <- 42
+      glue::glue('The answer is {local_var}.', .transformer = glue::identity_transformer)
+    }
+  "), "local_var", object_usage_linter())
+
+  expect_lint(trim_some("
+    fun <- function() {
+      local_var <- 42
+      e <- new.env()
+      glue::glue('The answer is {local_var}.', .envir = e)
+    }
+  "), "local_var", object_usage_linter())
+
+  expect_lint(trim_some("
+    fun <- function() {
+      local_var <- 42
+      unused_var <- 3
+      glue::glue('The answer is {local_var}.')
+    }
+  "), "unused_var", object_usage_linter())
+})