defer: Deferred function evaluation

#' Defer function execution.
#'
#' Both \code{defer} and \code{defer_} create an execution package
#' (wrapper) for any user-provided function.
#'
#' \code{defer} is intended for interactive use - it assumes that
#' dependencies should be extracted (\code{.extract} defaults to
#' \code{TRUE}).
#'
#' @param entry Entry-point function.
#' @param ... List of dependencies, functions and variables.
#' @param .dots A list of functions or quosures (see \code{\link[rlang]{quos}}).
#' @param .extract Whether to analyze functions and extract dependencies
#'        from their code.
#'
#' @return A \code{deferred} function object.
#'
#' @seealso augment
#'
#' @export
#' @rdname defer
#'
#' @import rlang
#'
defer <- function (entry, ..., .dots, .extract = TRUE)
{
  dots <- quos(...)
  if (!missing(.dots)) {
    stopifnot(is.list(.dots))
    dots <- c(dots, .dots)
  }

  .caller_env <- caller_env()
  defer_(entry, .dots = dots, .extract = .extract, .caller_env = .caller_env, .verbosity = 1)
}



#' @description \code{defer_} is intended for non-interactive use. It
#' provides an interface very similar to \code{defer} but by default
#' turns off discovering dependencies (\code{.extract} is \code{FALSE}).
#'
#' @param .caller_env The environment where \code{defer_()} is supposed to
#'        assume the call was made and the wrapper is returned to. Its
#'        value is important when \code{.extract} is set to \code{TRUE},
#'        and it is used in the interactive version, \code{defer()}, which
#'        passes its own \code{caller_env()} to \code{defer_()}.
#'
#' @param .verbosity Accepts values 0, 1 and 2. 0 means quiet, 1 and 2
#'        result in additional output for the user. Set to \code{1} when
#'        in interactive mode, that is, when called from \code{defer()}.
#'
#' @export
#' @rdname defer
#' @import rlang
#'
defer_ <- function (entry, ..., .dots = list(), .extract = FALSE, .caller_env = caller_env(), .verbosity = 0)
{
  # TODO should library-function names be extracted even in the programmer's API?

  # entry must be a regular function
  stopifnot(is.function(entry))
  stopifnot(is.list(.dots))
  stopifnot(.verbosity %in% 0:2)

  # capture expressions with quos() and make sure all element are named
  dots  <- quos(...)

  dots  <- tryCatch(lapply(make_all_named(dots), eval_tidy), error = function(e) stop(
    "some arguments passed in ... are not named and names cannot be auto-generated", call. = FALSE))
  .dots <- tryCatch(lapply(make_all_named(.dots), eval_tidy), error = function(e) stop(
    "some elements in `.dots` are not named and names cannot be auto-generated", call. = FALSE))

  # no overlaps are allowed
  if (length(intersect(names(dots), names(.dots)))) {
    stop("names in ... and `.dots` cannot overlap", call. = FALSE)
  }
  if ('entry' %in% names(.dots)) {
    stop('cannot use `entry` as a name in `.dots`', call. = FALSE)
  }

  # --- put all dependencies together and then extract each category one by one
  deps <- c(dots, .dots, list(entry = entry))

  processor <- DependencyProcessor$new(deps, .caller_env)
  processor$run(.extract, .verbosity)

  # --- prepare and return the deferred execution function object

  executor <- executor
  exec_env <- environment(executor) <- new.env(parent = globalenv())

  exec_env$function_deps <- processor$function_deps
  exec_env$library_deps  <- processor$library_deps
  exec_env$variables     <- processor$variables
  exec_env$arguments     <- list()
  exec_env$parameters    <- processor$parameters

  formals(executor) <- formals(deps$entry)
  if (match("...", names(formals(executor)), 0) == 0) {
    formals(executor) <- c(formals(executor), alist(...=))
  }

  class(executor) <- c("deferred", "function")

  executor
}


#' @export
#' @importFrom rlang caller_env
rlang::caller_env


#' @description \code{is_deferred} verifies if the given object
#' is a \code{deferred} function wrapper.
#'
#' @param x Object to be tested.
#' @return \code{TRUE} or \code{FALSE}.
#' @export
#'
#' @rdname defer
#'
is_deferred <- function (x) inherits(x, 'deferred')



#' Manipulate a deferred function.
#'
#' @description Pass a value in place of an argument. This function will
#' modify the input object.
#'
#' @param deferred A \code{deferred} function wrapper.
#' @param ... Name-value pairs, where name is the name of an argument to
#'        the \code{entry} function.
#' @return Modified \code{deferred} function wrapper. Note that the
#'         original function object is also modified.
#'
#' @export
#' @importFrom rlang env_clone
#'
#' @examples
#' d <- defer(function(a, b, c) return(a+b+c))
#' d <- augment(d, a = 1, b = 2, c = 3)
#' d()
#' #> 6
#'
augment <- function (deferred, ...)
{
  args <- list(...)
  if (any(!nchar(names(args)))) {
    stop("all arguments must be named", call. = FALSE)
  }

  i <- !(names(args) %in% names(formals(deferred)))
  if (any(i)) {
    stop("following names are not among arguments of `deferred`: ",
         paste(names(args)[i], collapse = ", "), call. = FALSE)
  }

  cur <- environment(deferred)$arguments
  i <- (names(args) %in% names(cur))
  if (any(i)) {
    warning("following arguments are already augmented and will be reset: ",
            paste(names(args)[i], collapse = ", "), call. = FALSE)
  }

  for (name in names(args)) {
    cur[[name]] <- args[[name]]
  }

  # create a copy of deferred and assign arguments
  new_deferred <- deferred
  environment(new_deferred) <- env_clone(environment(deferred))
  environment(new_deferred)$arguments <- cur

  return(new_deferred)
}



# ---------------------------------------------------------------------

#' @importFrom rlang get_expr
make_all_named <- function (args)
{
  is_double_colon <- function (x) is.call(x) && identical(x[[1]], bquote(`::`))
  into_name       <- function (x) {
    e <- get_expr(x)
    if (is.name(e)) return(as.character(e))
    if (is_double_colon(e)) return(deparse(e[[3]]))
    ""
  }

  if (is.null(names(args)) || !length(names(args))) {
    names(args) <- rep("", length(args))
  }

  empty <- !nchar(names(args))
  if (!any(empty)) return(args)

  new_names <- vapply(args[empty], into_name, character(1))

  if (any(!nchar(new_names))) {
    stop("some objects are not named and names cannot be auto-generated",
         call. = FALSE)
  }

  names(args)[empty] <- new_names
  args
}


is_library_dependency <- function (x) {
  (is.function(x) && isNamespace(environment(x))) || is_magrittr_impl(x)
}

is_closure <- function (x, caller_env) {
  !identical(environment(x), caller_env) &&
    !identical(environment(x), globalenv())
}

# symbol; copied from magrittr:::is_pipe
is_magrittr_pipe <- function (x) {
  identical(x, quote(`%>%`)) || identical(x, quote(`%T>%`)) ||
    identical(x, quote(`%<>%`)) || identical(x, quote(`%$%`))
}
# operator function object
is_magrittr_impl <- function (x) identical(x, magrittr::`%>%`)|| identical(x, magrittr::`%<>%`)
# runtime
is_magrittr_fseq <- function (x) inherits(x, 'fseq')

is_double_colon <- function (x) is.call(x) && identical(x[[1]], bquote(`::`))
is_triple_colon <- function (x) is.call(x) && identical(x[[1]], bquote(`:::`))
is_colon <- function (x) is_double_colon(x) || is_triple_colon(x)

is_assignment <- function (x) identical(x[[1]], bquote(`<-`))


library(R6)

#' @importFrom rlang caller_env is_scalar_atomic
#' @importFrom R6 R6Class
DependencyProcessor<- R6::R6Class("DependencyProcessor",
  public = list(
    library_deps  = data.frame(pkg = character(), fun = character(), ver = character(),
                               stringsAsFactors = FALSE),
    function_deps = list(),
    variables = list(),
    parameters = list(),

    initialize = function (deps, caller_env) {
      private$deps <- deps
      private$caller_env <- caller_env
    },

    # 1. extract regular functions
    # 2. extract variables
    # 3. extract library functions
    # 4. nothing else should be left
    #
    run = function (extract = FALSE, verbosity = 0)
    {
      private$extract   <- extract
      private$verbosity <- verbosity
      private$process()
      private$summary()
    }
  ),
  private = list(
    deps       = list(),
    processed  = list(),
    caller_env = NA,
    extract    = FALSE,
    verbosity  = 0,

    process = function () {
      while (length(private$deps)) {
        name    <- names(private$deps)[1]
        current <- private$deps[[1]]
        private$deps <- private$deps[-1]

        if (is_library_dependency(current)) {
          private$process_library(name, current)
        }
        else if (is.function(current)) {
          private$process_function(name, current)
        }
        else if (is.vector(current) || is.list(current)) {
          private$process_variable(name, current)
        }
        else {
          stop("cannot process")
        }
      }
    },

    process_library = function (name, fun) {
      pkg_name <- if (is_magrittr_impl(fun)) 'magrittr' else environmentName(environment(fun))
      pkg_ver  <- as.character(getNamespaceVersion(pkg_name))
      new_dep  <- data.frame(fun = name, pkg = pkg_name, ver = pkg_ver, stringsAsFactors = FALSE)

      private$verbose("Adding library call: ", pkg_name, '::', name)
      self$library_deps <- rbind(self$library_deps, new_dep)
    },

    # Extracts regular functions.
    # remove environment from a function unless it's a closure
    #
    process_function = function (name, fun) {
      if (!is_closure(fun, private$caller_env) && !is_magrittr_fseq(fun)) {
        environment(fun) <- emptyenv()
      }

      private$verbose("Adding function: ", name)
      self$function_deps[[name]] <- fun

      if (isTRUE(private$extract)) {
        private$verbose("Processing function: ", name)

        if (is_magrittr_fseq(fun)) {
          private$verbose("Processing fseq: fun")
          private$verbose("  - adding candidate function: %>%")
          private$deps[["%>%"]] <- magrittr::`%>%`
          lapply(magrittr::functions(fun), function (f) {
            private$process_body(body(f))
          })
        }
        else
          private$process_body(body(fun))
      }
    },

    process_variable = function (name, value) {
      private$verbose("Adding variable: ", name)
      self$variables[[name]] <- value
    },

    # https://stackoverflow.com/questions/14276728/finding-the-names-of-all-functions-in-an-r-expression/14295659#14295659
    process_body = function (x, in_pipe = FALSE, argname = "") {
      # TODO in order to extract names to which constants and variables are assigned to, here is one place
      #      the inner lapply in recurse()
      recurse <- function (x, in_pipe = FALSE) {
        # TODO does not work for positional args
        names <- if (is.null(names(x))) rep("", length(x)) else names(x)
        sort(unique(as.character(unlist(Map(f = function (node, name) {
          private$process_body(node, in_pipe = in_pipe, argname = name)
        }, node = x, name = names)))))
      }
      already_found <- function (x) (f_name %in% c(names(self$function_deps), self$library_deps$fun, names(self$deps)))

      # if a name but in the context of a pipe expression, treat it like a function call,
      # which it is
      if (is.name(x) && isTRUE(in_pipe)) {
        x <- substitute(fun(.), list(fun = x))
      }

      # it will be either a name, an assignment, a call or something recursive
      if (is.name(x)) {
        private$verbose("name")

        v_name <- as.character(x)
        if (!nchar(v_name) || !exists(v_name, envir = private$caller_env, inherits = TRUE)) return()

        candidate <- get(v_name, envir = private$caller_env)
        # TODO replace condition if only simple variables are to be extracted
        #if (!is.numeric(candidate) && !is.character(candidate)) return()
        if (is.function(candidate)) return()

        v_value <- get(v_name, envir = private$caller_env)
        self$variables[[v_name]] <- v_value
        private$verbose("  - adding candidate variable: ", v_name)

        if (is_scalar_atomic(v_value)) {
          if (nchar(argname)) {
            self$parameters[[argname]] <- x # TODO what if parameter is actually a symbol?
          } else {
            self$parameters <- append(self$parameters, x)
          }
        }
      }
      else if (is_scalar_atomic(x)) {
        if (nchar(argname)) {
          self$parameters[[argname]] <- x
        } else {
          self$parameters <- append(self$parameters, x)
        }
      }
      else if (is_assignment(x)) {
        private$verbose("assignment")

        # TODO here is another place where argument name has to be extracted from
        return(recurse(x[-(1:2)]))
      }
      else if (is_colon(x)) {
        private$verbose("colon ", deparse(x))

        # TODO seems that functions might mask one another here; the package pointed
        #      to by x should be loaded upon execution but the function itself shouldn't
        #      be loaded into the shim environment as it is clearly conflicting with
        #      something else if it needs the :: or ::: operator to be recognized
        f_name <- deparse(x[[3]])
        f_obj <- eval(x, envir = private$caller_env)
        private$process_candidate(f_name, f_obj)
      }
      else if (is.call(x) && is.name(x[[1]])) {
        private$verbose("single-name call")

        f_name <- deparse(x[[1]])
        if (!already_found(f_name) && exists(f_name, envir = private$caller_env, mode = 'function', inherits = TRUE)) {
          f_obj <- get(f_name, envir = private$caller_env, mode = 'function', inherits = TRUE)
          private$process_candidate(f_name, f_obj)
        }

        if (is_magrittr_pipe(x[[1]])) {
          recurse(x[2], FALSE)
          recurse(x[-(1:2)], TRUE)
        }
        else {
          recurse(x[-1], FALSE)
        }
      }
      else if (is.recursive(x)) {
        private$verbose("recursive")
        recurse(x)
      }
    },

    process_candidate = function (name, fun) {
      if (!is.primitive(fun)) {
        private$deps[[name]] <- fun
        private$verbose("  - adding candidate function: ", name)
      }
    },

    verbose = function (...) {
      if (identical(private$verbosity, 2)) {
        message(paste(..., collapse = " ", sep = ""))
      }
    },

    summary = function () {
      if (identical(private$verbosity, 1) || identical(private$verbosity, 2)) {
        formatted <- format_deferred(self)
        if (nchar(formatted) > 0) {
          message("Found ", formatted)
        }
      }
    }
  )
)