# Rtinycc - TinyCC for R
# Copyright (C) 2025-2026 Sounkou Mahamane Toure
# SPDX-License-Identifier: GPL-3.0-or-later

# Callback Registration and Invocation
# Allow R functions to be passed as callbacks to compiled C code

#' Register an R function as a callback
#'
#' Wraps an R function so it can be passed as a C function pointer
#' to compiled code. The callback will be invoked via a trampoline
#' that marshals arguments between C and R.
#'
#' @details
#' Thread safety: callbacks are executed on the R main thread only. Invoking
#' a callback from a worker thread is unsupported and may crash R. The
#' \code{threadsafe} flag is currently informational only.
#'
#' If a callback raises an error, a warning is emitted and a type-appropriate
#' default value is returned.
#'
#' When binding callbacks with `tcc_bind()`, use a `callback:<signature>`
#' argument type so a synchronous trampoline is generated. The trampoline
#' expects a `void*` user-data pointer as its first argument; pass
#' `tcc_callback_ptr(cb)` as the user-data argument to the C API. For
#' thread-safe usage from worker threads, use `callback_async:<signature>`
#' which schedules the call on the main thread and returns a default value.
#'
#' Pointer arguments (e.g., \code{double*}, \code{int*}) are passed as
#' external pointers. Lengths must be supplied separately if needed.
#'
#' The return type may be any scalar type supported by the FFI mappings
#' (e.g., \code{i32}, \code{f64}, \code{bool}, \code{cstring}), or
#' \code{SEXP} to return an R object directly.
#'
#' Callback lifetime: callbacks are eventually released by finalizers and
#' package unload. Call `tcc_callback_close()` when you want deterministic
#' invalidation and earlier release of the preserved R function.
#'
#' @param fun An R function to be called from C
#' @param signature C function signature string (e.g., "double (*)(int, double)")
#' @param threadsafe Whether to enable thread-safe invocation (experimental)
#' @return A tcc_callback object (externalptr wrapper)
#' @export
tcc_callback <- function(fun, signature, threadsafe = FALSE) {
  if (!is.function(fun)) {
    stop("fun must be a function", call. = FALSE)
  }

  if (!is.character(signature) || length(signature) != 1) {
    stop("signature must be a single string", call. = FALSE)
  }

  # Parse signature to get return type and argument types
  sig <- parse_callback_signature(signature)

  # Register with C runtime
  callback_ext <- .Call(
    RC_register_callback,
    fun,
    sig$return_type,
    sig$arg_types,
    as.integer(threadsafe)
  )

  # Add metadata as attributes
  attr(callback_ext, "signature") <- sig
  attr(callback_ext, "threadsafe") <- threadsafe
  attr(callback_ext, "fun") <- fun
  class(callback_ext) <- c("tcc_callback", "externalptr")

  callback_ext
}

#' Close/unregister a callback
#'
#' Invalidates a callback immediately, releases the preserved R function
#' reference, and cleans up callback resources as early as possible.
#' This is recommended for deterministic lifetime management, but callbacks
#' are also eventually released by finalizers if you simply drop all references.
#'
#' @param callback A tcc_callback object returned by tcc_callback()
#' @return NULL (invisible)
#' @export
tcc_callback_close <- function(callback) {
  if (!inherits(callback, "tcc_callback")) {
    stop("Expected tcc_callback object", call. = FALSE)
  }

  .Call(RC_unregister_callback, callback)
  invisible(NULL)
}

#' Get the C-compatible function pointer
#'
#' Returns an external pointer that can be passed to compiled C code
#' as user data for trampolines. Keep this handle (and the original
#' `tcc_callback`) alive for as long as C may call back.
#' The pointer handle keeps the underlying token storage alive until it is
#' garbage collected. Closing the original callback still invalidates the
#' callback registry entry, so C must not continue invoking it after
#' `tcc_callback_close()`.
#'
#' Pointer arguments and return values are treated as external pointers.
#' Use \code{tcc_read_bytes()}, \code{tcc_read_u8()}, or \code{tcc_read_f64()}
#' to inspect pointed data when needed.
#'
#' @param callback A tcc_callback object
#' @return An external pointer (address of the callback token)
#' @export
tcc_callback_ptr <- function(callback) {
  if (!inherits(callback, "tcc_callback")) {
    stop("Expected tcc_callback object", call. = FALSE)
  }

  # Get the token address as external pointer
  .Call(RC_get_callback_ptr, callback)
}

#' Print tcc_callback object
#'
#' @param x A tcc_callback object
#' @param ... Ignored
#' @return The input `tcc_callback` object, invisibly. Called for its
#'   side effect of printing the callback signature, thread-safety flag,
#'   and validity status.
#' @export
print.tcc_callback <- function(x, ...) {
  sig <- attr(x, "signature")
  threadsafe <- attr(x, "threadsafe")

  cat("<tcc_callback>\n")
  cat("  Signature: ", format_signature(sig), "\n", sep = "")
  cat("  Thread-safe: ", if (threadsafe) "yes" else "no", "\n", sep = "")
  cat(
    "  Status: ",
    if (is_callback_valid(x)) "valid" else "invalid",
    "\n",
    sep = ""
  )
  invisible(x)
}

#' Check if callback is still valid
#'
#' @param callback A tcc_callback object
#' @return Logical indicating if callback can be invoked
#' @export
tcc_callback_valid <- function(callback) {
  if (!inherits(callback, "tcc_callback")) {
    return(FALSE)
  }
  is_callback_valid(callback)
}

# Internal function to check validity
is_callback_valid <- function(callback) {
  tryCatch(
    {
      .Call(RC_callback_is_valid, callback)
    },
    error = function(e) FALSE
  )
}

new_rtinycc_callback_signature <- function(
  return_type,
  arg_types,
  raw,
  mode = "sync"
) {
  structure(
    list(
      return_type = return_type,
      arg_types = arg_types,
      raw = raw,
      mode = mode
    ),
    class = c(
      paste0("rtinycc_callback_signature_", mode),
      "rtinycc_callback_signature"
    )
  )
}

is_rtinycc_callback_signature <- function(x) {
  inherits(x, "rtinycc_callback_signature")
}

# Parse a C function signature string
# Returns classed signature object with return_type and arg_types.
parse_callback_signature <- function(signature, mode = "sync") {
  # Remove whitespace
  sig <- gsub("\\s+", " ", trimws(signature))

  # Pattern: return_type (*)(arg1, arg2, ...)
  # or:      return_type (*name)(arg1, arg2, ...)
  # or:      return_type(arg1, arg2, ...)
  patterns <- c(
    "^(.*?)\\s*\\(\\*[^)]*\\)\\s*\\((.*)\\)$",
    "^(.*?)\\((.*)\\)$"
  )

  for (pat in patterns) {
    m <- regexec(pat, sig, perl = TRUE)
    if (m[[1]][1] != -1) {
      matches <- regmatches(sig, m)[[1]]
      return_type <- trimws(matches[2])
      args_str <- trimws(matches[3])

      # Parse argument types
      if (args_str == "" || args_str == "void") {
        arg_types <- character(0)
      } else {
        # Split by comma, handling function pointers and nested parens
        arg_types <- parse_arg_list(args_str)
      }

      return(new_rtinycc_callback_signature(
        return_type = return_type,
        arg_types = arg_types,
        raw = signature,
        mode = mode
      ))
    }
  }

  # If no pattern matched, try simple fallback
  stop("Unable to parse callback signature: ", signature, call. = FALSE)
}

# Parse a comma-separated argument list, handling nested structures
parse_arg_list <- function(args_str) {
  if (args_str == "" || args_str == "void") {
    return(character(0))
  }

  args <- character(0)
  depth_paren <- 0L
  depth_bracket <- 0L
  start <- 1L
  n <- nchar(args_str, type = "chars")

  for (i in seq_len(n)) {
    ch <- substr(args_str, i, i)
    if (ch == "," && depth_paren == 0L && depth_bracket == 0L) {
      args <- c(args, trimws(substr(args_str, start, i - 1L)))
      start <- i + 1L
      next
    }

    if (ch == "(") {
      depth_paren <- depth_paren + 1L
    } else if (ch == ")") {
      depth_paren <- max(0L, depth_paren - 1L)
    } else if (ch == "[") {
      depth_bracket <- depth_bracket + 1L
    } else if (ch == "]") {
      depth_bracket <- max(0L, depth_bracket - 1L)
    }
  }

  args <- c(args, trimws(substr(args_str, start, n)))
  args <- args[nzchar(args)]

  # Remove parameter names (keep only type)
  # e.g., "int x" -> "int", "double* ptr" -> "double*"
  result <- character(length(args))
  for (i in seq_along(args)) {
    arg <- args[i]

    # Handle function pointer types: void (*)(int)
    # Keep them as-is, they'll be treated as "callback" type
    if (grepl("\\(", arg)) {
      result[i] <- "callback"
    } else {
      result[i] <- strip_callback_arg_name(arg)
    }
  }

  result
}

strip_callback_arg_name <- function(arg) {
  arg <- trimws(gsub("\\s+", " ", arg))
  if (!nzchar(arg)) {
    return(arg)
  }

  # Pointer declarators often attach the parameter name directly to the last
  # asterisk, for example `const char *name` or `int **out`.
  ptr_match <- regexec(
    "^(.*?)(\\*+)\\s*([A-Za-z_][A-Za-z0-9_]*)$",
    arg,
    perl = TRUE
  )[[1]]
  if (ptr_match[[1]] != -1) {
    pieces <- regmatches(arg, list(ptr_match))[[1]]
    return(trimws(paste0(pieces[[2]], pieces[[3]])))
  }

  parts <- strsplit(arg, "\\s+")[[1]]
  if (
    length(parts) > 1 &&
      grepl("^[A-Za-z_][A-Za-z0-9_]*$", parts[[length(parts)]])
  ) {
    parts <- parts[-length(parts)]
  }

  trimws(paste(parts, collapse = " "))
}

# Format signature for display
format_signature <- function(sig) {
  if (is.null(sig)) {
    return("unknown")
  }

  args <- if (length(sig$arg_types) == 0) {
    "void"
  } else {
    paste(sig$arg_types, collapse = ", ")
  }
  paste0(sig$return_type, " (*)(", args, ")")
}

# ============================================================================
# FFI Integration - Allow callbacks in tcc_bind()
# ============================================================================

#' Check if a type represents a callback
#'
#' @param type Type string to check
#' @return Logical
is_callback_type <- function(type) {
  if (is_rtinycc_ffi_type(type)) {
    return(ffi_type_family(type) %in% c("callback", "callback_async"))
  }
  if (!is.character(type)) {
    return(FALSE)
  }
  type == "callback" ||
    startsWith(type, "callback:") ||
    startsWith(type, "callback_async:")
}

is_callback_async_type <- function(type) {
  if (is_rtinycc_ffi_type(type)) {
    return(identical(ffi_type_family(type), "callback_async"))
  }
  if (!is.character(type)) {
    return(FALSE)
  }
  startsWith(type, "callback_async:")
}

#' Parse callback type specification
#'
#' @param type Type string like "callback:double(int,int)"
#' @return Parsed signature list or NULL
parse_callback_type <- function(type) {
  if (is_rtinycc_ffi_type(type)) {
    type <- type$name
  }

  if (type == "callback") {
    # Generic callback without signature - will need runtime determination
    return(NULL)
  }

  if (startsWith(type, "callback:")) {
    # Extract signature after "callback:"
    sig_str <- sub("^callback:", "", type)
    return(parse_callback_signature(sig_str, mode = "sync"))
  }

  if (startsWith(type, "callback_async:")) {
    sig_str <- sub("^callback_async:", "", type)
    return(parse_callback_signature(sig_str, mode = "async"))
  }

  NULL
}

#' Schedule a callback to run on the main thread
#'
#' Enqueue a callback for main-thread execution. Arguments must be basic
#' scalars or external pointers.
#'
#' @param callback A tcc_callback object
#' @param args List of arguments to pass to the callback
#' @return NULL (invisible)
#' @export
tcc_callback_async_schedule <- function(callback, args = list()) {
  if (!inherits(callback, "tcc_callback")) {
    stop("Expected tcc_callback object", call. = FALSE)
  }
  if (!is.list(args)) {
    stop("args must be a list", call. = FALSE)
  }
  .Call(RC_callback_async_schedule, callback, args)
  invisible(NULL)
}

#' Drain the async callback queue
#'
#' Execute any pending async callbacks immediately on the main R thread.
#' Normally callbacks fire automatically via R's event loop (input
#' handler on POSIX, message pump on Windows), so explicit draining is
#' only needed in test harnesses or tight batch loops that never yield
#' to R's event loop.
#'
#' TCC-compiled C code running on the main thread can call
#' \code{RC_callback_async_drain_c()} directly instead of returning to R.
#'
#' @return NULL (invisible)
#' @export
tcc_callback_async_drain <- function() {
  .Call(RC_callback_async_drain)
  invisible(NULL)
}

#' Generate trampoline code for a callback argument
#'
#' @param trampoline_name Name of the trampoline function
#' @param sig Parsed signature
#' @return C code string for the trampoline
generate_trampoline <- function(trampoline_name, sig) {
  # Generate a trampoline function that:
  # 1. Takes a user data pointer + C arguments
  # 2. Calls RC_invoke_callback_id() to invoke the R function
  # 3. Returns the result

  n_args <- length(sig$arg_types)

  # Build argument list for C function signature
  c_args <- c("void* cb")
  if (n_args > 0) {
    for (i in seq_len(n_args)) {
      c_args <- c(
        c_args,
        sprintf("%s arg%d", callback_c_decl_type(sig$arg_types[i]), i)
      )
    }
  }

  # Build the trampoline
  lines <- c(
    sprintf("// Trampoline %s", trampoline_name),
    sprintf(
      "%s %s(%s) {",
      callback_c_decl_type(sig$return_type),
      trampoline_name,
      if (length(c_args) > 0) paste(c_args, collapse = ", ") else "void"
    ),
    "  callback_token_t* tok = (callback_token_t*)cb;",
    "  if (!tok || tok->id < 0) {",
    sprintf(
      "    Rf_warning(\"Invalid callback token in %s\");",
      trampoline_name
    ),
    get_c_default_return(sig$return_type, indent = 4L),
    "  }"
  )

  # Build argument conversion
  if (n_args > 0) {
    lines <- c(
      lines,
      sprintf("  SEXP args = PROTECT(allocVector(VECSXP, %d));", n_args)
    )
    for (i in seq_len(n_args)) {
      lines <- c(
        lines,
        sprintf(
          "  SET_VECTOR_ELT(args, %d, %s);",
          i - 1,
          get_sexp_constructor_call(sig$arg_types[i], paste0("arg", i))
        )
      )
    }
  } else {
    lines <- c(lines, "  SEXP args = R_NilValue;")
  }

  # Call the runtime
  lines <- c(lines, "  SEXP result = RC_invoke_callback_id(tok->id, args);")

  if (n_args > 0) {
    lines <- c(lines, "  UNPROTECT(1);")
  }

  # Convert result back to C type
  lines <- c(
    lines,
    get_r_to_c_return_lines(sig$return_type, "result", indent = 2L)
  )

  lines <- c(lines, "}")

  paste(lines, collapse = "\n")
}

# Generate async trampoline that schedules callbacks on the main thread.
#
# void return    -> fire-and-forget via RC_callback_async_schedule_c
#                   (PostMessage on Windows, write-to-pipe on Linux).
#                   Auto-drains through R's input handler / message pump.
# non-void return -> synchronous via RC_callback_async_schedule_sync_c
#                   (SendMessage on Windows, pthread_cond on Linux).
#                   Blocks the worker thread until the main thread
#                   services the callback.  C code on the main thread
#                   can call RC_callback_async_drain_c() in a loop
#                   rather than returning to R.
generate_async_trampoline <- function(trampoline_name, sig) {
  unsupported <- vapply(sig$arg_types, async_type_unsupported, logical(1))
  if (any(unsupported)) {
    bad <- unique(trimws(sig$arg_types[unsupported]))
    stop(
      "callback_async unsupported argument type(s): ",
      paste(bad, collapse = ", "),
      call. = FALSE
    )
  }

  is_void_return <- identical(sig$return_type, "void")

  if (!is_void_return) {
    ret_kind <- async_result_kind(sig$return_type)
    if (is.null(ret_kind)) {
      stop(
        "callback_async unsupported return type: ",
        sig$return_type,
        " (supported: void, int variants, double/float, bool/logical, ptr)",
        call. = FALSE
      )
    }
  }

  n_args <- length(sig$arg_types)

  c_args <- c("void* cb")
  if (n_args > 0) {
    for (i in seq_len(n_args)) {
      c_args <- c(
        c_args,
        sprintf("%s arg%d", callback_c_decl_type(sig$arg_types[i]), i)
      )
    }
  }

  lines <- c(
    sprintf("// Async trampoline %s", trampoline_name),
    sprintf(
      "%s %s(%s) {",
      callback_c_decl_type(sig$return_type),
      trampoline_name,
      if (length(c_args) > 0) paste(c_args, collapse = ", ") else "void"
    ),
    "  callback_token_t* tok = (callback_token_t*)cb;",
    "  if (!tok || tok->id < 0) {",
    sprintf(
      "    Rf_warning(\"Invalid callback token in %s\");",
      trampoline_name
    ),
    get_c_default_return(sig$return_type, indent = 4L),
    "  }"
  )

  if (n_args > 0) {
    lines <- c(lines, sprintf("  cb_arg_t args[%d];", n_args))
    for (i in seq_len(n_args)) {
      lines <- c(lines, generate_cb_arg_assignment(i, sig$arg_types[i]))
    }
  } else {
    lines <- c(lines, "  cb_arg_t* args = NULL;")
  }

  if (is_void_return) {
    lines <- c(
      lines,
      sprintf(
        "  int rc = RC_callback_async_schedule_c(tok->id, %d, %s);",
        n_args,
        if (n_args > 0) "args" else "NULL"
      ),
      "  if (rc != 0) {",
      sprintf(
        "    Rf_warning(\"Async schedule failed (rc=%%d) in %s\", rc);",
        trampoline_name
      ),
      "  }",
      "  return;"
    )
  } else {
    lines <- c(
      lines,
      "  cb_result_t result;",
      sprintf(
        "  int rc = RC_callback_async_schedule_sync_c(tok->id, %d, %s, &result);",
        n_args,
        if (n_args > 0) "args" else "NULL"
      ),
      "  if (rc != 0) {",
      sprintf(
        "    Rf_warning(\"Async schedule failed (rc=%%d) in %s\", rc);",
        trampoline_name
      ),
      get_c_default_return(sig$return_type, indent = 4L),
      "  }",
      get_async_result_return(sig$return_type)
    )
  }

  lines <- c(lines, "}")

  paste(lines, collapse = "\n")
}

# Determine the CB_RESULT_* kind that a C return type maps to.
# Returns NULL if the type cannot be returned from an async sync callback.
async_result_kind <- function(return_type) {
  rt <- trimws(return_type)
  if (
    rt %in%
      c(
        "int",
        "i32",
        "int32_t",
        "i16",
        "int16_t",
        "i8",
        "int8_t",
        "u8",
        "uint8_t",
        "u16",
        "uint16_t"
      )
  ) {
    return("int")
  }
  if (
    rt %in%
      c(
        "double",
        "f64",
        "float",
        "f32",
        "i64",
        "int64_t",
        "u32",
        "uint32_t",
        "u64",
        "uint64_t"
      )
  ) {
    return("real")
  }
  if (rt %in% c("bool", "logical")) {
    return("logical")
  }
  if (is_ptr_type(rt)) {
    return("ptr")
  }
  NULL
}

# Generate the C return statement that extracts a value from cb_result_t.
get_async_result_return <- function(return_type) {
  kind <- async_result_kind(return_type)
  rt <- callback_c_decl_type(return_type)
  switch(
    kind,
    "int" = sprintf("  return (%s)result.v.i;", rt),
    "real" = sprintf("  return (%s)result.v.d;", rt),
    "logical" = sprintf("  return (%s)result.v.i;", rt),
    "ptr" = sprintf("  return (%s)result.v.p;", rt),
    stop(
      "BUG: unhandled async result kind for return type: ",
      return_type,
      call. = FALSE
    )
  )
}

async_type_unsupported <- function(c_type) {
  key <- normalize_cb_kind_key(c_type)
  if (key %in% c("ptr", "cstring", "real", "logical")) {
    return(FALSE)
  }
  if (!identical(key, "int")) {
    return(TRUE)
  }
  type_name <- trimws(c_type)
  !type_name %in%
    c(
      "int",
      "int32_t",
      "i32",
      "int16_t",
      "i16",
      "int8_t",
      "i8",
      "uint8_t",
      "u8",
      "uint16_t",
      "u16"
    )
}

generate_cb_arg_assignment <- function(index, c_type) {
  kind <- map_c_to_cb_arg_kind(c_type)
  value <- map_c_to_cb_arg_value(c_type, paste0("arg", index))
  c(
    sprintf("  args[%d].kind = %s;", index - 1, kind),
    sprintf("  args[%d].v.%s = %s;", index - 1, value$field, value$expr)
  )
}

is_ptr_type <- function(c_type) {
  c_type <- trimws(c_type)
  grepl("\\*", c_type) && !is_cstring_type(c_type)
}

is_cstring_type <- function(c_type) {
  c_type <- trimws(c_type)
  grepl("^const\\s+char\\s*\\*$", c_type) || grepl("^char\\s*\\*$", c_type)
}

normalize_cb_kind_key <- function(c_type) {
  cb_kind_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}

normalize_sexp_type_key <- function(c_type) {
  sexp_type_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}

normalize_r_type_key <- function(c_type) {
  c_r_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}

normalize_sexp_ctor_key <- function(c_type) {
  sexp_ctor_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}

normalize_r_to_c_key <- function(c_type) {
  r_to_c_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}

normalize_default_key <- function(c_type) {
  default_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}

normalize_return_key <- function(c_type) {
  return_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}

# Normalize callback signature spellings into concrete C declaration types.
# This keeps trampoline ABI faithful to the declared callback type while still
# accepting internal alias forms like i8/f32/sexp in callback signatures.
callback_c_decl_type <- function(c_type) {
  type_name <- trimws(gsub("\\s+", " ", c_type))
  if (!nzchar(type_name)) {
    return(type_name)
  }

  alias_map <- c(
    callback = "void*",
    ptr = "void*",
    cstring = "const char*",
    string = "const char*",
    sexp = "SEXP",
    logical = "bool",
    i8 = "int8_t",
    i16 = "int16_t",
    i32 = "int32_t",
    i64 = "int64_t",
    u8 = "uint8_t",
    u16 = "uint16_t",
    u32 = "uint32_t",
    u64 = "uint64_t",
    f32 = "float",
    f64 = "double"
  )

  if (type_name %in% names(alias_map)) {
    mapped <- unname(alias_map[[type_name]])
    return(mapped)
  }

  type_name
}

map_c_to_cb_arg_kind <- function(c_type) {
  cb_arg_kind_rule(normalize_cb_kind_key(c_type))
}

map_c_to_cb_arg_value <- function(c_type, arg_expr) {
  cb_arg_value_rule(normalize_cb_kind_key(c_type), arg_expr)
}

# Get default C return statement for a type
get_c_default_return <- function(c_type, indent = 2L) {
  c_default_return_rule(normalize_default_key(c_type), indent)
}

# Map C types to R SEXP types for trampoline arguments
map_c_to_sexp_type <- function(c_type) {
  c_sexp_type_rule(normalize_sexp_type_key(c_type))
}

# Map C types to FFI types
map_c_to_r_type <- function(c_type) {
  c_r_type_rule(normalize_r_type_key(c_type))
}

# Get SEXP constructor for C type
get_sexp_constructor <- function(c_type) {
  sexp_constructor_rule(normalize_sexp_ctor_key(c_type))
}

# Get SEXP constructor call for a C expression
get_sexp_constructor_call <- function(c_type, arg_expr) {
  sexp_constructor_call_rule(normalize_sexp_ctor_key(c_type), arg_expr)
}

# Get R to C converter function
get_r_to_c_converter <- function(c_type) {
  r_to_c_converter_rule(normalize_r_to_c_key(c_type))
}

get_r_to_c_return_lines <- function(c_type, result_var, indent = 2L) {
  r_to_c_return_lines_rule(
    normalize_return_key(c_type),
    c_type,
    result_var,
    indent
  )
}
