An attempt at creating a decorating operator in R

decorator-infix.R

#' Right-associative operator for function decoration
#'
#' @description Decorating a function wraps the body of the inner function in a
#'   decorator function, allowing for insertion of code before or after the body
#'   of the inner function call.
#'
#' @param d the decorating function to wrap function \code{f}
#' @param f the function to decorate
#'
#' @return a new function call, functionally equivalent to the decorated
#'   function but with a wrapping call to the decorating function, passing the
#'   function body to the first argument of the decorating function.
#'
#' @examples
#' ## Decorating a function
#'
#' decorator <- function(f, decorator_name = "decorator") {
#'   c(paste("Entering the", decorator_name),
#'     f,
#'     paste("Exiting the", decorator_name))
#' }
#'
#' hello <- decorator("Twilight Zone") %@% function(hello_to = "World!") {
#'   paste("Hello,", hello_to)
#' }
#'
#' hello
#' #> function (hello_to = "World!")
#' #> decorator({
#' #>     paste("Hello,", hello_to)
#' #> }, "twilight zone.")
#'
#' cat(hello(), sep = "\n")
#' #> Entering the Twilight Zone
#' #> Hello, World!"
#' #> Exiting the Twilight Zone
#'
#'
#' ## Chaining Decorators and Mutating Function Outputs
#'
#' decorator2 <- function(f, append = "") {
#'   gsub("Twilight Zone", paste("Twilight Zone", append), f)
#' }
#'
#' hello2 <-
#'   decorator2("(o_0)") %@%
#'   decorator("Twilight Zone") %@%
#'   function(hello_to = "World!") {
#'   paste("Hello,", hello_to)
#' }
#'
#' hello2
#' #> function (hello_to = "World!")
#' #> decorator2(decorator({
#' #>     paste("Hello,", hello_to)
#' #> }, "Twilight Zone."), "(o_0)")
#'
#' cat(hello2(), sep = "\n")
#' #> Entering the Twilight Zone (o_0).
#' #> Hello, World!
#' #> Exiting the Twilight Zone (o_0).
#'
#' @name decorator-infix
#' @rdname decorator-infix
#' @export
`%@%` <- function(d, f) {
  envir <- parent.frame()
  dlist <- as.list(sys.call()[[2]])

  # enforce right associativity
  if (dlist[[1]] == "%@%") {
    f <- eval(bquote(.(dlist[[3]]) %@% .(f)), envir = envir)
    return(eval(bquote(.(dlist[[2]]) %@% .(f)), envir = envir))
  # handle parenthesized anonymous functions
  } else if (dlist[[1]] == "(") {
    dlist <- list(d)
  }

  body(f) <- as.call(c(dlist[[1]], body(f), dlist[-1]))
  as.function(f, envir = envir)
}