R/linters.R

In rsconnect: Deploy Docs, Apps, and APIs to 'Posit Connect', 'shinyapps.io', and 'RPubs'

.__LINTERS__. <- new.env(parent = emptyenv())

##' Add a Linter
##'
##' Add a linter, to be used in subsequent calls to [lint()].
##'
##' @param name The name of the linter, as a string.
##' @param linter A [linter()].
##' @export
##' @example examples/example-linter.R
addLinter <- function(name, linter) {
  assign(name, linter, envir = .__LINTERS__.)
}

##' Create a Linter
##'
##' Generate a linter, which can identify errors or problematic regions in a
##' project.
##'
##' @param apply Function that, given the content of a file, returns the indices
##'   at which problems were found.
##' @param takes Function that, given a set of paths, returns the subset of
##'   paths that this linter uses.
##' @param message Function that, given content and lines, returns an
##'   informative message for the user. Typically generated with
##'   [makeLinterMessage()].
##' @param suggestion String giving a prescribed fix for the linted problem.
##' @export
##' @example examples/example-linter.R
linter <- function(apply, takes, message, suggestion) {
  result <- list(
    apply = apply,
    takes = takes,
    message = message,
    suggestion = suggestion
  )
  class(result) <- "linter"
  result
}

getLinterApplicableFiles <- function(linter, files) {
  result <- linter$takes(files)
  if (is.numeric(result) || is.logical(result)) {
    files[result]
  } else {
    result
  }
}

applyLinter <- function(linter, ...) {
  result <- linter$apply(...)
  if (is.logical(result)) {
    output <- which(result)
  } else {
    output <- as.numeric(result)
  }
  attributes(output) <- attributes(result)
  output
}


isRCodeFile <- function(path) {
  grepl("\\.[rR]$|\\.[rR]md$|\\.[rR]nw$", path)
}


addLinter(
  "absolute.paths",
  linter(
    apply = function(content, ...) {
      content <- stripComments(content)
      which(hasAbsolutePaths(content))
    },

    takes = isRCodeFile,

    message = function(content, lines) {
      makeLinterMessage(
        "The following lines contain absolute paths",
        content,
        lines
      )
    },

    suggestion = "Paths should be to files within the project directory."
  )
)

addLinter(
  "filepath.capitalization",
  linter(
    apply = function(content, project, path, files) {
      content <- stripComments(content)

      # Extract references between bounding (unescaped) quotes.
      extractQuoted <- function(regex) {
        matches <- gregexpr(regex, content, perl = TRUE)
        results <- vector("list", length(content))
        for (i in seq_along(matches)) {
          x <- matches[[i]]
          if (x[[1]] == -1L || length(x) %% 2 != 0) {
            next
          }
          starts <- x[seq(1, length(x), by = 2)]
          ends <- x[seq(2, length(x), by = 2)]
          results[[i]] <- character(length(starts))
          for (j in seq_along(starts)) {
            results[[i]][[j]] <- substring(
              content[i],
              starts[j] + 1,
              ends[j] - 1
            )
          }
        }
        results
      }

      # Extract targets from Markdown links.
      extractLinked <- function() {
        regex <- "\\]\\(.*?\\)"
        matches <- gregexpr(regex, content, perl = TRUE)
        results <- vector("list", length(content))
        for (i in seq_along(matches)) {
          x <- matches[[i]]
          if (x[[1]] == -1L) {
            next
          }
          results[[i]] <- character(length(x))
          attr <- attributes(x)
          for (j in seq_along(x)) {
            raw <- x[[j]]
            raw.length <- attr$match.length[[j]]
            # skip past "](" and discard ")"
            start <- as.integer(raw) + 2
            end <- as.integer(raw) + raw.length - 2
            results[[i]][[j]] <- substring(content[i], start, end)
          }
        }
        results
      }

      # Inferred files within source documents; between matching quotes or in
      # something that looks like a Markdown link.
      inferredFiles <- list(
        "single.quotes" = extractQuoted("(?!\\\\)\'"),
        "double.quotes" = extractQuoted("(?!\\\\)\""),
        "markdown.links" = extractLinked()
      )

      ## Replace '\' with '/' in filepaths for consistency in comparisons
      inferredFiles <- lapply(inferredFiles, function(x) {
        lapply(x, function(xx) {
          gsub("\\\\", "/", xx, perl = TRUE)
        })
      })

      # Compare in case sensitive, case insensitive fashion
      projectFiles <- files
      projectFilesLower <- tolower(files)

      badLines <- lapply(inferredFiles, function(regex) {
        lapply(regex, function(x) {
          which(
            # Only examine paths containing a slash to reduce false positives
            grepl("/", x, fixed = TRUE) &
              (tolower(x) %in% projectFilesLower) &
              (!(x %in% projectFiles))
          )
        })
      })

      indices <- Reduce(
        union,
        lapply(badLines, function(x) {
          which(sapply(x, length) > 0)
        })
      )

      if (!length(indices)) {
        return(integer())
      }

      from <- lapply(inferredFiles, function(x) x[indices])
      to <- lapply(from, function(x) {
        lapply(x, function(xx) {
          projectFiles[tolower(xx) == projectFilesLower]
        })
      })

      messages <- lapply(seq_along(from), function(regex) {
        lapply(seq_along(regex), function(i) {
          if (length(from[[regex]][[i]])) {
            paste(
              collapse = ", ",
              paste(
                "[",
                sQuote(from[[regex]][[i]]),
                " -> ",
                sQuote(to[[regex]][[i]]),
                "]",
                sep = ""
              )
            )
          } else {
            ""
          }
        })
      })

      transposed <- transposeList(messages)
      lint <- sapply(transposed, function(x) {
        paste(x[x != ""], collapse = ", ")
      })

      indices <- as.numeric(indices)
      attr(indices, "lint") <- lint
      indices
    },

    takes = isRCodeFile,

    message = function(content, lines) {
      makeLinterMessage(
        "The following lines contain paths to files not matching in case sensitivity",
        content,
        lines
      )
    },

    suggestion = "Filepaths are case-sensitive on deployment server."
  )
)

addLinter(
  "browser",
  linter(
    apply = function(content, ...) {
      content <- stripComments(content)
      which(hasBrowserCalls(content))
    },

    takes = isRCodeFile,

    message = function(content, lines) {
      makeLinterMessage(
        "The following lines contain the browser() debugging function",
        content,
        lines
      )
    },

    suggestion = "The browser() debugging function should be removed."
  )
)

addLinter(
  "browseURL",
  linter(
    apply = function(content, ...) {
      content <- stripComments(content)
      which(hasBrowseURLCalls(content))
    },

    takes = isRCodeFile,

    message = function(content, lines) {
      makeLinterMessage(
        "The following lines contain calls to the browseURL function",
        content,
        lines
      )
    },

    suggestion = "Remove browseURL calls; browseURL does not work in deployed applications."
  )
)


stripComments <- function(content) {
  gsub("#.*", "", content, perl = TRUE)
}

hasBrowserCalls <- function(content) {
  # look for calls to browser(); they will cause a debug halt, which is almost
  # never wanted in a production application
  grepl("\\bbrowser\\([^)]*\\)", content, perl = TRUE)
}

hasBrowseURLCalls <- function(content) {
  # look for calls to browseURL(); browsers can't be opened on the server in
  # deployed applications
  grepl("\\bbrowseURL\\([^)]*\\)", content, perl = TRUE)
}

hasAbsolutePaths <- function(content) {
  regex <- c(
    "\\[(.*?)\\]\\(\\s*[a-zA-Z]:/[^\"\']", ## windows-style markdown references [Some image](C:/...)
    "\\[(.*?)\\]\\(\\s*/[^/]", ## unix-style markdown references [Some image](/Users/...)
    NULL ## so we don't worry about commas above
  )

  regexResults <- as.logical(Reduce(
    `+`,
    lapply(regex, function(rex) {
      grepl(rex, content, perl = TRUE)
    })
  ))

  # Strip out all strings in the document, and check to see if any of them
  # resolve to absolute paths on the system.
  sQuoteRegex <- "['](?:(?:\\\\.)|(?:[^'\\\\]))*?[']"
  dQuoteRegex <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]'

  extractedStrings <- lapply(c(sQuoteRegex, dQuoteRegex), function(regex) {
    matches <- gregexpr(regex, content, perl = TRUE)
    lapply(seq_along(matches), function(i) {
      match <- matches[[i]]
      if (c(match[[1]]) == -1L) {
        return(character())
      }
      starts <- as.integer(match) + 1
      ends <- starts + attr(match, "match.length") - 3
      substring(content[[i]], starts, ends)
    })
  })

  strings <- vector("list", length(extractedStrings[[1]]))
  for (i in seq_along(extractedStrings[[1]])) {
    strings[[i]] <- unique(c(
      extractedStrings[[1]][[i]],
      extractedStrings[[2]][[i]]
    ))
    strings[[i]] <- strings[[i]][nchar(strings[[i]]) >= 5]
  }

  lineHasAbsolutePath <- unlist(lapply(strings, function(x) {
    any(
      grepl("^/|^[a-zA-Z]:/|^~", x, perl = TRUE) &
        file.exists(x) &
        !dirExists(x) &
        vapply(
          gregexpr("[~/]", x, perl = TRUE),
          USE.NAMES = FALSE,
          FUN.VALUE = numeric(1),
          length
        ) >=
          3
    )
  }))

  as.logical(lineHasAbsolutePath + regexResults)
}

noMatch <- function(x) {
  identical(attr(x, "match.length"), -1L)
}

transposeList <- function(list) {
  unname(as.list(
    as.data.frame(
      t(
        as.matrix(
          as.data.frame(list, stringsAsFactors = FALSE)
        )
      ),
      stringsAsFactors = FALSE
    )
  ))
}