duckdb-r/scripts/rethrow.R at main · krlmlr/duckdb-r · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
# Generate R/rethrow-gen.R from R/cpp11.R: wrap each rapi_* binding
# to rethrow errors with call context; sourced by .Rprofile on repo load.
rethrow_generate <- function() {
  if (Sys.getenv("CI") != "") {
    return()
  }

  source <- "R/cpp11.R"
  dest <- "R/rethrow-gen.R"
  if (file.exists(dest) && file.mtime(source) <= file.mtime(dest)) {
    return()
  }

  cpp11 <- readLines("R/cpp11.R")
  rx <- "(?<fun>rapi_.*) [<]- function[(](?<args>[^)]*)[)]"
  fun_lines <- grep(rx, cpp11, value = TRUE, perl = TRUE)
  funs <- rematch2::re_match(fun_lines, rx)

  code_wrappers <- paste0(
    "rethrow_",
    funs$fun,
    " <- function(",
    funs$args,
    ifelse(funs$args == "", "", ", "),
    "call = parent.frame(2)) {\n",
    "  rlang::try_fetch(\n",
    "    ",
    funs$fun,
    "(",
    funs$args,
    "),\n",
    "    error = function(e) {\n",
    "      rethrow_error_from_rapi(e, call)\n",
    "    }\n",
    "  )\n",
    "}"
  )

  code_restore <- paste0(
    "rethrow_restore <- function() {\n",
    paste0("  rethrow_", funs$fun, " <<- ", funs$fun, "\n", collapse = ""),
    "}"
  )

  rethrow <- paste(
    c(
      "# Generated by scripts/rethrow.R, do not edit by hand",
      code_wrappers,
      code_restore
    ),
    collapse = "\n\n"
  )

  writeLines(rethrow, "R/rethrow-gen.R")
}

rethrow_generate()