# Retrieve the lifecycle status defined in each Rd file
db_lifecycle <- function(db) {
  lifecycle_patterns <- paste0(
    "(?:",
    paste(
      collapse = "|",
      c(
        "lifecycle::badge\\([\\\\]\"",
        "rlang:::lifecycle\\([\\\\]\"",
        "list\\(\"lifecycle-",
        "https://www.tidyverse.org/lifecycle/#"
      )
    ),
    ")([\\w-]+)"
  )

  desc <- lapply(db, asNamespace("tools")$.Rd_get_metadata, "description")
  lapply(desc, function(x) {
    res <- regexpr(lifecycle_patterns, x, perl = TRUE)
    starts <- attr(res, "capture.start")
    ends <- starts + attr(res, "capture.length") - 1
    substring(x, starts, ends)
  })
}

# Retrieve the functions listed in the usage for each Rd file in the database
db_function <- function(db) {
  usage <- lapply(db, asNamespace("tools")$.Rd_get_section, "usage")
  lapply(usage, get_usage_function_names)
}

#' @param package The name of an installed package.
#' @param which The lifecycle statuses to retrieve.
#'   Include `NA` if you want to include functions without a specified lifecycle
#'   status in the results.
#' @export
#' @rdname lifecycle_linter
pkg_lifecycle_statuses <- function(
  package,
  which = c(
    "superseded",
    "deprecated",
    "questioning",
    "defunct",
    "experimental",
    "soft-deprecated",
    "retired"
  )
) {
  check_installed("vctrs")
  which <- match.arg(which, several.ok = TRUE)
  stopifnot(is_string(package))

  db <- tools::Rd_db(package)
  lc <- db_lifecycle(db)
  funs <- db_function(db)

  res <- mapply(
    function(lc, f) {
      data.frame(
        fun = f,
        lifecycle = rep(lc, length(f)),
        stringsAsFactors = FALSE
      )
    },
    lc,
    funs,
    SIMPLIFY = FALSE
  )

  res <- vctrs::vec_rbind(!!!res)

  # Filter funs without a lifecycle
  if (!NA %in% which) {
    res <- res[!is.na(res$lifecycle), ]
  }

  # Filter funs without a function name
  res <- res[nzchar(res$fun), ]

  # Filter method definitions
  res <- res[grep("[\\\\]method\\{", res$fun, invert = TRUE), ]

  # filter lifecycles not in which
  res <- res[res$lifecycle %in% which, ]

  if (nrow(res) == 0) {
    return(data.frame(
      package = character(),
      fun = character(),
      lifecycle = character()
    ))
  }

  res$package <- package

  res[c("package", "fun", "lifecycle")]
}

get_usage_function_names <- function(x) {
  if (!length(x)) {
    character(1)
  } else {
    res <- asNamespace("tools")$.parse_usage_as_much_as_possible(x)
    vapply(
      res,
      function(x) {
        if (is.call(x)) as.character(x[[1]]) else character(1)
      },
      character(1)
    )
  }
}

#' @rdname lifecycle_linter
#' @param path The directory path to the files you want to search.
#' @param pattern Any files matching this pattern will be searched. The default
#'   searches any files ending in `.R` or `.Rmd`.
#' @export
lint_lifecycle <- function(
  packages,
  path = ".",
  pattern = "(?i)[.](r|rmd|qmd|rnw|rhtml|rrst|rtex|rtxt)$",
  which = c(
    "superseded",
    "deprecated",
    "questioning",
    "defunct",
    "experimental",
    "soft-deprecated",
    "retired"
  ),
  symbol_is_undesirable = FALSE
) {
  which <- match.arg(which, several.ok = TRUE)

  check_installed(c("lintr", "vctrs", "xml2"))

  lintr::lint_dir(
    path = path,
    pattern = pattern,
    linters = lifecycle_linter(
      packages = packages,
      which = which,
      symbol_is_undesirable = symbol_is_undesirable
    )
  )
}

#' @rdname lifecycle_linter
#' @export
lint_tidyverse_lifecycle <- function(
  path = ".",
  pattern = "(?i)[.](r|rmd|qmd|rnw|rhtml|rrst|rtex|rtxt)$",
  which = c(
    "superseded",
    "deprecated",
    "questioning",
    "defunct",
    "experimental",
    "soft-deprecated",
    "retired"
  ),
  symbol_is_undesirable = FALSE
) {
  which <- match.arg(which, several.ok = TRUE)

  check_installed(c("lintr", "vctrs", "xml2", "tidyverse"))

  lint_lifecycle(
    packages = tidyverse::tidyverse_packages(),
    pattern = pattern,
    path = path,
    which = which,
    symbol_is_undesirable = symbol_is_undesirable
  )
}

#' Lint usages of functions that have a non-stable life cycle.
#'
#' - `lifecycle_linter()` creates a linter for lifecycle annotations which can be
#'   included in a `.lintr` configuration if `lintr` is used directly.
#' - `lint_lifecycle()` dynamically queries the package documentation for packages
#'   in `packages` for lifecycle annotations and then searches the directory in
#'   `path` for usages of those functions.
#' - `lint_tidyverse_lifecycle()` is a convenience function to call `lint_lifecycle()`
#'   for all the packages in the tidyverse.
#' - `pkg_lifecycle_statuses()` returns a data frame of functions with lifecycle
#'   annotations for an installed package.
#'
#' @param packages One or more installed packages to query for lifecycle statuses.
#' @param which Vector of lifecycle statuses to lint.
#' @param symbol_is_undesirable Also lint symbol usages, e.g. `lapply(x, is_na)`?
#'
#' @export
#' @examples
#' lintr::lint(
#'   text = "is_na(x)",
#'   linters = lifecycle_linter(packages = "rlang")
#' )
#' lintr::lint(
#'   text = "lapply(x, is_na)",
#'   linters = lifecycle_linter(packages = "rlang",
#'   symbol_is_undesirable = TRUE)
#' )
lifecycle_linter <- function(
  packages = tidyverse::tidyverse_packages(),
  which = c(
    "superseded",
    "deprecated",
    "questioning",
    "defunct",
    "experimental",
    "soft-deprecated",
    "retired"
  ),
  symbol_is_undesirable = FALSE
) {
  check_installed(c("lintr", "vctrs", "xml2"))

  life_cycles <- vctrs::vec_rbind(
    !!!lapply(packages, pkg_lifecycle_statuses, which = which)
  )
  bad_usages <- sprintf(
    "`%s::%s` is %s",
    life_cycles$package,
    life_cycles$fun,
    life_cycles$lifecycle
  )
  names(bad_usages) <- life_cycles$fun

  if (symbol_is_undesirable) {
    xpath <- sprintf(
      "//SYMBOL_FUNCTION_CALL[%1$s] | //SYMBOL[%1$s]",
      paste0("text() = '", names(bad_usages), "'", collapse = " or ")
    )
  } else {
    xpath <- sprintf(
      "//SYMBOL_FUNCTION_CALL[%s]",
      paste0("text() = '", names(bad_usages), "'", collapse = " or ")
    )
  }

  lintr::Linter(function(source_expression) {
    if (!lintr::is_lint_level(source_expression, "expression")) {
      return(list())
    }

    matched_nodes <- xml2::xml_find_all(
      source_expression$xml_parsed_content,
      xpath
    )
    fun_names <- lintr::get_r_string(matched_nodes)

    lintr::xml_nodes_to_lints(
      matched_nodes,
      source_expression = source_expression,
      lint_message = unname(bad_usages[fun_names])
    )
  })
}
