Basic C++ to C++ API generation

R/register.R

@@ -61,6 +61,18 @@ cpp_register <- function(path = ".", quiet = FALSE) {
 
   r_functions <- generate_r_functions(funs, package, use_package = FALSE)
 
+  ex_funs <- get_registered_functions(all_decorations, "cpp11::external", quiet)
+  ex_fun_registration <- ""
+  ex_declarations <- ""
+
+  if (nrow(ex_funs) > 0) {
+    ex_fun_registration <- glue::glue_collapse(sprintf("\n  %s", glue::glue_data(ex_funs, 
+      'R_RegisterCCallable("{package}", "_{package}_ex_{name}", (DL_FUNC) {name});'
+    )))
+    ex_declarations <- generate_ex_declarations(ex_funs)
+    generate_ex_header(path, ex_funs, package, quiet = quiet)
+  }
+
   dir.create(dirname(r_path), recursive = TRUE, showWarnings = FALSE)
 
   brio::write_lines(path = r_path, glue::glue('
@@ -118,10 +130,10 @@ cpp_register <- function(path = ".", quiet = FALSE) {
       extern "C" {{
       {call_entries}
       }}
-      {init$declarations}
+      {init$declarations}{ex_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_useDynamicSymbols(dll, FALSE);{ex_fun_registration}{init$calls}
         R_forceSymbols(dll, TRUE);
       }}
       ',
@@ -158,6 +170,94 @@ get_registered_functions <- function(decorations, tag, quiet = FALSE) {
   out
 }
 
+generate_ex_declarations <- function(funs) {
+  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)
+
+  out <- paste0("\n", glue::glue_collapse(glue::glue_data(funs,
+    '{return_type} {name}({real_params}); // {basename(file)}\n\n'
+  )))
+  unclass(out)
+}
+
+ex_params_call <- function(params) {
+  ex <- function(name="", comment="") {
+    list(
+      name = name,
+      comment = comment
+    )
+  }
+  if (is.list(params)) do.call(ex, params) else ex()
+}
+
+generate_ex_header <- function(path, funs, package, quiet = FALSE) {
+  ex_path <- file.path(path, "inst", "include", glue::glue("{package}_api.h"))
+  unlink(ex_path)
+  dir.create(dirname(ex_path), recursive = TRUE, showWarnings = FALSE)
+
+  ex_types <- c(
+    file.path(path, "inst", "include", paste0(package, "_types.h")),
+    file.path(path, "inst", "include", paste0(package, "_types.hpp"))
+  )
+  ex_types <- ex_types[file.exists(ex_types)]
+
+  ex_types_import <- if (length(ex_types) > 0) {
+    paste0("\n", glue::glue_collapse(glue::glue(
+      '\n\n#include <{ex_type_file}>',
+      ex_type_file = basename(ex_types)
+    )))
+  } else {
+    ""
+  }
+
+  header_guard <- glue::glue("{package_upper}_EXTERNAL_API_H", package_upper=toupper(package))
+
+  funs$real_params <- vcapply(funs$args, glue_collapse_data, "{type} {name}")
+  funs$types_params <- vcapply(funs$args, glue_collapse_data, "{type}")
+  funs$names_params <- vcapply(funs$args, glue_collapse_data, "{name}")
+  funs$ex_params <- lapply(funs$params, ex_params_call)
+  funs$ex_params_name <- vapply(funs$ex_params, `[[`, character(1), "name")
+  funs$ex_params_comment <- vapply(funs$ex_params, `[[`, character(1), "comment")
+
+  call_entries <- glue::glue_data(funs,
+    '
+    {comment}static inline {return_type} {export_name}({real_params}) {{
+        static {return_type}(*p_{name})({types_params}) = NULL;
+        if (p_{name} == NULL) {{
+            p_{name} = ({return_type}(*)({types_params})) R_GetCCallable("{package}", "_{package}_ex_{name}");
+        }}
+        return p_{name}({names_params});
+    }}
+    ',
+    export_name = ifelse(nchar(ex_params_name), ex_params_name, name),
+    comment = ifelse(nchar(ex_params_comment), sprintf("// %s\n", ex_params_comment), "")
+  )
+
+  brio::write_lines(path = ex_path, glue::glue('
+      // Generated by cpp11: do not edit by hand
+      // clang-format off
+
+      #ifndef {header_guard}
+      #define {header_guard}
+
+      #define R_NO_REMAP
+      #include <Rinternals.h>
+      #include <R_ext/Rdynload.h>{ex_types_import}
+
+      {call_entries}
+
+      #endif // {header_guard}
+      ',
+      call_entries = glue::glue_collapse(call_entries, "\n\n")
+  ))
+
+  if (!quiet) {
+    cli::cli_alert_success("generated file {.file {basename(ex_path)}}")
+  }
+}
+
 generate_cpp_functions <- function(funs, package = "cpp11") {
   funs <- funs[c("name", "return_type", "args", "file", "line", "decoration")]
   funs$real_params <- vcapply(funs$args, glue_collapse_data, "{type} {name}")
@@ -303,18 +403,19 @@ get_cpp_register_needs <- function() {
 
 check_valid_attributes <- function(decorations, file = decorations$file) {
 
+  valid_decor <- c("cpp11::register", "cpp11::init", "cpp11::linking_to", "cpp11::external")
   bad_decor <- startsWith(decorations$decoration, "cpp11::") &
-    (!decorations$decoration %in% c("cpp11::register", "cpp11::init", "cpp11::linking_to"))
+    (!decorations$decoration %in% valid_decor)
 
   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("cpp11 attributes must be one of `cpp11::register`, `cpp11::init` or `cpp11::linking_to`:
+    msg <- glue::glue("cpp11 attributes must be one of {msg_valid}:
       {bad_lines}
-      ")
+      ", msg_valid = glue::glue_collapse(valid_decor, sep = ", "))
     stop(msg, call. = FALSE)
 
   }