#' @title Generates wrappers for registered C++ functions
#'
#' @description Functions decorated with `[[cpp4r::register]]` in files ending in `.cc`,
#' `.cpp`, `.h` or `.hpp` will be wrapped in generated code and registered to
#' be called from R.
#'
#' Note registered functions will not be *exported* from your package unless
#' you also add a `@export` roxygen2 directive for them.
#'
#' @param path The path to the package root directory. The default is `NULL`,
#' @param quiet If `TRUE` suppresses output from this function
#' @param extension The file extension to use for the generated src/cpp4r file.
#'   `.cpp` by default, but `.cc` is also supported.
#' @return The paths to the generated R and C++ source files (in that order).
#' @export
#' @examples
#' # create a minimal package
#' dir <- tempfile()
#' dir.create(dir)
#'
#' writeLines("Package: testPkg", file.path(dir, "DESCRIPTION"))
#' writeLines("useDynLib(testPkg, .registration = TRUE)", file.path(dir, "NAMESPACE"))
#'
#' # create a C++ file with a decorated function
#' dir.create(file.path(dir, "src"))
#' writeLines("[[cpp4r::register]] int one() { return 1; }", file.path(dir, "src", "one.cpp"))
#'
#' # register the functions in the package
#' register(dir)
#'
#' # Files generated by registration
#' file.exists(file.path(dir, "R", "cpp4r.R"))
#' file.exists(file.path(dir, "src", "cpp4r.cpp"))
#'
#' # cleanup
#' unlink(dir, recursive = TRUE)
register <- function(path = NULL, quiet = !is_interactive(), extension = c(".cpp", ".cc")) {
  stopifnot(!is.null(path), dir.exists(path))

  extension <- match.arg(extension)

  r_path <- file.path(path, "R", "cpp4r.R")
  cpp_path <- file.path(path, "src", paste0("cpp4r", extension))
  unlink(c(r_path, cpp_path))

  suppressWarnings(
    all_decorations <- cpp_decorations(path, is_attribute = TRUE)
  )

  if (length(all_decorations$file) == 0) {
    return(invisible(character()))
  }

  check_valid_attributes(all_decorations)

  funs <- get_registered_functions(all_decorations, "cpp4r::register", quiet)

  description_lines <- readLines(file.path(path, "DESCRIPTION"))
  package_line <- grep("^Package:", description_lines, value = TRUE)[1]
  package <- sub("^Package:\\s*", "", package_line)
  package <- trimws(package)
  package <- sub("[.]", "_", package)

  cpp_functions_definitions <- generate_cpp_functions(funs, package)

  init <- generate_init_functions(get_registered_functions(all_decorations, "cpp4r::init", quiet))

  r_functions <- generate_r_functions(funs, package, use_package = FALSE)

  dir.create(dirname(r_path), recursive = TRUE, showWarnings = FALSE)

  writeLines(text = paste0("# Generated by cpp4r: do not edit by hand\n\n", r_functions), con = r_path)
  if (!quiet) {
    message(" Generated file '", basename(r_path), "'")
  }

  fun_guards <- stats::setNames(
    mapply(get_preprocessor_guard, funs$file, funs$line, SIMPLIFY = FALSE),
    funs$name
  )

  call_entries <- get_call_entries(path, funs, package, fun_guards)

  extra_includes <- character()

  pkg_types <- c(
    file.path(path, "src", paste0(package, "_types.h")),
    file.path(path, "src", paste0(package, "_types.hpp")),
    file.path(path, "inst", "include", paste0(package, "_types.h")),
    file.path(path, "inst", "include", paste0(package, "_types.hpp"))
  )

  pkg_types_exist <- file.exists(pkg_types)
  if (any(pkg_types_exist)) {
    extra_includes <- c(
      sprintf('#include "%s"', basename(pkg_types[pkg_types_exist])),
      extra_includes
    )
  }

  extra_includes <- paste0(extra_includes, collapse = "\n")

  src_files <- list.files(file.path(path, "src"),
    pattern = "\\.(cpp|cc|h|hpp)$",
    full.names = TRUE
  )

  writeLines(text = paste0(
    "// Generated by cpp4r: do not edit by hand\n",
    "// clang-format off\n\n",
    extra_includes, "\n",
    '#include "cpp4r/declarations.hpp"\n',
    "#include <R_ext/Visibility.h>\n\n",
    cpp_functions_definitions, "\n\n",
    'extern "C" {\n',
    paste(call_entries, collapse = "\n"), "\n",
    "}\n",
    init$declarations,
    'extern "C" attribute_visible void R_init_', package, "(DllInfo* dll){\n",
    "  R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);\n",
    "  R_useDynamicSymbols(dll, FALSE);", init$calls, "\n",
    "  R_forceSymbols(dll, TRUE);\n",
    "}"
  ), con = cpp_path)

  if (!quiet) {
    message(" Generated file '", basename(cpp_path), "'")
  }

  invisible(c(r_path, cpp_path))
}

utils::globalVariables(c("name", "cpp_name", "return_type", "line", "decoration", "context", ".", "functions", "res"))

empty_registered <- function() {
  list(
    file = character(),
    line = integer(),
    decoration = character(),
    namespace = character(),
    params = list(),
    context = list(),
    name = character(),
    cpp_name = character(),
    return_type = character(),
    args = list()
  )
}

get_registered_functions <- function(decorations, tag, quiet = !is_interactive()) {
  if (length(decorations$file) == 0) {
    return(empty_registered())
  }

  idx <- decorations$decoration == tag
  out <- lapply(decorations, `[`, idx)
  if (length(out$file) == 0) {
    return(empty_registered())
  }

  parsed <- lapply(out$context, parse_cpp_function, is_attribute = TRUE)

  parsed_name <- vcapply(parsed, function(x) if (length(x$name)) x$name else NA_character_)
  parsed_ret <- vcapply(parsed, function(x) if (length(x$name)) x$return_type else NA_character_)
  parsed_args <- lapply(parsed, function(x) if (length(x$name)) x$args else empty_args())
  # `cpp_name` is the fully-qualified C++ name used in declarations and calls;
  # `name` is the trailing identifier used for R-side names and C symbols.
  cpp_name <- ifelse(
    nzchar(out$namespace) & !is.na(parsed_name),
    paste0(out$namespace, "::", parsed_name),
    parsed_name
  )
  simple_name <- sub(".*::", "", parsed_name)

  out$name <- simple_name
  out$cpp_name <- cpp_name
  out$return_type <- parsed_ret
  out$args <- parsed_args
  out$decoration <- sub("::[[:alpha:]]+", "", out$decoration)

  n <- length(out$file)

  if (!quiet && n > 0) {
    message("i ", n, " functions decorated with [[", tag, "]]")
  }

  out
}

generate_cpp_functions <- function(funs, package = "cpp4r") {
  cols <- c("name", "cpp_name", "return_type", "args", "file", "line", "decoration")
  if (!"cpp_name" %in% names(funs)) {
    funs$cpp_name <- funs$name
  }
  funs <- funs[cols]

  funs$real_params <- vcapply(funs$args, collapse_data, "{type} {name}")
  funs$sexp_params <- vcapply(funs$args, collapse_data, "SEXP {name}")
  funs$calls <- mapply(wrap_call, funs$cpp_name, funs$return_type, funs$args, SIMPLIFY = TRUE)

  out <- mapply(function(file, return_type, cpp_name, real_params, name, sexp_params, calls) {
    paste0(
      "// ", basename(file), "\n",
      return_type, " ", cpp_name, "(", real_params, ");\n",
      'extern "C" SEXP _', package, "_", name, "(", sexp_params, ") {\n",
      "  BEGIN_CPP4R\n",
      "  ", calls, "\n",
      "  END_CPP4R\n",
      "}"
    )
  }, funs$file, funs$return_type, funs$cpp_name, funs$real_params, funs$name, funs$sexp_params, funs$calls, SIMPLIFY = TRUE)

  guards <- mapply(get_preprocessor_guard, funs$file, funs$line, SIMPLIFY = FALSE)
  out <- mapply(function(code, guard) {
    if (!is.null(guard)) paste0(guard, "\n", code, "\n#endif") else as.character(code)
  }, out, guards, SIMPLIFY = TRUE)

  out <- paste(out, collapse = "\n")
  out
}

generate_init_functions <- function(funs) {
  if (length(funs$name) == 0) {
    return(list(declarations = "", calls = ""))
  }

  if (!"cpp_name" %in% names(funs)) {
    funs$cpp_name <- funs$name
  }
  funs <- funs[c("name", "cpp_name", "return_type", "args", "file", "line", "decoration")]
  funs$declaration_params <- vcapply(funs$args, collapse_data, "{type} {name}")
  funs$call_params <- vcapply(funs$args, `[[`, "name")

  declarations <- paste0(funs$return_type, " ", funs$cpp_name, "(", funs$declaration_params, ");")
  declarations <- paste0("\n", paste(declarations, collapse = "\n"), "\n")

  calls <- paste0("  ", funs$cpp_name, "(", funs$call_params, ");")
  calls <- paste0("\n", paste(calls, collapse = "\n"))

  list(
    declarations = declarations,
    calls = calls
  )
}

generate_r_functions <- function(funs, package = "cpp4r", use_package = FALSE) {
  funs <- funs[c("name", "return_type", "args", "file", "line", "decoration")]

  if (use_package) {
    package_call <- paste0(', PACKAGE = "', package, '"')
    package_names <- paste0('"_', package, "_", funs$name, '"')
  } else {
    package_names <- paste0("`_", package, "_", funs$name, "`")
    package_call <- ""
  }

  funs$package_call <- package_call

  # Extract default values and create parameter lists
  funs$param_info <- lapply(funs$args, function(args_df) {
    if (length(args_df$name) == 0) {
      return(list(params = "", args = "", checks = ""))
    }

    # Parse default values from the type column (they appear after '=')
    param_names <- args_df$name
    param_types <- args_df$type

    # Extract defaults (format: "type name = value" becomes "value")
    defaults <- vapply(param_types, function(t) {
      if (grepl("=", t)) {
        sub(".*=\\s*", "", t)
      } else {
        ""
      }
    }, character(1))

    # Clean up types (remove default value parts)
    clean_types <- vapply(param_types, function(t) {
      trimws(sub("\\s*=.*$", "", t))
    }, character(1))

    # Generate R function parameters with defaults
    params_with_defaults <- vapply(seq_along(param_names), function(i) {
      if (nzchar(defaults[i])) {
        # Convert C++ defaults to R defaults
        r_default <- convert_cpp_default_to_r(defaults[i])
        paste0(param_names[i], " = ", r_default)
      } else {
        param_names[i]
      }
    }, character(1))

    # Generate type checking/coercion code
    checks <- vapply(seq_along(param_names), function(i) {
      generate_type_check(param_names[i], clean_types[i])
    }, character(1))
    checks <- checks[nzchar(checks)]

    list(
      params = paste(params_with_defaults, collapse = ", "),
      args = paste(param_names, collapse = ", "),
      checks = if (length(checks) > 0) paste0("\t", checks, collapse = "\n") else ""
    )
  })

  funs$list_params <- vapply(funs$param_info, function(x) x$params, character(1))
  funs$call_args <- vapply(funs$param_info, function(x) x$args, character(1))
  funs$type_checks <- vapply(funs$param_info, function(x) x$checks, character(1))

  funs$params <- vcapply(funs$call_args, function(x) if (nzchar(x)) paste0(", ", x) else x)
  is_void <- funs$return_type == "void"
  funs$calls <- ifelse(is_void,
    paste0("invisible(.Call(", package_names, funs$params, package_call, "))"),
    paste0(".Call(", package_names, funs$params, package_call, ")")
  )

  # Parse and associate Roxygen comments
  funs$roxygen_comment <- mapply(function(file, line) {
    if (file.exists(file)) {
      comments <- extract_roxygen_comments(file)
      matched_comment <- ""
      for (comment in comments) {
        # Check if the comment directly precedes the function without gaps
        if (line == comment$line + 1) {
          matched_comment <- comment$text
          break
        }
      }
      matched_comment
    } else {
      ""
    }
  }, funs$file, funs$line, SIMPLIFY = TRUE)

  # Generate R functions with type checks and defaults
  out <- mapply(function(name, list_params, calls, roxygen_comment, type_checks) {
    body <- if (nzchar(type_checks)) {
      paste0("\n", type_checks, "\n\t", calls, "\n")
    } else {
      paste0("\n\t", calls, "\n")
    }

    if (nzchar(roxygen_comment)) {
      paste0(roxygen_comment, "\n", name, " <- function(", list_params, ") {", body, "}")
    } else {
      paste0(name, " <- function(", list_params, ") {", body, "}")
    }
  }, funs$name, funs$list_params, funs$calls, funs$roxygen_comment, funs$type_checks, SIMPLIFY = TRUE)

  out <- trimws(out)
  out <- paste(out, collapse = "\n\n")
  out
}

# Helper function to convert C++ default values to R
convert_cpp_default_to_r <- function(cpp_default) {
  cpp_default <- trimws(cpp_default)

  # Handle common cases
  if (cpp_default == "true" || cpp_default == "TRUE") {
    return("TRUE")
  } else if (cpp_default == "false" || cpp_default == "FALSE") {
    return("FALSE")
  } else if (grepl("^[0-9]+L?$", cpp_default)) {
    # Integer literal
    return(paste0(sub("L$", "", cpp_default), "L"))
  } else if (grepl("^[0-9.]+[fF]?$", cpp_default)) {
    # Float/double literal
    return(sub("[fF]$", "", cpp_default))
  } else if (grepl('^".*"$', cpp_default) || grepl("^'.*'$", cpp_default)) {
    # String literal - keep as is
    return(cpp_default)
  } else if (cpp_default == "NULL" || cpp_default == "nullptr") {
    return("NULL")
  }

  # Default: keep as-is and hope for the best
  cpp_default
}

# Helper function to generate type checking/coercion code
generate_type_check <- function(param_name, param_type) {
  # No type checking or coercion - match cpp11's approach
  # The C++ side handles all type validation and conversion
  return("")
}

extract_roxygen_comments <- function(file) {
  lines <- readLines(file)

  # Look for roxygen comments that start with /* roxygen
  roxygen_start <- grep("^/\\* roxygen\\s*$", lines)

  if (length(roxygen_start) == 0) {
    return(list())
  }

  roxygen_comments <- lapply(roxygen_start, function(start) {
    # Find the end of the comment block (line ending with */)
    end_line <- start + 1
    while (end_line <= length(lines) && !grepl("\\*/$", lines[end_line])) {
      end_line <- end_line + 1
    }

    # If we didn't find an end, skip this comment
    if (end_line > length(lines)) {
      return(NULL)
    }

    # Extract the roxygen content (excluding the start and end lines)
    roxygen_lines <- lines[(start + 1):(end_line - 1)]

    # Convert to R roxygen format by adding #' prefix
    roxygen_lines <- sub("^", "#' ", roxygen_lines)

    list(line = end_line, text = paste(roxygen_lines, collapse = "\n"))
  })

  # Remove NULL entries
  roxygen_comments[!vapply(roxygen_comments, is.null, logical(1))]
}

wrap_call <- function(name, return_type, args) {
  list_params <- collapse_data(args, "cpp4r::as_cpp<cpp4r::decay_t<{type}>>({name})")
  call <- paste0(name, "(", list_params, ")")
  if (return_type == "void") {
    paste0("  ", call, ";\n    return R_NilValue;")
  } else {
    paste0("  return cpp4r::as_sexp(", call, ");")
  }
}

get_preprocessor_guard <- function(file, line) {
  if (!file.exists(file)) {
    return(NULL)
  }
  lines <- readLines(file, warn = FALSE)
  if (line > length(lines)) {
    return(NULL)
  }

  depth <- 0
  for (i in rev(seq_len(line - 1))) {
    l <- trimws(lines[i])
    if (grepl("^#\\s*endif\\b", l)) {
      depth <- depth + 1
    } else if (grepl("^#\\s*(ifndef|ifdef|if)\\b", l)) {
      if (depth == 0) {
        return(l)
      }
      depth <- depth - 1
    }
  }

  NULL
}

get_call_entries <- function(path, funs, package, fun_guards = list()) {
  n_args <- viapply(funs$args, function(x) length(x$name))

  entries <- as.character(mapply(function(nm, n) {
    s <- paste0("_", package, "_", nm)
    line <- sprintf('    {"%s", (DL_FUNC) &%s, %d},', s, s, n)
    guard <- fun_guards[[nm]]
    if (!is.null(guard)) paste0(guard, "\n", line, "\n#endif") else line
  }, funs$name, n_args, SIMPLIFY = TRUE, USE.NAMES = FALSE))

  c(
    "static const R_CallMethodDef CallEntries[] = {",
    entries,
    "    {NULL, NULL, 0}",
    "};"
  )
}

check_valid_attributes <- function(decorations, file = decorations$file) {
  bad_decor <- startsWith(decorations$decoration, "cpp4r::") &
    (!decorations$decoration %in% c("cpp4r::register", "cpp4r::init", "cpp4r::linking_to"))

  if (any(bad_decor)) {
    lines <- decorations$line[bad_decor]
    names <- decorations$decoration[bad_decor]
    bad_lines <- paste(
      sprintf("- Invalid attribute `%s` on\n                 line %d in file '%s'.", names, lines, file),
      collapse = "\n"
    )

    msg <- paste0(
      "cpp4r attributes must be one of `cpp4r::register`, `cpp4r::init` or `cpp4r::linking_to`:\n      ",
      bad_lines,
      "\n      "
    )
    stop(msg, call. = FALSE)
  }
}
