# an internal environment to store objects
.env = new.env(parent = emptyenv())

one_string = function(x, collapse = '\n') paste(x, collapse = collapse)

# signal an error from one or more failure messages; when check = TRUE,
# print full details via message() if they would exceed warning.length
stop_errs = function(msgs, check = TRUE) {
  if (!(n <- length(msgs))) return(invisible())
  msgs = vapply(msgs, function(m) {
    if (starts_with(m, '-- ')) m else
      one_string(c('-- Error --', paste0('   ', strsplit(m, '\n')[[1]])))
  }, '', USE.NAMES = FALSE)
  full = one_string(msgs, '\n\n')
  if (!check || nchar(full, type = 'bytes') <= getOption('warning.length', 1000L))
    stop(full, call. = FALSE)
  message(full)
  stop(sprintf(
    '%d test%s failed (see details above)', n, if (n > 1) 's' else ''
  ), call. = FALSE)
}

# trigger %==% diagnostics and return the collected info (for testing)
equ_info = function(x, y) {
  .env$equ_info = NULL
  op = options(testit.asserting = TRUE); on.exit(options(op))
  x %==% y
  .env$equ_info
}

# base::startsWith() requires R >= 3.3
starts_with = function(x, prefix) substring(x, 1, nchar(prefix)) == prefix

norm_path = function(x, ...) normalizePath(x, '/', ...)

# check if a source package needs (re)installation by comparing source file
# mtimes against the installed package timestamp
pkg_needs_install = function(pkg_root, package) {
  pkg_root = norm_path(pkg_root)
  libs = .libPaths()
  libs = libs[norm_path(libs, mustWork = FALSE) != dirname(pkg_root)]
  # if the namespace is already loaded from outside .libPaths() (e.g., covr's
  # temp lib or load_all()), the caller set it up intentionally — skip reinstall
  if (isNamespaceLoaded(package)) {
    ns_path = norm_path(getNamespaceInfo(package, 'path'), mustWork = FALSE)
    if (!any(starts_with(ns_path, norm_path(libs, mustWork = FALSE)))) return(FALSE)
  }
  lib = find.package(package, lib.loc = libs, quiet = TRUE)
  if (!length(lib)) return(TRUE)
  installed_time = file.mtime(file.path(lib, 'Meta', 'package.rds'))
  if (is.na(installed_time)) return(TRUE)
  src_files = list.files(pkg_root, recursive = TRUE, full.names = TRUE)
  tests_dir = paste0(pkg_root, '/tests/')
  src_files = src_files[!starts_with(src_files, tests_dir)]
  if (!length(src_files)) return(TRUE)
  max(file.mtime(src_files), na.rm = TRUE) > installed_time
}

# get package name from DESCRIPTION file
pkg_name = function() {
  for (desc in c('DESCRIPTION', '../DESCRIPTION')) {
    if (file.exists(desc)) {
      d = read.dcf(desc, fields = 'Package')
      if (!is.na(d[1, 1])) return(d[1, 1])
    }
  }
  stop('Package name cannot be detected from DESCRIPTION.')
}

dir_exists = function(x) utils::file_test('-d', x)

# find an available dir
available_dir = function(dirs) {
  for (i in dirs) if (dir_exists(i)) return(i)
  stop('None of the directories exists:\n', one_string(utils::formatUL(dirs)))
}

# a compact way to display tempfile()
short_temp = function(x) paste0('tempdir()/', basename(x))

cleanup_msg = function(path) message(
  if (dir_exists(path)) 'Failed to clean' else 'Cleaned', ' up ', short_temp(path)
)

# tailored for assert(): extract the expression that is likely to be useful for
# diagnostics if possible
deparse_key = function(expr) {
  x = deparse(expr, width.cutoff = 100L)
  if ((n <- length(x)) <= 1) return(x)
  # if expression is in {}, fetch the line n-1, otherwise use the first line
  paste(x[1], '....', if (x[n] == '}') sub('^\\s*', '', x[n - 1L]))
}

deparse_one = function(expr) one_string(deparse(expr, 500L), '')

# whether every element of x is strictly TRUE
all_true = function(x) {
  is.logical(x) && length(x) && !any(is.na(x)) && all(x)
}

insert_identical = function() {
  insert = getFromNamespace('insertText', 'rstudioapi')
  insert(text = ' %==% ')
}

# A modification of base::sys.source that uses the package namespace as the
# top-level environment and collects all errors instead of stopping at the
# first. Returns a character vector of error messages (empty if no errors).
sys.source2 = function(file, envir, top.env = as.environment(envir)) {
  oop = options(keep.source = TRUE, topLevelEnvironment = top.env)
  on.exit(options(oop), add = TRUE)

  file = norm_path(file)
  lines = readLines(file, warn = FALSE, encoding = 'UTF-8')
  srcfile = srcfilecopy(file, lines, file.mtime(file), isFile = TRUE)
  exprs = parse(text = lines, srcfile = srcfile, encoding = 'UTF-8')

  if (length(exprs) == 0L) return()
  owd = setwd(dirname(file)); on.exit(setwd(owd), add = TRUE)
  errs = NULL
  for (i in seq_along(exprs)) tryCatch(
    loc_stop(eval(exprs[i], envir)),
    error = function(e) errs <<- c(errs, conditionMessage(e))
  )
  errs
}

# Clean output to remove unstable elements like bytecode addresses
clean_output = function(lines) {
  # Remove addresses like <bytecode: 0x...>, <environment: 0x...>, <pointer: 0x...>
  gsub('<(bytecode|environment|pointer): 0x[0-9a-f]+>', '<\\1: ...>', lines)
}

# get fence for code blocks based on content
get_fence = function(text, extra = FALSE) {
  ms = gregexpr('^`+', text, perl = TRUE)
  n = max(unlist(lapply(ms, attr, 'match.length')))
  if (extra && n >= 3) n = n + 1
  one_string(rep('`', max(n, 3)), '')
}

# Parse markdown file to extract code blocks
parse_snapshot = function(lines, file) {
  # Find all fence lines with optional R language labels ({r} or r)
  idx = grepl(r <- sprintf('^%s\\s*(\\{r\\}|r)?\\s*$', get_fence(lines)), lines)
  if (sum(idx) %% 2 != 0) stop('Unbalanced code fences in ', error_loc(file))
  # Change TRUE to FALSE for idx elements at even positions and their next
  # elements to TRUE to mark the start of the next block
  fences = which(idx)
  i = seq_len(length(fences)/2) * 2
  idx[fences[i]] = FALSE
  idx[fences[i] + 1] = TRUE
  # Split lines into code, output, and text blocks
  N = seq_along(lines)
  blocks = split(data.frame(lines, N, stringsAsFactors = FALSE), cumsum(idx[N]))
  lapply(blocks, function(b) {
    n = nrow(b)
    if (n < 2 || !grepl(r, b[1, 1])) list(type = 'text', content = b[, 1]) else {
      list(type = gsub('^```+|\\s+', '', b[1, 1]), content = b[-c(1, n), 1], line = b[1, 2])
    }
  })
}

# Execute snapshot tests from a markdown file containing R code blocks and
# expected output blocks. Returns error messages (if any) like sys.source2().
test_snap = function(f, env, update = NA) {
  raw_lines = readLines(f, warn = FALSE, encoding = 'UTF-8')
  blocks = parse_snapshot(raw_lines, f)
  new_blocks = list(); changed = FALSE
  pos = NULL  # record the first line of the first failed block for error reporting

  # Process blocks in pairs: R code block followed by output block
  N = length(blocks)
  for (i in seq_len(N)) {
    block = blocks[[i]]
    new_blocks[[length(new_blocks) + 1]] = block  # Add current block to new_blocks
    if (!block$type %in% c('{r}', 'r')) next

    out = capture_output(block$content, env, dirname(f), f, block$line)
    # look for the next output block k (stop at the next R code block)
    k = NULL
    if (i + 1 <= N) for (j in (i + 1):N) {
      if (blocks[[j]]$type %in% c('{r}', 'r')) break
      if (blocks[[j]]$type == '') { k = j; break }
    }
    if (is.null(k)) {
      # no output block, add one
      new_blocks[[length(new_blocks) + 1]] = list(type = '', content = out)
      changed = TRUE
    } else {
      expected_lines = blocks[[k]]$content
      if (identical(out, expected_lines)) next
      changed = TRUE
      if (!isTRUE(update) && is.null(pos)) pos = block$line
      blocks[[k]] = list(type = '', content = out)
    }
  }

  if (!changed) return()

  # Write updated markdown
  all_content = unlist(lapply(new_blocks, function(b) b$content))
  fence = get_fence(all_content, TRUE)
  out_lines = unlist(lapply(new_blocks, function(b) {
    if (b$type == 'text') b$content else {
      c(paste0(fence, b$type), b$content, fence)
    }
  }))
  if (isTRUE(update) || is.null(pos)) {
    write_utf8(out_lines, f)
    message('Updated snapshot file: ', f)
    return()
  }
  tracked = system2(
    'git', c('ls-files', '--error-unmatch', shQuote(f)), stdout = FALSE, stderr = FALSE
  ) == 0
  if (tracked && is.na(update)) {
    write_utf8(out_lines, f)
    d = system2('git', c('diff', '--color=auto', shQuote(f)), stdout = TRUE, stderr = FALSE)
    message(one_string(d))
  } else {
    message(one_string(mini_diff(raw_lines, out_lines)))
  }
  paste0(
    'Snapshot test failed', error_loc(f, pos), '\n',
    if (tracked) 'If the changes are not expected, revert them in GIT.' else
      'Call testit::test_pkg(update = TRUE) to update.'
  )
}

capture_output = function(code, envir, wd, file = NULL, line = NULL) {
  owd = setwd(wd); on.exit(setwd(owd), add = TRUE)
  err_i = NULL
  out = tryCatch(capture.output(quietly({
    exprs = if (length(code)) parse(text = code, keep.source = TRUE)
    for (i in seq_along(exprs)) {
      err_i = i
      res = withVisible(eval(exprs[[i]], envir = envir))
      if (res$visible) print(res$value)
    }
  })), error = function(e) {
    loc = if (!is.null(file) && !is.null(err_i)) {
      sr = attr(exprs, 'srcref')
      err_line = if (!is.null(sr[[err_i]])) line + sr[[err_i]][1]
      if (!is.null(err_line)) error_loc(file, err_line)
    }
    paste0('Error: ', conditionMessage(e), loc)
  })
  clean_output(out)
}

write_utf8 = function(text, con) {
  opts = options(encoding = "native.enc")
  on.exit(options(opts))
  writeLines(enc2utf8(text), con, useBytes = TRUE)
}

# Deparse two values with full precision, split on ", " for token-level diff
deparse_diff = function(x, y, max_diff = 50L) {
  dx = one_string(deparse(x, width.cutoff = 500L, control = 'all'), ' ')
  dy = one_string(deparse(y, width.cutoff = 500L, control = 'all'), ' ')
  if (identical(dx, dy)) return()
  tx = trimws(strsplit(dx, ', ')[[1]])
  ty = trimws(strsplit(dy, ', ')[[1]])
  mini_diff(tx, ty, max_diff)
}

# parse command-line args for test_pkg() defaults (--filter=PATTERN, --update)
parse_args = function(args = commandArgs(TRUE)) {
  filter = NULL
  update = NA
  for (a in args) {
    if (starts_with(a, '--filter=')) filter = sub('^--filter=', '', a)
    else if (a == '--update') update = TRUE
  }
  list(filter = filter, update = update)
}

# Output a minimal diff between two character vectors, showing only lines that
# are different and 3 lines of context around them. Lines starting with " " are
# unchanged, "-" are in x1 but not x2, "+" are in x2 but not x1. When max_diff
# is finite, bail out after that many diff lines are found (returns NULL).
mini_diff = function(x1, x2, max_diff = Inf) {
  out = character()
  n_diff = 0L
  i = 1; j = 1
  n1 = length(x1); n2 = length(x2)

  # 1. Alignment Loop
  while (i <= n1 || j <= n2) {
    if (i <= n1 && j <= n2 && x1[i] == x2[j]) {
      out = c(out, paste(" ", x1[i])); i = i + 1; j = j + 1
    } else {
      m_i = if (i <= n1 && j <= n2) match(x2[j], x1[i:n1]) else NA
      m_j = if (i <= n1 && j <= n2) match(x1[i], x2[j:n2]) else NA
      if (!is.na(m_i) && (is.na(m_j) || m_i <= m_j)) {
        out = c(out, paste("-", x1[i])); i = i + 1; n_diff = n_diff + 1L
      } else if (!is.na(m_j)) {
        out = c(out, paste("+", x2[j])); j = j + 1; n_diff = n_diff + 1L
      } else {
        if (i <= n1) { out = c(out, paste("-", x1[i])); i = i + 1; n_diff = n_diff + 1L }
        if (j <= n2) { out = c(out, paste("+", x2[j])); j = j + 1; n_diff = n_diff + 1L }
      }
      if (n_diff >= max_diff) break
    }
  }

  # 2. Context Filtering (Keep 3 lines around any change)
  if (length(out) > 0) {
    change_idx = grep("^[-+]", out)

    # Identify indices within 3 steps of a change
    keep_idx = unique(as.integer(outer(change_idx, -3:3, "+")))
    keep_idx = sort(keep_idx[keep_idx > 0 & keep_idx <= length(out)])

    # Build output with "..." where gaps occur
    lines = character()
    last_idx = 0
    for (idx in keep_idx) {
      if (idx > last_idx + 1) lines = c(lines, '  ...')
      lines = c(lines, out[idx])
      last_idx = idx
    }
    lines
  }
}
