R/add-reg-glue.R

In hrbrmstr/swiftr: Seamless R and Swift Integration

auto_gen_note <- "// Generated by swiftr: do not edit by hand"

preamble <- '#include <R.h>
#include <Rinternals.h>
#include <stdlib.h>
#include <R_ext/Rdynload.h>
'

extern_template <- "extern SEXP %s(%s);"

method_template <- '  {"%s", (DL_FUNC) &%s, %s},'

postamble_template <- '
static const R_CallMethodDef CallEntries[] = {
%s
  {NULL, NULL, 0}
};

void R_init_daybreak(DllInfo *dll) {
  R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
  R_useDynamicSymbols(dll, FALSE);
}
'

populate_template <- function(src_dir, swift_src, glue_src) {

  wd <- getwd()
  on.exit(setwd(wd))

  setwd(src_dir)

  gsub(
    "^import ", "",
    grep("^import", readLines(file.path(src_dir, swift_src), warn=FALSE), value=TRUE)
  ) -> imports

  if (length(imports) >= 1) {
    imports <- sprintf("-framework %s", imports)
  }

  system2(
    command = Sys.which("swiftc"),
    args = c(
      "-I /Library/Frameworks/R.framework/Headers",
      "-F/Library/Frameworks",
      "-framework R",
      imports,
      "-print-ast",
      sprintf("-import-objc-header %s", glue_src),
      swift_src
    ),
    stdout = TRUE,
    stderr = TRUE
  ) -> ast

  func_lines <- which(grepl("@_cdec", ast))

  funcs <- gsub('@_cdecl\\("|"\\)', "", ast[func_lines])
  sexp_cts <- stringi::stri_count_fixed(ast[func_lines+1], "SEXP")-1

  paste0(
    mapply(function(func, sexp_ct) {
      sprintf(extern_template, func, paste0(rep("SEXP", sexp_ct), collapse = ", "))
    }, funcs, sexp_cts, SIMPLIFY = TRUE, USE.NAMES = FALSE),
    collapse = "\n"
  ) -> externs

  paste0(
    mapply(function(func, sexp_ct) {
      sprintf(method_template, func, func, sexp_ct)
    }, funcs, sexp_cts, SIMPLIFY = TRUE, USE.NAMES = FALSE),
    collapse = "\n"
  ) -> methods

  paste(
    auto_gen_note,
    preamble,
    externs,
    sprintf(postamble_template, methods),
    sep = "\n"
  )

}

init_file_auto_generated <- function(src_dir) {

  init_file <- file.path(src_dir, "init.c")

  if (file.exists(init_file)) {
    grepl(sprintf("^%s", auto_gen_note), readLines(init_file)[1])
  } else {
    TRUE
  }

}

#' This examines a package swift file and builds the necessary registration glue code
#'
#' @param package where the package lives
#' @return nothing directly, but has a side effect of creating `init.c`
#' @export
add_registration_glue <- function(package = ".") {

  makevars <- rprojroot::find_package_root_file("src/Makevars")

  src_dir <- dirname(makevars)

  if (init_file_auto_generated(src_dir)) {

    swift_src <- list.files(src_dir, pattern = "swift$")
    glue_src <- list.files(src_dir, pattern = "h$")

    tmpl <- populate_template(src_dir, swift_src, glue_src)

    writeLines(tmpl, file.path(src_dir, "init.c"))

  } else {
    stop("init.c was not auto-generated. Aborting.")
  }

}