# WID code grammar: <series_type:1><concept:5-6>[<age:3>][<pop:1>]

#' Validate WID code components
#' @param series_type One-letter series type code.
#' @param concept     5-6 letter concept code.
#' @param age         Three-digit age code.
#' @param pop         One-letter population unit code.
#' @param years       Integer vector of years.
#' @param areas       ISO-2 area codes.
#' @param perc        Percentile codes of the form \code{pXpY}.
#' @return Invisibly, a named list of normalised inputs with the same names as
#'   the parameters, with \code{age} zero-padded and \code{years} coerced to
#'   integer.
#' @examples
#' wid_validate(series_type = "s", concept = "ptinc", age = 992, pop = "j")
#' wid_validate(areas = c("US", "FR", "US-CA"))
#' @export
wid_validate <- function(series_type = NULL, concept = NULL, age = NULL,
                         pop = NULL, years = NULL, areas = NULL, perc = NULL) {
  if (!is.null(age)) {
    age <- formatC(suppressWarnings(as.integer(age)), width = 3L, flag = "0")
    if (anyNA(suppressWarnings(as.integer(age))))
      stop("'age' must be coercible to integer.", call. = FALSE)
  }
  for (ch in list(list(series_type, wid_series_types, "series_type"),
                  list(concept,     wid_concepts,     "concept"),
                  list(age,         wid_ages,         "age"),
                  list(pop,         wid_pop_types,    "pop"))) {
    val <- ch[[1L]]; tbl <- ch[[2L]]; label <- ch[[3L]]
    if (is.null(val)) next
    bad <- setdiff(val, tbl$code)
    if (length(bad))
      stop(sprintf("Unknown %s: %s", label, paste(bad, collapse = ", ")), call. = FALSE)
  }
  if (!is.null(years)) {
    years <- suppressWarnings(as.integer(years))
    if (anyNA(years)) stop("'years' must be integers.", call. = FALSE)
    if (any(years < 1800L | years > 2100L))
      warning("Some years outside [1800, 2100].", call. = FALSE)
  }
  if (!is.null(areas)) {
    bad <- areas[!grepl("^[A-Z]{2}(-[A-Z0-9]{1,5})?$", areas)]
    if (length(bad))
      warning(sprintf("Area codes may be invalid: %s", paste(bad, collapse = ", ")), call. = FALSE)
  }
  if (!is.null(perc)) {
    bad <- perc[!grepl("^p[0-9]+(\\.[0-9]+)?p[0-9]+(\\.[0-9]+)?$", perc)]
    if (length(bad))
      stop(sprintf("Invalid percentile format: %s", paste(bad, collapse = ", ")), call. = FALSE)
    bounds <- regmatches(perc, regexec("^p([0-9.]+)p([0-9.]+)$", perc))
    inv    <- vapply(bounds, function(m) as.numeric(m[2L]) >= as.numeric(m[3L]), logical(1L))
    if (any(inv))
      stop(sprintf("Lower >= upper in: %s", paste(perc[inv], collapse = ", ")), call. = FALSE)
  }
  invisible(list(series_type = series_type, concept = concept, age = age,
                 pop = pop, years = years, areas = areas, perc = perc))
}

#' Test WID code components without throwing
#' @param ... Arguments passed to \code{\link{wid_validate}}.
#' @return Scalar logical: \code{TRUE} if all supplied components are valid,
#'   \code{FALSE} if any would cause an error. Warning-level issues return
#'   \code{TRUE}.
#' @examples
#' wid_is_valid(series_type = "s", concept = "ptinc")  # TRUE
#' wid_is_valid(series_type = "Z")                      # FALSE
#' @export
wid_is_valid <- function(...) {
  tryCatch({ wid_validate(...); TRUE }, error = function(e) FALSE, warning = function(w) TRUE)
}

#' Parse a WID variable code into its components
#' @param x      Character string, e.g. \code{"sptinc992j"}.
#' @param strict \code{TRUE} (default) stops on error; \code{FALSE} warns and returns \code{NULL}.
#' @return Named list with elements \code{series_type} (character),
#'   \code{concept} (character), \code{age} (character or \code{NULL}),
#'   and \code{pop} (character or \code{NULL}).
#' @examples
#' wid_decode("sptinc992j")
#' wid_decode("mnninc")        # no age or pop
#' @export
wid_decode <- function(x, strict = TRUE) {
  x    <- trimws(as.character(x))
  .err <- function(...) {
    msg <- paste0(...)
    if (strict) stop(msg, call. = FALSE) else { warning(msg, call. = FALSE); return(NULL) }
  }
  st <- substr(x, 1L, 1L)
  if (!st %in% wid_series_types$code) return(.err("Unknown series_type: '", st, "'"))
  rest <- substr(x, 2L, nchar(x))
  if (nchar(rest) < 4L) return(.err("Unknown series_type or code too short: '", x, "'"))
  codes <- wid_concepts$code[order(-nchar(wid_concepts$code))]
  hit   <- codes[startsWith(rest, codes)][1L]
  if (is.na(hit)) return(.err("No known concept in: '", rest, "'"))
  rest <- substr(rest, nchar(hit) + 1L, nchar(rest))
  age  <- pop <- NULL
  if (nchar(rest) > 0L) {
    if (!grepl("^[0-9]{3}", rest))
      return(.err("Expected 3-digit age suffix, got: '", rest, "'"))
    age_c <- substr(rest, 1L, 3L)
    if (!age_c %in% wid_ages$code) return(.err("Unknown age: '", age_c, "'"))
    age  <- age_c
    rest <- substr(rest, 4L, nchar(rest))
  }
  if (nchar(rest) == 1L) {
    if (!rest %in% wid_pop_types$code) return(.err("Unknown pop: '", rest, "'"))
    pop <- rest
  } else if (nchar(rest) > 1L) {
    return(.err("Unexpected trailing characters: '", rest, "'"))
  }
  list(series_type = st, concept = hit, age = age, pop = pop)
}

#' Build a WID variable code from its components
#' @param series_type 1-letter series type, or a list from \code{\link{wid_decode}}.
#' @param concept     5-6 letter concept code.
#' @param age         3-digit age code or \code{NULL}.
#' @param pop         1-letter population code or \code{NULL}.
#' @return A character string of the form
#'   \code{<type><concept>[age][pop]}.
#' @examples
#' wid_encode("s", "ptinc", "992", "j")   # "sptinc992j"
#' wid_encode("m", "nninc")               # "mnninc"
#' wid_encode(wid_decode("sptinc992j"))   # round-trip
#' @export
wid_encode <- function(series_type, concept = NULL, age = NULL, pop = NULL) {
  if (is.list(series_type)) {
    x <- series_type
    return(paste0(x$series_type, x$concept, x$age %||% "", x$pop %||% ""))
  }
  wid_validate(series_type = series_type, concept = concept, age = age, pop = pop)
  paste0(series_type, concept, age %||% "", pop %||% "")
}

# Internal lookup source (mockable in tests)
.get_available_variables <- function() {
  pool <- list(
    concepts     = wid_concepts,     series_types = wid_series_types,
    ages         = wid_ages,         pop_types    = wid_pop_types,
    countries    = wid_countries,    percentiles  = wid_percentiles
  )
  do.call(rbind, lapply(names(pool), function(nm) {
    df <- pool[[nm]]
    data.frame(table = nm, variable = df$code, description = df$description,
               stringsAsFactors = FALSE)
  }))
}

#' Search WID lookup tables by regex
#' @param query  Regular expression.
#' @param tables Table names to search. Default \code{"concepts"}.
#' @param type   Optional series-type letter to filter results.
#' @return A \code{data.frame} with columns \code{table},
#'   \code{variable}, and \code{description} for each matching row,
#'   or an invisible empty \code{data.frame} if no matches are found.
#' @examples
#' wid_search("national income")
#' wid_search("wealth", type = "s")
#' wid_search("^US", tables = "countries")
#' @export
wid_search <- function(query, tables = "concepts", type = NULL) {
  all_tables <- c("concepts","series_types","ages","pop_types","countries","percentiles")
  if (!identical(tables, "all")) {
    bad <- setdiff(tables, all_tables)
    if (length(bad)) stop("Unknown table(s): ", paste(bad, collapse = ", "), call. = FALSE)
  }
  av  <- .get_available_variables()
  if (!identical(tables, "all")) av <- av[av$table %in% tables, ]
  idx <- grepl(query, av$variable, ignore.case = TRUE) |
    grepl(query, av$description, ignore.case = TRUE)
  out <- av[idx, ]
  if (!is.null(type)) out <- out[substr(out$variable, 1L, 1L) == type, ]
  rownames(out) <- NULL
  if (!nrow(out)) { message("No matches found."); return(invisible(out)) }
  out
}