R/code-generation.R

In krlmlr/dm: Relational Data Models

new_cg_block <- function(cg_input_object = list(), cg_f_list = list()) {
  structure(list(cg_input_object = cg_input_object, cg_f_list = cg_f_list), class = "dm_cg_code_block")
}

cg_add_call <- function(cg_block, fn_call) {
  fn <- function(.) NULL
  body(fn) <- enexpr(fn_call)
  new_cg_block(cg_block$cg_input_object, append(cg_block$cg_f_list, fn))
}

#' @export
format.dm_cg_code_block <- function(x, ...) {
  c(
    cg_format_input_object(x, is_empty(x$cg_f_list)),
    cg_format_f_list(x$cg_f_list)
  )
}

#' @export
print.dm_cg_code_block <- function(x, ...) {
  writeLines(format(x, ...))
  invisible(x)
}

cg_format_input_object <- function(x, has_no_f_call) {
  if (has_no_f_call) {
    if (!is_empty(x$cg_input_object)) {
      cg_clean_in_obj_text(x)
    }
  } else {
    paste0(cg_clean_in_obj_text(x), " %>%")
  }
}

cg_format_f_list <- function(x) {
  if (is_empty(x)) {
    character()
  } else {
    purrr::map_chr(x, ~ body(.) %>% call_to_char()) %>%
      paste0("  ", ., collapse = " %>%\n")
  }
}

call_to_char <- function(body) {
  stopifnot(identical(body[[2]], sym(".")))
  body <- as.call(as.list(body[-2]))
  trimws(expr_deparse(body)) %>% paste0(collapse = " ")
}

cg_eval_block <- function(cg_block) {
  if (is_empty(cg_block$cg_f_list)) {
    eval_tidy(cg_block$cg_input_object)
  } else {
    magrittr::freduce(eval_tidy(cg_block$cg_input_object), cg_block$cg_f_list)
  }
}

cg_clean_in_obj_text <- function(x) {
  gsub("\033[39m", "", trimws(expr_deparse(x$cg_input_object)), fixed = TRUE) %>%
    gsub("\\^", "", .)
}