diff --git a/NEWS.md b/NEWS.md index 1f6616efd..17fcc2538 100644 --- a/NEWS.md +++ b/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 diff --git a/R/object_usage_linter.R b/R/object_usage_linter.R index f227c177e..7481adb00 100644 --- a/R/object_usage_linter.R +++ b/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,16 +194,18 @@ 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() @@ -157,7 +213,11 @@ parse_check_usage <- function(expression) { 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), ":", diff --git a/tests/testthat/test-object_usage_linter.R b/tests/testthat/test-object_usage_linter.R index 2b39053ec..6b1164f5a 100644 --- a/tests/testthat/test-object_usage_linter.R +++ b/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()) +})