R/aaa-named-layer-factory.R

In coursekata: Packages and Functions for 'CourseKata' Courses

#' Generate a named ggformula layer function
#'
#' `ggformula::layer_factory()` deliberately captures several arguments as
#' expressions and gives its generated function lazy promises plus
#' `environment = parent.frame()`. Calling it through an ordinary wrapper would
#' force or re-scope those expressions. This adapter rebuilds the factory call
#' from the wrapper's unevaluated `...`, then records the literal exported name
#' in the generated closure for `pre` code that needs to name an error, warning
#' or lifecycle signal.
#'
#' Each invocation still returns a new generated closure. Aliases can therefore
#' share one recipe without becoming forwarders or two bindings of one function:
#' `match.call()` sees the name the reader wrote, promises retain ggformula's
#' laziness, and the generated `environment = parent.frame()` still points at
#' the reader's calling frame.
#'
#' Helpers used by `pre` are installed as lazy bindings because package source
#' may define them after the generated front door. They resolve from the
#' CourseKata namespace on first use without replacing the ggformula namespace
#' that encloses the generated function.
#'
#' @param function_name The literal exported `gf_*` function name.
#' @param ... Unevaluated arguments forwarded to
#'   [ggformula::layer_factory()].
#' @param .pre_bindings A named pairlist of CourseKata helpers to bind lazily
#'   in the generated function's environment for use by `pre`.
#'
#' @return A function generated by [ggformula::layer_factory()].
#'
#' @noRd
named_layer_factory <- function(function_name, ..., .pre_bindings = alist()) {
  if (
    !is.character(function_name) || length(function_name) != 1L ||
      is.na(function_name) || !startsWith(function_name, "gf_")
  ) {
    stop("`function_name` must be one literal CourseKata `gf_*` name.", call. = FALSE)
  }

  pre_bindings <- as.list(.pre_bindings)
  binding_names <- names(pre_bindings)
  if (
    length(pre_bindings) > 0L &&
      (is.null(binding_names) || anyNA(binding_names) ||
        any(!nzchar(binding_names)) || anyDuplicated(binding_names))
  ) {
    stop("`.pre_bindings` must have unique, non-empty names.", call. = FALSE)
  }

  factory_args <- as.list(match.call(expand.dots = FALSE)$...)
  # A shared recipe quotes generated `pre` code so package checks do not treat
  # its symbols as bindings in the recipe helper itself. The underlying factory
  # still receives the same bare expression as a direct call would.
  quoted_pre <- is.call(factory_args$pre) &&
    identical(factory_args$pre[[1L]], quote(quote))
  if (quoted_pre) {
    factory_args$pre <- factory_args$pre[[2L]]
  }
  factory_call <- as.call(c(quote(ggformula::layer_factory), factory_args))
  front_door <- eval_bare(factory_call, env = caller_env())
  front_door_env <- get_env(front_door)

  collisions <- binding_names[env_has(front_door_env, binding_names)]
  if (length(collisions) > 0L) {
    stop(
      "`.pre_bindings` must not replace bindings created by `layer_factory()`.",
      call. = FALSE
    )
  }
  if (length(pre_bindings) > 0L) {
    namespace <- ns_env()
    inject(
      env_bind_lazy(
        front_door_env,
        !!!pre_bindings,
        .eval_env = namespace
      )
    )
  }
  env_bind(front_door_env, .coursekata_function_name = function_name)
  front_door
}