object_name_linters.R

#' @describeIn linters  Check that object names conform to a naming style.
#' @param styles A subset of
#'   \Sexpr[stage=render, results=rd]{lintr:::regexes_rd}. A name should
#'   match at least one of these styles.
#' @export
object_name_linter <- function(styles = "snake_case") {

  .or_string <- function(xs) {
    # returns "<S> or <T>"
    # where <T> is the last string in xs
    # where <S> is a comma-separated string of all entries in xs except <T>
    len <- length(xs)
    if (len <= 1) {
      return(xs)
    }
    comma_sepd_prefix <- paste(xs[-len], collapse = ", ")
    paste(comma_sepd_prefix, "or", xs[len])
  }

  styles <- match.arg(styles, names(style_regexes), several.ok = TRUE)

  lint_msg <- paste0(
    "Variable and function name style should be ", .or_string(styles), "."
  )

  function(source_file) {
    x <- global_xml_parsed_content(source_file)
    if (is.null(x)) {
      return()
    }

    xpath <- paste0(
      # Left hand assignments
      "//expr[SYMBOL or STR_CONST][following-sibling::LEFT_ASSIGN or following-sibling::EQ_ASSIGN]/*",

      # Or
      " | ",

      # Right hand assignments
      "//expr[SYMBOL or STR_CONST][preceding-sibling::RIGHT_ASSIGN]/*",

      # Or
      " | ",

      # Formal argument names
      "//SYMBOL_FORMALS"
    )

    assignments <- xml2::xml_find_all(x, xpath)

    # Retrieve assigned name
    nms <- strip_names(
      as.character(xml2::xml_find_first(assignments, "./text()")))

    generics <- c(
      declared_s3_generics(x),
      namespace_imports()$fun,
      names(.knownS3Generics),
      .S3PrimitiveGenerics, ls(baseenv()))

    style_matches <- lapply(styles, function(x) {
      check_style(nms, x, generics)
    })

    matches_a_style <- Reduce(`|`, style_matches)

    lapply(
      assignments[!matches_a_style],
      object_lint2,
      source_file,
      lint_msg,
      "object_name_linter"
    )
  }
}

check_style <- function(nms, style, generics = character()) {
  conforming <- re_matches(nms, style_regexes[[style]])

  # mark empty names and NA names as conforming
  conforming[!nzchar(nms) | is.na(conforming)] <- TRUE

  if (any(!conforming)) {
    possible_s3 <- re_matches(
      nms[!conforming],
      rex(capture(name = "generic", something), ".", capture(name = "method", something))
    )
    if (any(!is.na(possible_s3))) {
      has_generic <- possible_s3$generic %in% generics

      # If they are not conforming, but are S3 methods then ignore them
      conforming[!conforming][has_generic] <- TRUE
    }
  }
  conforming
}

# Remove quotes or other things from names
strip_names <- function(x) {
  x <- re_substitutes(x, rex(start, some_of(".", quote, "`", "%", "$", "@")), "")
  x <- re_substitutes(x, rex(some_of(quote, "`", "<", "-", "%", "$", "@"), end), "")
  x
}


object_lint2 <- function(expr, source_file, message, type) {
  symbol <- xml2::as_list(expr)
  Lint(
    filename = source_file$filename,
    line_number = symbol@line1,
    column_number = symbol@col1,
    type = "style",
    message = message,
    line = source_file$file_lines[as.numeric(symbol@line1)],
    ranges = list(as.numeric(c(symbol@col1, symbol@col2))),
    linter = type
    )
}

make_object_linter <- function(fun) {
  function(source_file) {

    token_nums <- ids_with_token(
      source_file, rex(start, "SYMBOL" %if_next_isnt% "_SUB"), fun=re_matches
    )
    if (length(token_nums) == 0) {
      return(list())
    }
    tokens <- with_id(source_file, token_nums)
    names <- unquote(tokens[["text"]]) # remove surrounding backticks

    keep_indices <- which(
      !is_operator(names) &
        !is_known_generic(names) &
        !is_base_function(names) &
        !is_special_function(names)
    )

    lapply(
      keep_indices,
      function(i) {
        token <- tokens[i, ]
        if (is_declared_here(token, source_file) &&
            !is_external_reference(source_file, token[["id"]])) {
          fun(source_file, token)
        }
      }
    )
  }
}

known_generic_regex <- rex(
  start,
  or(
    unique(
      # Clean up "as.data.frame" to "as", "names<-" to "names", etc
      re_substitutes(c(names(.knownS3Generics), .S3PrimitiveGenerics),
                     rex(or(dot, "<-"), anything, end), "")
    )
  ),
  dot
)

is_known_generic <- function(name) {
  re_matches(name, known_generic_regex)
}

is_declared_here <- function(token, source_file) {
  # The object was declared here if one of the following is true:
  #   * its name precedes a left assign ("<-" or "<<-") or equal assign ("=")
  #   * its name follows a right assign ("->" or "->>")
  #   * its name is not "..." and its first sibling token is a function definition
  filt <- filter_out_token_type(source_file[["parsed_content"]], "expr")
  assign_regex <- rex(start, or("EQ_ASSIGN", "LEFT_ASSIGN"), end)
  l <- which(filt[, "id"] == token[["id"]])
  if ( (l + 1L <= dim(filt)[[1L]] && re_matches(filt[l + 1L, "token"], assign_regex)) ||
       (l >= 2L  &&  filt[l - 1L, "token"] == "RIGHT_ASSIGN") ) {
    # assigned variable or function parameter
    TRUE
  } else {
    sibling_ids <- siblings(source_file[["parsed_content"]], token[["id"]], 1L)
    if (token[["text"]] != "..." &&
        length(sibling_ids) &&
        with_id(source_file, sibling_ids[[1L]])[["text"]] == "function" ) {
      # parameter in function definition
      TRUE
    } else {
      FALSE
    }
  }
}

is_operator <- function(name) {
  name != make.names(name)
}

is_external_reference <- function(source_file, id) {
  sibling_tokens <- with_id(source_file, siblings(source_file$parsed_content, id, 1))$token
  any(sibling_tokens %in% c("NS_GET", "NS_GET_INT"))
}

# via unlist(tools:::.get_standard_package_names(), use.names = FALSE)
base_pkgs <- c(
  "base",
  "tools",
  "utils",
  "grDevices",
  "graphics",
  "stats",
  "datasets",
  "methods",
  "grid",
  "splines",
  "stats4",
  "compiler",
  "parallel",
  "MASS",
  "lattice",
  "Matrix",
  "nlme",
  "survival",
  "boot",
  "cluster",
  "codetools",
  "foreign",
  "KernSmooth",
  "rpart",
  "class",
  "nnet",
  "spatial",
  "mgcv"
)

base_funs <- unlist(lapply(base_pkgs,
                           function(x) {
                             name <- try_silently(getNamespace(x))
                             if (!inherits(name, "try-error")) {
                               ls(name, all.names = TRUE)
                             }
                           }))

is_base_function <- function(x) {
  x %in% base_funs
}

# see ?".onLoad" and ?"Startup"
special_funs <- c(
  ".onLoad",
  ".onAttach",
  ".onUnload",
  ".onDetach",
  ".Last.lib",
  ".First",
  ".Last"
)

is_special_function <- function(x) {
  x %in% special_funs
}

object_lint <- function(source_file, token, message, type) {
  Lint(
    filename = source_file$filename,
    line_number = token$line1,
    column_number = token$col1,
    type = "style",
    message = message,
    line = source_file$lines[as.character(token$line1)],
    ranges = list(c(token$col1, token$col2)),
    linter = type
    )
}


object_name_linter_old <- function(style = "snake_case") {
  make_object_linter(
    function(source_file, token) {
      name <- unquote(token[["text"]])
      if (!any(matches_styles(name, style))) {
        object_lint(
          source_file,
          token,
          sprintf("Variable and function name style should be %s.", paste(style, collapse = " or ")),
          "object_name_linter"
        )
      }
    }
  )
}


loweralnum <- rex(one_of(lower, digit))
upperalnum <- rex(one_of(upper, digit))

style_regexes <- list(
  "CamelCase" = rex(start, maybe("."), upper, zero_or_more(alnum), end),
  "camelCase" = rex(start, maybe("."), lower, zero_or_more(alnum), end),
  "snake_case"     = rex(start, maybe("."), some_of(lower, digit), any_of("_", lower, digit), end),
  "SNAKE_CASE"     = rex(start, maybe("."), some_of(upper, digit), any_of("_", upper, digit), end),
  "dotted.case"    = rex(start, maybe("."), one_or_more(loweralnum), zero_or_more(dot, one_or_more(loweralnum)), end),
  "lowercase"   = rex(start, maybe("."), one_or_more(loweralnum), end),
  "UPPERCASE"   = rex(start, maybe("."), one_or_more(upperalnum), end)
)

regexes_rd <- paste0(collapse = ", ", paste0("\\sQuote{", names(style_regexes), "}"))

matches_styles <- function(name, styles=names(style_regexes)) {
  invalids <- paste(styles[!styles %in% names(style_regexes)], collapse=", ")
  if (nzchar(invalids)) {
    valids <- paste(names(style_regexes), collapse=", ")
    stop(sprintf("Invalid style(s) requested: %s\nValid styles are: %s\n", invalids, valids))
  }
  name <- re_substitutes(name, rex(start, one_or_more(dot)), "")  # remove leading dots
  vapply(
    style_regexes[styles],
    re_matches,
    logical(1L),
    data=name
  )
}


#' @describeIn linters check that object names are not too long.
#' @export
object_length_linter <- function(length = 30L) {
  make_object_linter(function(source_file, token) {
    if (nchar(token$text) > length) {
        object_lint(
          source_file,
          token,
          paste0("Variable and function names should not be longer than ", length, " characters."),
          "object_length_linter"
        )
      }
  })
}