# TODO(R>=4.4.0): remove this.
# NB: {backports} approach doesn't work since we need this before .onLoad() in names2()
if (!exists("%||%", "package:base")) {
  `%||%` <- function(x, y) if (is.null(x)) y else x # nolint: coalesce_linter.
}

`%==%` <- function(x, y) {
  identical(x, y)
}

`%:::%` <- function(p, f) {
  get(f, envir = asNamespace(p))
}

flatten_lints <- function(x) {
  x <- flatten_list(x, class = "lint")
  class(x) <- "lints"
  x
}

# any function using unlist or c was dropping the classnames,
# so need to brute force copy the objects
flatten_list <- function(x, class) {
  if (length(x) == 0L) {
    return(list())
  }
  if (inherits(x, class)) {
    return(list(x))
  }
  if (is.list(x)) {
    is_flat <- TRUE
    for (i in seq_along(x)) {
      if (!inherits(x[[i]], class)) {
        is_flat <- FALSE
        break
      }
    }
    if (is_flat) {
      if (!is.null(names(x))) {
        names(x) <- NULL
      }
      return(x)
    }
  }

  outer_env <- new.env(parent = emptyenv())
  outer_env$res <- list()
  outer_env$itr <- 1L
  assign_item <- function(x) {
    if (inherits(x, class)) {
      outer_env$res[[outer_env$itr]] <- x
      outer_env$itr <- outer_env$itr + 1L
    } else if (is.list(x)) {
      lapply(x, assign_item)
    }
  }
  assign_item(x)
  outer_env$res
}

fix_names <- function(x, default) {
  nms <- names(x)

  if (is.null(nms)) {
    nms <- default
  } else {
    nms[!nzchar(nms)] <- default
  }
  names(x) <- nms
  x
}

linter_auto_name <- function(which = -3L) {
  sys_call <- sys.call(which = which)
  nm <- deparse1(sys_call)
  regex <- rex(start, one_or_more(alnum %or% "." %or% "_" %or% ":"))
  if (re_matches(nm, regex)) {
    match_data <- re_matches(nm, regex, locations = TRUE)
    nm <- nm |>
      substr(start = 1L, stop = match_data[1L, "end"]) |>
      re_substitutes(rex(start, alnums, "::"), "")
  }
  nm
}

auto_names <- function(x) {
  nms <- names2(x)
  empty <- !nzchar(nms, keepNA = TRUE)
  if (!any(empty)) {
    return(nms)
  }

  default_name <- function(x) {
    if (is_linter(x)) {
      attr(x, "name", exact = TRUE)
    } else {
      deparse1(x)
    }
  }
  defaults <- vapply(x[empty], default_name, character(1L), USE.NAMES = FALSE)

  nms[empty] <- defaults
  nms
}

# The following functions is from dplyr
names2 <- function(x) {
  names(x) %||% rep("", length(x))
}

#' @param needs_braces Logical, default FALSE. If it's possible or known that
#'   `lines` cannot be parsed as a standalone expression, only a "child"
#'   expression, we insert braces `{}` around it to ensure that it parses.
#'   There is only one known case for this, namely, when finding code with
#'   shorthand lambda `\(` where `\` and `(` are separated by a comment;
#'   see `object_usage_linter()` for more details.
#' @noRd
get_content <- function(lines, info, needs_braces = FALSE) {
  lines[is.na(lines)] <- ""

  if (!missing(info)) {
    # put in data.frame-like format
    if (is_node(info)) {
      info <- lapply(xml_attrs_(info), as.integer)
    }

    lines <- lines[seq(info$line1, info$line2)]
    lines[length(lines)] <- substr(lines[length(lines)], 1L, info$col2)
    lines[1L] <- substr(lines[1L], info$col1, nchar(lines[1L]))
  }
  if (needs_braces) lines <- c("{", lines, "}")
  paste(lines, collapse = "\n")
}

try_silently <- function(expr) {
  suppressWarnings(
    suppressMessages(
      try(expr, silent = TRUE)
    )
  )
}

# interface to work like options() or setwd() -- returns the old value for convenience
set_lang <- function(new_lang) {
  old_lang <- Sys.getenv("LANGUAGE", unset = NA)
  Sys.setenv(LANGUAGE = new_lang) # nolint: undesirable_function_name. Avoiding {withr} dep in pkg.
  old_lang
}
# handle the logic of either unsetting if it was previously unset, or resetting
reset_lang <- function(old_lang) {
  if (is.na(old_lang)) {
    Sys.unsetenv("LANGUAGE")
  } else {
    Sys.setenv(LANGUAGE = old_lang) # nolint: undesirable_function_name. Avoiding {withr} dep in pkg.
  }
}

#' Create a `linter` closure
#'
#' @param fun A function that takes a source file and returns `lint` objects.
#' @param name Default name of the Linter.
#' Lints produced by the linter will be labelled with `name` by default.
#' @param linter_level Which level of expression is the linter working with?
#'   `"expression"` means an individual expression in `xml_parsed_content`, while `"file"` means all expressions
#'   in the current file are available in `full_xml_parsed_content`.
#'   `NA` means the linter will be run with both, expression-level and file-level source expressions.
#'
#' @return The same function with its class set to 'linter'.
#' @export
Linter <- function(fun, name = linter_auto_name(), linter_level = c(NA_character_, "file", "expression")) { # nolint: object_name, line_length.
  if (!is.function(fun) || length(formals(args(fun))) != 1L) {
    cli_abort("{.arg fun} must be a function taking exactly one argument.")
  }
  linter_level <- match.arg(linter_level)
  force(name)
  class(fun) <- c("linter", "function")
  attr(fun, "name") <- name
  attr(fun, "linter_level") <- linter_level
  fun
}

ensure_utf8 <- function(lines, encoding = NULL) {
  if (is.null(encoding) || is.na(encoding)) {
    encoding <- ""
  }

  if (encoding == "" && l10n_info()[["UTF-8"]]) {
    encoding <- "UTF-8"
  }

  if (encoding == "UTF-8") {
    Encoding(lines) <- "UTF-8"
    return(lines)
  }

  is_utf8 <- Encoding(lines) == "UTF-8"
  if (any(is_utf8)) {
    return(lines)
  }

  lines_conv <- iconv(lines, from = encoding, to = "UTF-8")
  lines[!is.na(lines_conv)] <- lines_conv[!is.na(lines_conv)]
  Encoding(lines) <- "UTF-8"
  lines
}

read_lines <- function(file, ...) {
  outer_env <- new.env(parent = emptyenv())
  outer_env$terminal_newline <- TRUE
  lines <- withCallingHandlers(
    readLines(file, warn = TRUE, ...),
    warning = function(w) {
      if (grepl("incomplete final line found on", conditionMessage(w), fixed = TRUE)) {
        outer_env$terminal_newline <- FALSE
        invokeRestart("muffleWarning")
      }
    }
  )
  attr(lines, "terminal_newline") <- outer_env$terminal_newline
  lines
}

# see issue #923, PR #2455 -- some locales ignore _ when running sort(), others don't.
#   We want to consistently treat "_" < "n" = "N"; C locale does this, which 'radix' uses.
platform_independent_order <- function(x) order(tolower(x), method = "radix")
platform_independent_sort <- function(x) x[platform_independent_order(x)]

#' re_matches with type-stable logical output
#' TODO(r-lib/rex#94): Use re_matches() option directly & deprecate this.
#' @noRd
re_matches_logical <- function(x, regex, ...) {
  res <- re_matches(x, regex, ...)
  if (is.data.frame(res)) {
    res <- complete.cases(res)
  }
  res
}

#' re_matches with type-stable locations output for the overall match
#' @noRd
re_matches_locations <- function(x, regex, ...) {
  m <- regexpr(regex, x, perl = TRUE, ...)
  match_start <- as.vector(m)
  match_end <- match_start + attr(m, "match.length") - 1L
  matched <- match_start != -1L
  match_start[!matched] <- NA_integer_
  match_end[!matched] <- NA_integer_
  data.frame(start = match_start, end = match_end)
}

#' Extract text from `STR_CONST` nodes
#'
#' Convert `STR_CONST` `text()` values into R strings. This is useful to account for arbitrary
#'  character literals, e.g. `R"------[hello]------"`, which is parsed in R as `"hello"`.
#'  It is quite cumbersome to write XPaths allowing for strings like this, so whenever your
#'  linter logic requires testing a `STR_CONST` node's value, use this function.
#' NB: this is also properly vectorized on `s`, and accepts a variety of inputs. Empty inputs
#'  will become `NA` outputs, which helps ensure that `length(get_r_string(s)) == length(s)`.
#'
#' @param s An input string or strings. If `s` is an `xml_node` or `xml_nodeset` and `xpath` is `NULL`,
#'   extract its string value with [xml2::xml_text()]. If `s` is an `xml_node` or `xml_nodeset`
#'   and `xpath` is specified, it is extracted with [xml2::xml_find_chr()].
#' @param xpath An XPath, passed on to [xml2::xml_find_chr()] after wrapping with `string()`.
#'
#' @examples
#' tmp <- tempfile()
#' writeLines("c('a', 'b')", tmp)
#' expr_as_xml <- get_source_expressions(tmp)$expressions[[1L]]$xml_parsed_content
#' writeLines(as.character(expr_as_xml))
#' get_r_string(expr_as_xml, "expr[2]")
#' get_r_string(expr_as_xml, "expr[3]")
#' unlink(tmp)
#'
#' # more importantly, extract raw strings correctly
#' tmp_raw <- tempfile()
#' writeLines("c(R'(a\\b)', R'--[a\\\"\'\"\\b]--')", tmp_raw)
#' expr_as_xml_raw <- get_source_expressions(tmp_raw)$expressions[[1L]]$xml_parsed_content
#' writeLines(as.character(expr_as_xml_raw))
#' get_r_string(expr_as_xml_raw, "expr[2]")
#' get_r_string(expr_as_xml_raw, "expr[3]")
#' unlink(tmp_raw)
#'
#' @export
get_r_string <- function(s, xpath = NULL) {
  if (length(s) == 0L) {
    return(character())
  }
  if (is_node(s) || is_nodeset(s)) {
    if (is.null(xpath)) {
      s <- xml_text(s)
    } else {
      s <- xml_find_chr_(s, sprintf("string(%s)", xpath))
    }
  }
  r_string_from_parse_text(s)
}

# parse() skips "" elements --> offsets the length of the output,
#   but NA in --> NA out
r_string_from_parse_text <- function(s) {
  is.na(s) <- !nzchar(s)
  out <- as.character(parse(text = s, keep.source = FALSE))
  is.na(out) <- is.na(s)
  out
}

is_linter <- function(x) inherits(x, "linter")
is_lint <- function(x) inherits(x, "lint")

is_error <- function(x) inherits(x, "error")

is_tainted <- function(lines) {
  is_error(tryCatch(nchar(lines), error = identity))
}

#' Check that the entries in ... are valid
#'
#' @param dot_names Supplied names, from [...names()].
#' @param ref_calls Functions consuming these `...` (character).
#' @param ref_help Help page to refer users hitting an error to.
#' @noRd
check_dots <- function(dot_names, ref_calls, ref_help = as.character(sys.call(-1L)[[1L]])) {
  valid_args <- unlist(lapply(ref_calls, \(f) names(formals(f))))
  # TODO(#2502): needn't check is.na() after R 4.2.0
  is_valid <- is.na(dot_names) | !nzchar(dot_names) | dot_names %in% valid_args
  if (all(is_valid)) {
    return(invisible())
  }
  invalid_args <- dot_names[!is_valid] # nolint: object_usage_linter. TODO(#2252).
  cli_abort(c(
    x = "Found unknown arguments in `...`: {.arg {invalid_args}}.",
    i = "Check for typos and see ?{ref_help} for valid arguments."
  ))
}

cli_abort_internal <- function(...) {
  cli_abort(..., .internal = TRUE) # nocov
}
