Merge pull request #15 from lionel-/feature-interp

Refactor interp()

NAMESPACE

@@ -32,11 +32,6 @@ S3method(find_data,default)
 S3method(find_data,list)
 S3method(has_name,default)
 S3method(has_name,environment)
-S3method(interp,call)
-S3method(interp,character)
-S3method(interp,formula)
-S3method(interp,lazy)
-S3method(interp,name)
 S3method(print,frame)
 S3method(rst_muffle,default)
 S3method(rst_muffle,mufflable)
@@ -50,6 +45,10 @@ export("env<-")
 export("f_env<-")
 export("f_lhs<-")
 export("f_rhs<-")
+export("fn_env<-")
+export(UQ)
+export(UQF)
+export(UQS)
 export(abort)
 export(arg_capture)
 export(arg_dots)
@@ -127,7 +126,6 @@ export(f_env)
 export(f_eval)
 export(f_eval_lhs)
 export(f_eval_rhs)
-export(f_interp)
 export(f_label)
 export(f_lhs)
 export(f_list)
@@ -136,6 +134,7 @@ export(f_rhs)
 export(f_text)
 export(f_unwrap)
 export(find_data)
+export(fn_env)
 export(fn_fmls)
 export(fn_fmls_names)
 export(fn_new)
@@ -236,9 +235,6 @@ export(rst_muffle)
 export(set_names)
 export(splice)
 export(stack_trim)
-export(uq)
-export(uqf)
-export(uqs)
 export(warn)
 export(with_attributes)
 export(with_env)
@@ -263,3 +259,5 @@ useDynLib(rlang,set_cadr_)
 useDynLib(rlang,set_car_)
 useDynLib(rlang,set_cddr_)
 useDynLib(rlang,set_cdr_)
+useDynLib(rlang,set_tag_)
+useDynLib(rlang,tag_)

R/arg.R

@@ -319,8 +319,8 @@ fml_default <- function(expr, fn) {
 #' @export
 #' @examples
 #' # The missing argument can be useful to generate calls
-#' f_interp(~f(x = uq(arg_missing())))
-#' f_interp(~f(x = uq(NULL)))
+#' interp(~f(x = !! arg_missing()))
+#' interp(~f(x = !! NULL))
 #'
 #'
 #' # It is perfectly valid to generate and assign the missing

R/cnd-handlers.R

@@ -99,10 +99,10 @@ with_handlers_ <- function(.expr, .handlers = list(), .env = NULL) {
 
 interp_handlers <- function(f, inplace, exiting) {
   if (length(exiting)) {
-    f <- env_set(f_interp(~tryCatch(uq(f), uqs(exiting))), f)
+    f <- env_set(interp(~tryCatch(UQ(f), UQS(exiting))), f)
   }
   if (length(inplace)) {
-    f <- env_set(f_interp(~withCallingHandlers(uq(f), uqs(inplace))), f)
+    f <- env_set(interp(~withCallingHandlers(UQ(f), UQS(inplace))), f)
   }
   f
 }

R/cnd-restarts.R

@@ -114,7 +114,7 @@ with_restarts <- function(.expr, ..., .restarts = list()) {
 #' @export
 with_restarts_ <- function(.expr, .restarts = list(), .env = NULL) {
   f <- as_quoted_f(.expr, .env)
-  f <- env_set(f_interp(~withRestarts(uq(f), uqs(.restarts))), f)
+  f <- env_set(interp(~withRestarts(UQ(f), UQS(.restarts))), f)
   f_eval(f)
 }
 

R/f-eval.R

@@ -5,7 +5,7 @@ f_eval_rhs <- function(f, data = NULL) {
     stop("`f` is not a formula", call. = FALSE)
   }
 
-  expr <- f_rhs(f_interp(f, data = data))
+  expr <- f_rhs(interp(f, data = data))
   eval_expr(expr, f_env(f), data)
 }
 
@@ -16,7 +16,7 @@ f_eval_lhs <- function(f, data = NULL) {
     stop("`f` is not a formula", call. = FALSE)
   }
 
-  expr <- f_lhs(f_interp(f, data = data))
+  expr <- f_lhs(interp(f, data = data))
   eval_expr(expr, f_env(f), data)
 }
 
@@ -35,9 +35,9 @@ f_eval_lhs <- function(f, data = NULL) {
 #' \code{.env} and \code{.data}. These are thin wrappers around \code{.data}
 #' and \code{.env} that throw errors if you try to access non-existent values.
 #'
-#' @param f A formula. Any expressions wrapped in \code{ uq() } will
+#' @param f A formula. Any expressions wrapped in \code{ UQ() } will
 #'   will be "unquoted", i.e. they will be evaluated, and the results inserted
-#'   back into the formula. See \code{\link{f_interp}} for more details.
+#'   back into the formula. See \code{\link{interp}} for more details.
 #' @param data A list (or data frame). \code{find_data} is a generic used to
 #'   find the data associated with a given object. If you want to make
 #'   \code{f_eval} work for your own objects, you can define a method for this
@@ -68,10 +68,10 @@ f_eval_lhs <- function(f, data = NULL) {
 #' # Imagine you are computing the mean of a variable:
 #' f_eval(~ mean(cyl), mtcars)
 #' # How can you change the variable that's being computed?
-#' # The easiest way is "unquote" with uq()
-#' # See ?f_interp for more details
+#' # The easiest way is "unquote" with !!
+#' # See ?interp for more details
 #' var <- ~ cyl
-#' f_eval(~ mean( uq(var) ), mtcars)
+#' f_eval(~ mean( !!var ), mtcars)
 f_eval <- f_eval_rhs
 
 
@@ -101,3 +101,50 @@ find_data.data.frame <- function(x) x
 find_data.default <- function(x) {
   stop("Do not know how to find data associated with `x`", call. = FALSE)
 }
+
+
+complain <- function(x, message = "object '%s' not found") {
+  if (is.null(x)) {
+    return(NULL)
+  }
+
+  if (is.environment(x)) {
+    x <- clone_env(x)
+  }
+
+  structure(x, message = message, class = c("complain", class(x)))
+}
+
+clone_env <- function(x) {
+  list2env(as.list(x, all.names = TRUE), parent = parent.env(x))
+}
+
+#' @export
+`$.complain` <- function(x, name) {
+  if (!has_name(x, name)) {
+    stop(sprintf(attr(x, "message"), name), call. = FALSE)
+  }
+  x[[name]]
+}
+
+#' @export
+`[[.complain` <- function(x, i, ...) {
+  if (!is_scalar_character(i)) {
+    stop("Must subset with a string", call. = FALSE)
+  }
+  if (!has_name(x, i)) {
+    stop(sprintf(attr(x, "message"), i), call. = FALSE)
+  }
+  NextMethod()
+}
+has_name <- function(x, name) {
+  UseMethod("has_name")
+}
+#' @export
+has_name.default <- function(x, name) {
+  name %in% names(x)
+}
+#' @export
+has_name.environment <- function(x, name) {
+  exists(name, envir = x, inherits = FALSE)
+}

R/fn.R

@@ -26,11 +26,10 @@
 #' attr(f, "srcref") <- NULL
 #' # Now they are:
 #' stopifnot(identical(f, g))
-fn_new <- function(args, body, env = parent.frame()) {
-  stopifnot(all(has_names(args)), is_lang(body), is.environment(env))
+fn_new <- function(args, body, env = env_caller()) {
+  stopifnot(all(has_names(args)), is_lang(body), is_env(env))
 
   args <- as.pairlist(args)
-
   eval(call("function", args, body), env)
 }
 
@@ -218,6 +217,47 @@ is_primitive_lazy <- function(x) {
 }
 
 
+#' Return the closure environment of a function.
+#'
+#' Closure environments define the scope of functions (see
+#' \code{\link{env}()}). When a function call is evaluated, R creates
+#' an evaluation frame (see \code{\link{eval_stack}()}) that inherits
+#' from the closure environment. This makes all objects defined in the
+#' closure environment and all its parents available to code executed
+#' within the function.
+#'
+#' \code{fn_env()} returns the closure environment of \code{fn}. There
+#' is also an assignment method to set a new closure environment.
+#'
+#' @param fn,x A function.
+#' @param value A new closure environment for the function.
+#' @export
+#' @examples
+#' env <- env_new("base")
+#' fn <- with_env(env, function() NULL)
+#' identical(fn_env(fn), env)
+#'
+#' other_env <- env_new("base")
+#' fn_env(fn) <- other_env
+#' identical(fn_env(fn), other_env)
+fn_env <- function(fn) {
+  if(!is_function(fn)) {
+    abort("`fn` is not a function", "type")
+  }
+  environment(fn)
+}
+
+#' @export
+#' @rdname fn_env
+`fn_env<-` <- function(x, value) {
+  if(!is_function(x)) {
+    abort("`fn` is not a function", "type")
+  }
+  environment(x) <- value
+  x
+}
+
+
 #' Coerce to function.
 #'
 #' This generic transforms objects to functions. It is especially