R/register.R

In cpp4r: Header-Only 'C++' and 'R' Interface

#' @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 <- decor::cpp_decorations(path, is_attribute = TRUE)
  )

  if (nrow(all_decorations) == 0) {
    return(invisible(character()))
  }

  check_valid_attributes(all_decorations)

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

  package <- desc::desc_get("Package", file = file.path(path, "DESCRIPTION"))
  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 = glue::glue("
      # Generated by cpp4r: do not edit by hand

      {r_functions}
      "), con = r_path)
  if (!quiet) {
    message(" Generated file '", basename(r_path), "'")
  }

  call_entries <- get_call_entries(path, funs$name, package)

  cpp_function_registration <- glue::glue_data(funs, '    {{
    "_cpp4r_{name}", (DL_FUNC) &_{package}_{name}, {n_args}}}, ',
    n_args = viapply(funs$args, nrow)
  )

  cpp_function_registration <- glue::glue_collapse(cpp_function_registration, sep = "\n")

  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")

  writeLines(text = glue::glue('
      // Generated by cpp4r: do not edit by hand
      // clang-format off

      {extra_includes}
      #include "cpp4r/declarations.hpp"
      #include <R_ext/Visibility.h>

      {cpp_functions_definitions}

      extern "C" {{
      {call_entries}
      }}
      {init$declarations}
      extern "C" attribute_visible void R_init_{package}(DllInfo* dll){{
        R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
        R_useDynamicSymbols(dll, FALSE);{init$calls}
        R_forceSymbols(dll, TRUE);
      }}
      ',
    call_entries = glue::glue_collapse(call_entries, "\n")
  ), con = cpp_path)

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

  invisible(c(r_path, cpp_path))
}

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

get_registered_functions <- function(decorations, tag, quiet = !is_interactive()) {
  if (NROW(decorations) == 0) {
    return(tibble::tibble(file = character(), line = integer(), decoration = character(), params = list(), context = list(), name = character(), return_type = character(), args = list()))
  }

  out <- decorations[decorations$decoration == tag, ]
  out$functions <- lapply(out$context, decor::parse_cpp_function, is_attribute = TRUE)
  out <- vctrs::vec_cbind(out, vctrs::vec_rbind(!!!out$functions))

  out <- out[!(names(out) %in% "functions")]
  out$decoration <- sub("::[[:alpha:]]+", "", out$decoration)

  n <- nrow(out)

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

  out
}

generate_cpp_functions <- function(funs, package = "cpp4r") {
  funs <- funs[c("name", "return_type", "args", "file", "line", "decoration")]
  funs$real_params <- vcapply(funs$args, glue_collapse_data, "{type} {name}")
  funs$sexp_params <- vcapply(funs$args, glue_collapse_data, "SEXP {name}")
  funs$calls <- mapply(wrap_call, funs$name, funs$return_type, funs$args, SIMPLIFY = TRUE)
  funs$package <- package

  out <- glue::glue_data(
    funs,
    '
    // {basename(file)}
    {return_type} {name}({real_params});
    extern "C" SEXP _{package}_{name}({sexp_params}) {{
      BEGIN_CPP4R
      {calls}
      END_CPP4R
    }}
    '
  )
  out <- glue::glue_collapse(out, sep = "\n")
  unclass(out)
}

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

  funs <- funs[c("name", "return_type", "args", "file", "line", "decoration")]
  funs$declaration_params <- vcapply(funs$args, glue_collapse_data, "{type} {name}")
  funs$call_params <- vcapply(funs$args, `[[`, "name")

  declarations <- glue::glue_data(
    funs,
    "
    {return_type} {name}({declaration_params});
    "
  )

  declarations <- paste0("\n", glue::glue_collapse(declarations, "\n"), "\n")

  calls <- glue::glue_data(
    funs,
    "
      {name}({call_params});
    "
  )
  calls <- paste0("\n", glue::glue_collapse(calls, "\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 <- glue::glue(', PACKAGE = "{package}"')
    package_names <- glue::glue_data(funs, '"_{package}_{name}"')
  } else {
    package_names <- glue::glue_data(funs, "`_{package}_{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 (nrow(args_df) == 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,
    glue::glue_data(funs, "invisible(.Call({package_names}{params}{package_call}))"),
    glue::glue_data(funs, ".Call({package_names}{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)) {
      glue::glue("{roxygen_comment}\n{name} <- function({list_params}) {{{body}}}")
    } else {
      glue::glue("{name} <- function({list_params}) {{{body}}}")
    }
  }, funs$name, funs$list_params, funs$calls, funs$roxygen_comment, funs$type_checks, SIMPLIFY = TRUE)

  out <- glue::trim(out)
  out <- glue::glue_collapse(out, sep = "\n\n")
  unclass(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[!sapply(roxygen_comments, is.null)]
}

wrap_call <- function(name, return_type, args) {
  call <- glue::glue("{name}({list_params})", list_params = glue_collapse_data(args, "cpp4r::as_cpp<cpp4r::decay_t<{type}>>({name})"))
  if (return_type == "void") {
    unclass(glue::glue("  {call};\n    return R_NilValue;", .trim = FALSE))
  } else {
    unclass(glue::glue("  return cpp4r::as_sexp({call});"))
  }
}

get_call_entries <- function(path, names, package) {
  con <- textConnection("res", local = TRUE, open = "w")

  withr::with_collate(
    "C",
    tools::package_native_routine_registration_skeleton(path,
      con,
      character_only = FALSE,
      include_declarations = TRUE
    )
  )

  close(con)

  start <- grep("/* .Call calls */", res, fixed = TRUE)

  end <- grep("};", res, fixed = TRUE)

  if (length(start) == 0) {
    return("")
  }

  redundant <- glue::glue_collapse(glue::glue("extern SEXP _{package}_{names}"), sep = "|")

  if (length(redundant) > 0 && nzchar(redundant)) {
    redundant <- paste0("^", redundant)
    res <- res[!grepl(redundant, res)]
  }

  end <- grep("};", res, fixed = TRUE)

  call_calls <- startsWith(res, "extern SEXP")

  if (any(call_calls)) {
    return(res[seq(start, end)])
  }

  mid <- grep("static const R_CallMethodDef CallEntries[] = {", res, fixed = TRUE)

  res[seq(mid, end)]
}

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 <- glue::glue_collapse(glue::glue("- Invalid attribute `{names}` on
                 line {lines} in file '{file}'."), "\n")

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