Port lazy functions to rlang

DESCRIPTION

@@ -12,10 +12,13 @@ License: GPL-3
 LazyData: true
 Depends:
     R (>= 3.1.0)
+Imports:
+    rlang
 Suggests:
     knitr,
     rmarkdown (>= 0.2.65),
     testthat,
     covr
 VignetteBuilder: knitr
 RoxygenNote: 5.0.1
+Remotes: hadley/rlang#2

NAMESPACE

@@ -94,11 +94,7 @@ export(uq)
 export(uqf)
 export(uqs)
 useDynLib(lazyeval,env)
-useDynLib(lazyeval,expr_env_)
-useDynLib(lazyeval,expr_find_)
 useDynLib(lazyeval,interp_)
 useDynLib(lazyeval,lhs)
 useDynLib(lazyeval,lhs_name)
-useDynLib(lazyeval,make_lazy)
-useDynLib(lazyeval,make_lazy_dots)
 useDynLib(lazyeval,rhs)

R/expr.R

@@ -69,28 +69,19 @@ expr_text_ <- function(x, width = 60L, nlines = Inf) {
   paste0(str, collapse = "\n")
 }
 
-#' @useDynLib lazyeval expr_find_
 #' @export
 #' @rdname expr_label
 expr_find <- function(x) {
-  .Call(expr_find_, quote(x), environment())
+  rlang::arg_expr(x)
 }
 
-#' @useDynLib lazyeval expr_env_
-#' @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 Deprecated and has no longer any effect.
+#'   \code{expr_env()} now always returns an environment.
 #' @export
 #' @rdname expr_label
 expr_env <- function(x, default_env) {
-  env <- .Call(expr_env_, quote(x), environment())
-
-  if (is.null(env)) {
-    if (missing(default_env)) {
-      stop("Promise has already been forced")
-    } else {
-      default_env
-    }
-  } else {
-    env
+  if (!missing(default_env)) {
+    warning(call. = FALSE, "`default_env` is deprecated")
   }
+  rlang::arg_env(x)
 }

R/f-capture.R

@@ -23,13 +23,13 @@
 #' h <- function(z) f_capture(z)
 #' f(a + b + c)
 f_capture <- function(x) {
-  lazy <- .Call(make_lazy, quote(x), environment(), TRUE)
-  f_new(lazy$expr, env = lazy$env)
+  info <- rlang::arg_info(x)
+  f_new(info$expr, env = info$eval_frame$env)
 }
 
 #' @export
 #' @rdname f_capture
 dots_capture <- function(..., .ignore_empty = TRUE) {
-  lazies <- .Call(make_lazy_dots, environment(), TRUE, .ignore_empty)
+  lazies <- lazy_dots(..., .ignore_empty = .ignore_empty)
   lapply(lazies, function(x) f_new(x$expr, env = x$env))
 }

R/lazy-dots.R

@@ -5,7 +5,6 @@
 #' @return A named list of \code{\link{lazy}} expressions.
 #' @inheritParams lazy
 #' @export
-#' @useDynLib lazyeval make_lazy_dots
 #' @examples
 #' lazy_dots(x = 1)
 #' lazy_dots(a, b, c * 4)
@@ -29,8 +28,29 @@
 #' l["z"] <- list(~g)
 #'
 #' c(lazy_dots(x = 1), lazy_dots(f))
-lazy_dots <- function(..., .follow_symbols = FALSE, .ignore_empty = FALSE) {
-  .Call(make_lazy_dots, environment(), .follow_symbols, .ignore_empty)
+lazy_dots <- function(..., .follow_symbols = TRUE, .ignore_empty = FALSE) {
+  dots <- rlang::arg_dots(...)
+  if (!length(dots)) {
+    return(structure(list(), class = "lazy_dots"))
+  }
+
+  if (.follow_symbols) {
+    stack <- rlang::call_stack()
+  } else {
+    stack <- rlang::call_stack(2)
+  }
+
+  info <- rlang::dots_info_(dots, stack)
+  lazy_dots <- lapply2(info, seq_along(info), info_as_lazy)
+
+  if (.ignore_empty) {
+    is_missing <- vapply_lgl(lazy_dots, function(lzy) {
+      rlang::is_missing(lzy$expr)
+    })
+    lazy_dots <- lazy_dots[!is_missing]
+  }
+
+  structure(lazy_dots, class = "lazy_dots")
 }
 
 is.lazy_dots <- function(x) inherits(x, "lazy_dots")

R/lazy.R

@@ -48,9 +48,35 @@ lazy_ <- function(expr, env) {
 
 #' @rdname lazy_
 #' @export
-#' @useDynLib lazyeval make_lazy
 lazy <- function(expr, env = parent.frame(), .follow_symbols = TRUE) {
-  .Call(make_lazy, quote(expr), environment(), .follow_symbols)
+  if (.follow_symbols) {
+    stack <- rlang::call_stack()
+  } else {
+    stack <- rlang::call_stack(2)
+  }
+  info <- rlang::arg_info_(quote(expr), stack)
+  info_as_lazy(info)
+}
+
+info_as_lazy <- function(info, i_dot) {
+  lzy <- list(
+    expr = info$expr,
+    env = info$eval_frame$env
+  )
+  lzy <- substitute_dots(lzy, info$eval_frame$env, i_dot)
+  structure(lzy, class = "lazy")
+}
+substitute_dots <- function(lazy, caller_env, i_dot) {
+  if (!is.symbol(lazy$expr)) {
+    return(lazy)
+  }
+
+  nm <- as.character(lazy$expr)
+  if (grepl("\\.\\.[0-9]+$", nm)) {
+    dots <- rlang::frame_dots(caller_env)
+    lazy$expr <- dots[[i_dot]]
+  }
+  lazy
 }
 
 is.lazy <- function(x) inherits(x, "lazy")

R/utils.R

@@ -35,3 +35,9 @@ substitute_ <- function(x, env) {
 missing_arg <- function() {
   quote(expr = )
 }
+vapply_lgl <- function(.x, .f, ...) {
+  vapply(.x, .f, logical(1), ...)
+}
+lapply2 <- function(.x, .y, .f, ...) {
+  Map(.f, .x, .y, ...)
+}

tests/testthat/test-expr.R

@@ -25,23 +25,6 @@ test_that("follows multiple promises", {
   expect_identical(h(x + y), environment())
 })
 
-test_that("throws error if promise forced", {
-  f <- function(x) {
-    force(x)
-    expr_env(x)
-  }
-  expect_error(f(10), "already been forced")
-})
-
-
-test_that("or can return default env", {
-  env <- new.env(parent = emptyenv())
-  f <- function(x) {
-    force(x)
-    expr_env(x, env)
-  }
-  expect_identical(f(10), env)
-})
 
 # expr_text ---------------------------------------------------------------