r/data-raw/codegen.R

# Licensed to the Apache Software Foundation (ASF) under one
# or more contributor license agreements.  See the NOTICE file
# distributed with this work for additional information
# regarding copyright ownership.  The ASF licenses this file
# to you under the Apache License, Version 2.0 (the
# "License"); you may not use this file except in compliance
# with the License.  You may obtain a copy of the License at
#
#   http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing,
# software distributed under the License is distributed on an
# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
# KIND, either express or implied.  See the License for the
# specific language governing permissions and limitations
# under the License.

# This file is used to generate code in the files
# src/arrowExports.cpp and R/arrowExports.R
#
# This is similar to what Rcpp::compileAttributes() would do,
# with some arrow specific changes.
#
# Functions are decorated with [[arrow::export]] instead of [[Rcpp::export]]
# and the generated code adds a layer of protection so that
# the arrow package can be installed even when libarrow is not
#
# All the C++ code should be guarded by
#
# #if defined(ARROW_R_WITH_ARROW)
# // [[arrow::export]]
# std::shared_ptr<arrow::Array> some_function_using_arrow_api(){
#     ...
# }
# #endif

suppressPackageStartupMessages({
  # remotes::install_github("romainfrancois/decor")
  library(decor)

  library(dplyr)
  library(purrr)
  library(glue)
  library(vctrs)
})

if (packageVersion("decor") < '0.0.0.9001') {
  stop("more recent version of `decor` needed, please install with `remotes::install_github('romainfrancois/decor')`")
}

decorations <- cpp_decorations() %>%
  filter(decoration == "arrow::export") %>%
  # the three lines below can be expressed with rap()
  # more concisely
  # rap(            ~ decor:::parse_cpp_function(context))
  mutate(functions = map(context, decor:::parse_cpp_function)) %>%
  { vec_cbind(., vec_rbind(!!!pull(., functions))) } %>%
  select(-functions)

message(glue("*** > {n} functions decorated with [[arrow::export]]", n = nrow(decorations)))

glue_collapse_data <- function(data, ..., sep = ", ", last = "") {
  res <- glue_collapse(glue_data(data, ...), sep = sep, last = last)
  if(length(res) == 0) res <- ""
  res
}

wrap_call <- function(name, return_type, args) {
  call <- glue::glue('{name}({list_params})', list_params = glue_collapse_data(args, "{name}"))
  if(return_type == "void") {
    glue::glue("\t{call};\n\treturn R_NilValue;", .trim = FALSE)
  } else {
    glue::glue("\treturn Rcpp::wrap({call});")
  }
}
cpp_functions_definitions <- decorations %>%
  select(name, return_type, args, file, line) %>%
  pmap_chr(function(name, return_type, args, file, line){
    glue::glue('
    // {basename(file)}
    #if defined(ARROW_R_WITH_ARROW)
    {return_type} {name}({real_params});
    RcppExport SEXP _arrow_{name}({sexp_params}){{
    BEGIN_RCPP
    {input_params}{return_line}{wrap_call(name, return_type, args)}
    END_RCPP
    }}
    #else
    RcppExport SEXP _arrow_{name}({sexp_params}){{
    \tRf_error("Cannot call {name}(). Please use arrow::install_arrow() to install required runtime libraries. ");
    }}
    #endif

    ',
      sep = "\n",
      real_params = glue_collapse_data(args, "{type} {name}"),
      sexp_params = glue_collapse_data(args, "SEXP {name}_sexp"),
      input_params = glue_collapse_data(args, "\tRcpp::traits::input_parameter<{type}>::type {name}({name}_sexp);", sep = "\n"),
      return_line = if(nrow(args)) "\n" else ""
    )
  }) %>%
  glue_collapse(sep = "\n")

cpp_functions_registration <- decorations %>%
  select(name, return_type, args) %>%
  pmap_chr(function(name, return_type, args){
    glue('\t\t{{ "_arrow_{name}", (DL_FUNC) &_arrow_{name}, {nrow(args)}}}, ')
  }) %>%
  glue_collapse(sep  = "\n")

writeLines(con = "src/arrowExports.cpp", glue::glue('
// Generated by using data-raw/codegen.R -> do not edit by hand
#include "./arrow_types.h"
#include <Rcpp.h>

using namespace Rcpp;

{cpp_functions_definitions}

extern "C" SEXP _arrow_available() {{
return Rf_ScalarLogical(
#if defined(ARROW_R_WITH_ARROW)
  TRUE
#else
  FALSE
#endif
);
}}

static const R_CallMethodDef CallEntries[] = {{
\t\t{{ "_arrow_available", (DL_FUNC)& _arrow_available, 0 }},
{cpp_functions_registration}
\t\t{{NULL, NULL, 0}}
}};

RcppExport void R_init_arrow(DllInfo* dll){{
  R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
  R_useDynamicSymbols(dll, FALSE);
}}

') )

message("*** > generated file `src/arrowExports.cpp`")

r_functions <- decorations %>%
  select(name, return_type, args) %>%
  pmap_chr(function(name, return_type, args) {
    params <- if (nrow(args)) {
      paste0(", ", glue_collapse_data(args, "{name}"))
    } else {
      ""
    }
    call <- if(return_type == "void") {
      glue::glue('invisible(.Call(`_arrow_{name}` {params}))')
    } else {
      glue::glue('.Call(`_arrow_{name}` {params})')
    }

    glue::glue('
    {name} <- function({list_params}){{
        {call}
    }}

    ',
      list_params = glue_collapse_data(args, "{name}"),
      sep = "\n",
    )
  }) %>%
  glue_collapse(sep = "\n")

writeLines(con = "R/arrowExports.R", glue::glue('
# Generated by using data-raw/codegen.R -> do not edit by hand

{r_functions}

'))
message("*** > generated file `R/arrowExports.R`")