replace compiled code with pure R implementations

DESCRIPTION

@@ -1,15 +1,15 @@
 Package: lazyeval
-Version: 0.2.2
+Version: 0.3.0
 Title: Lazy (Non-Standard) Evaluation
-Description: An alternative approach to non-standard evaluation using
-    formulas. Provides a full implementation of LISP style 'quasiquotation',
-    making it easier to generate code with other code.
+Description: This package has been retired. Please use 'rlang' instead.
+    An alternative approach to non-standard evaluation using formulas.
+    Provides a full implementation of LISP style 'quasiquotation', making
+    it easier to generate code with other code.
 Authors@R: c(
     person("Hadley", "Wickham", ,"hadley@rstudio.com", c("aut", "cre")),
     person("RStudio", role = "cph")
     )
 License: GPL-3
-LazyData: true
 Depends:
     R (>= 3.1.0)
 Suggests:

NAMESPACE

@@ -93,4 +93,3 @@ export(missing_arg)
 export(uq)
 export(uqf)
 export(uqs)
-useDynLib(lazyeval, .registration = TRUE)

NEWS.md

@@ -1,4 +1,13 @@
 
+# lazyeval 0.3.0
+
+* This package has been retired. Please use rlang instead.
+
+* Removed all compiled C code to comply with R's C API restrictions.
+  Promise capture now uses `substitute()` and `parent.frame()` instead
+  of directly accessing promise internals. Promise chasing through
+  nested function calls is no longer supported.
+
 # lazyeval 0.2.2
 
 * Fix protection issues from rchk reports.

R/expr.R

@@ -1,22 +1,17 @@
 #' Find the expression associated with an argument
 #'
-#' \code{expr_find()} finds the full expression; \code{expr_text()} turns the
-#' expression into a single string; \code{expr_label()} formats it nicely for
-#' use in messages. \code{expr_env()} finds the environment associated with
-#' the expression.
+#' \code{expr_find()} captures the unevaluated expression using
+#' \code{substitute()}; \code{expr_text()} turns the expression into a single
+#' string; \code{expr_label()} formats it nicely for use in messages.
+#' \code{expr_env()} returns the caller's environment.
 #'
-#' These functions never force promises, and will work even if a promise has
-#' previously been forced.
+#' Note: in previous versions, these functions could follow chains of
+#' promises across nested function calls. This is no longer supported.
 #'
-#' @param x A promise (function argument)
+#' @param x An unevaluated expression (function argument)
 #' @export
 #' @examples
-#' # Unlike substitute(), expr_find() finds the original expression
-#' f <- function(x) g(x)
-#' g <- function(y) h(y)
-#' h <- function(z) list(substitute(z), expr_find(z))
-#'
-#' f(1 + 2 + 3)
+#' expr_find(1 + 2 + 3)
 #'
 #' expr_label(10)
 #' # Names a quoted with ``
@@ -31,7 +26,7 @@
 #'   print(x)
 #' }))
 expr_label <- function(x) {
-  expr_label_(expr_find(x))
+  expr_label_(substitute(x))
 }
 
 expr_label_ <- function(x) {
@@ -56,7 +51,7 @@ expr_label_ <- function(x) {
 #' @param width Width of each line
 #' @param nlines Maximum number of lines to extract.
 expr_text <- function(x, width = 60L, nlines = Inf) {
-  expr_text_(expr_find(x), width = width, nlines = nlines)
+  expr_text_(substitute(x), width = width, nlines = nlines)
 }
 
 expr_text_ <- function(x, width = 60L, nlines = Inf) {
@@ -72,23 +67,12 @@ expr_text_ <- function(x, width = 60L, nlines = Inf) {
 #' @export
 #' @rdname expr_label
 expr_find <- function(x) {
-  .Call(lazyeval_expr_find_, quote(x), environment())
+  substitute(x)
 }
 
-#' @param default_env If supplied, \code{expr_env} will return this if the
-#'   promise has already been forced. Otherwise it will throw an error.
+#' @param default_env Ignored. Kept for backwards compatibility.
 #' @export
 #' @rdname expr_label
 expr_env <- function(x, default_env) {
-  env <- .Call(lazyeval_expr_env_, quote(x), environment())
-
-  if (is.null(env)) {
-    if (missing(default_env)) {
-      stop("Promise has already been forced")
-    } else {
-      default_env
-    }
-  } else {
-    env
-  }
+  parent.frame()
 }

R/f-capture.R

@@ -15,21 +15,20 @@
 #' @examples
 #' f_capture(a + b)
 #' dots_capture(a + b, c + d, e + f)
-#'
-#' # These functions will follow a chain of promises back to the
-#' # original definition
-#' f <- function(x) g(x)
-#' g <- function(y) h(y)
-#' h <- function(z) f_capture(z)
-#' f(a + b + c)
 f_capture <- function(x) {
-  lazy <- .Call(lazyeval_make_lazy, quote(x), environment(), TRUE)
-  f_new(lazy$expr, env = lazy$env)
+  f_new(substitute(x), env = parent.frame())
 }
 
 #' @export
 #' @rdname f_capture
 dots_capture <- function(..., .ignore_empty = TRUE) {
-  lazies <- .Call(lazyeval_make_lazy_dots, environment(), TRUE, .ignore_empty)
-  lapply(lazies, function(x) f_new(x$expr, env = x$env))
+  env <- parent.frame()
+  exprs <- eval(substitute(alist(...)))
+
+  if (.ignore_empty) {
+    keep <- vapply(exprs, function(x) !identical(x, quote(expr = )), logical(1))
+    exprs <- exprs[keep]
+  }
+
+  lapply(exprs, function(expr) f_new(expr, env = env))
 }

R/f-interp.R

@@ -8,8 +8,8 @@
 #' Formally, \code{f_interp} is a quasiquote function, \code{uq()} is the
 #' unquote operator, and \code{uqs()} is the unquote splice operator.
 #' These terms have a rich history in LISP, and live on in modern languages
-#' like \href{Julia}{http://docs.julialang.org/en/release-0.1/manual/metaprogramming/}
-#' and \href{Racket}{https://docs.racket-lang.org/reference/quasiquote.html}.
+#' like \href{http://docs.julialang.org/en/release-0.1/manual/metaprogramming/}{Julia}
+#' and \href{https://docs.racket-lang.org/reference/quasiquote.html}{Racket}.
 #'
 #' @param f A one-sided formula.
 #' @param x For \code{uq} and \code{uqf}, a formula. For \code{uqs}, a
@@ -38,10 +38,62 @@
 #' f
 #' f_interp(f)
 f_interp <- function(f, data = NULL) {
-  f_rhs(f) <- .Call(lazyeval_interp_, f_rhs(f), f_env(f), data)
+  f_rhs(f) <- interp_walk(f_rhs(f), f_env(f), data)
   f
 }
 
+interp_walk <- function(x, env, data) {
+  if (!is.call(x))
+    return(x)
+
+  if (is.name(x[[1]])) {
+    fn_name <- as.character(x[[1]])
+
+    if (fn_name == "uq") {
+      uq_call <- call("uq", x[[2]], data)
+      return(eval(uq_call, env))
+    }
+    if (fn_name == "uqf") {
+      return(eval(x, env))
+    }
+  }
+
+  # Recursive case: rebuild call handling uqs splicing
+  elements <- as.list(x)
+  el_names <- names(elements)
+  n <- length(elements)
+  result <- vector("list", n * 2L)
+  res_names <- character(n * 2L)
+  j <- 0L
+
+  for (i in seq_along(elements)) {
+    el <- elements[[i]]
+
+    # Check if this element is a uqs() call (only in argument position)
+    if (i > 1L && is.call(el) && is.name(el[[1]]) && as.character(el[[1]]) == "uqs") {
+      spliced <- as.list(eval(el, env))
+      spliced_nms <- names(spliced) %||% rep("", length(spliced))
+      for (k in seq_along(spliced)) {
+        j <- j + 1L
+        result[[j]] <- spliced[[k]]
+        res_names[j] <- spliced_nms[k]
+      }
+    } else {
+      j <- j + 1L
+      result[[j]] <- interp_walk(el, env, data)
+      res_names[j] <- if (!is.null(el_names)) el_names[i] else ""
+    }
+  }
+
+  result <- result[seq_len(j)]
+  res_names <- res_names[seq_len(j)]
+  out <- as.call(result)
+  if (any(nzchar(res_names))) {
+    names(out) <- res_names
+  }
+  out
+}
+
 #' @export
 #' @rdname f_interp
 uq <- function(x, data = NULL) {

R/formula.R

@@ -59,7 +59,13 @@ is_formula <- function(x) {
 #'
 #' f_env(~ x)
 f_rhs <- function(f) {
-  .Call(lazyeval_rhs, f)
+  if (!is_formula(f))
+    stop("`f` is not a formula", call. = FALSE)
+  switch(as.character(length(f)),
+    "2" = f[[2L]],
+    "3" = f[[3L]],
+    stop("Invalid formula", call. = FALSE)
+  )
 }
 
 #' @export
@@ -72,7 +78,13 @@ f_rhs <- function(f) {
 #' @export
 #' @rdname f_rhs
 f_lhs <- function(f) {
-  .Call(lazyeval_lhs, f)
+  if (!is_formula(f))
+    stop("`f` is not a formula", call. = FALSE)
+  switch(as.character(length(f)),
+    "2" = NULL,
+    "3" = f[[2L]],
+    stop("Invalid formula", call. = FALSE)
+  )
 }
 
 #' @export
@@ -85,7 +97,9 @@ f_lhs <- function(f) {
 #' @export
 #' @rdname f_rhs
 f_env <- function(f) {
-  .Call(lazyeval_env, f)
+  if (!is_formula(f))
+    stop("`f` is not a formula", call. = FALSE)
+  environment(f)
 }
 
 #' @export
@@ -163,11 +177,52 @@ f_unwrap <- function(f) {
 #' f_list("y" ~ x)
 #' f_list(a = "y" ~ a, ~ b, c = ~c)
 f_list <- function(...) {
-  .Call(lazyeval_lhs_name, list(...))
+  lhs_name(list(...))
 }
 
 #' @export
 #' @rdname f_list
 as_f_list <- function(x) {
-  .Call(lazyeval_lhs_name, x)
+  lhs_name(x)
+}
+
+lhs_as_name <- function(x) {
+  if (is.character(x)) {
+    if (length(x) != 1L)
+      stop("LHS must evaluate to a single string", call. = FALSE)
+    return(x)
+  }
+  if (is.name(x)) {
+    return(as.character(x))
+  }
+  if (is_formula(x) && length(x) == 2L) {
+    return(lhs_as_name(f_rhs(x)))
+  }
+  if (is_formula(x)) {
+    stop("RHS of LHS must be a single-sided formula", call. = FALSE)
+  }
+  stop("LHS must evaluate to a string or name", call. = FALSE)
+}
+
+lhs_name <- function(x) {
+  if (!is.list(x))
+    stop("`x` must be a list", call. = FALSE)
+
+  nms <- names(x) %||% rep("", length(x))
+
+  for (i in seq_along(x)) {
+    xi <- x[[i]]
+    if (!is_formula(xi) || length(xi) != 3L)
+      next
+
+    name <- eval(f_lhs(xi), f_env(xi))
+    if (!is.null(name)) {
+      nms[i] <- lhs_as_name(name)
+    }
+
+    x[[i]] <- f_new(f_rhs(xi), env = f_env(xi))
+  }
+
+  names(x) <- nms
+  x
 }

R/lazy-dots.R

@@ -13,12 +13,6 @@
 #'   lazy_dots(x = x, y = a + b, ...)
 #' }
 #' f(z = a + b)
-#' f(z = a + b, .follow_symbols = TRUE)
-#'
-#' # .follow_symbols is off by default because it causes problems
-#' # with lazy loaded objects
-#' lazy_dots(letters)
-#' lazy_dots(letters, .follow_symbols = TRUE)
 #'
 #' # You can also modify a dots like a list. Anything on the RHS will
 #' # be coerced to a lazy.
@@ -29,7 +23,19 @@
 #'
 #' c(lazy_dots(x = 1), lazy_dots(f))
 lazy_dots <- function(..., .follow_symbols = FALSE, .ignore_empty = FALSE) {
-  .Call(lazyeval_make_lazy_dots, environment(), .follow_symbols, .ignore_empty)
+  env <- parent.frame()
+  exprs <- eval(substitute(alist(...)))
+  nms <- names(exprs)
+
+  if (.ignore_empty) {
+    keep <- vapply(exprs, function(x) !identical(x, quote(expr = )), logical(1))
+    exprs <- exprs[keep]
+    if (!is.null(nms)) nms <- nms[keep]
+  }
+
+  dots <- lapply(exprs, function(expr) lazy_(expr, env))
+  if (!is.null(nms)) names(dots) <- nms
+  structure(dots, class = "lazy_dots")
 }
 
 is.lazy_dots <- function(x) inherits(x, "lazy_dots")