tests/testthat/test-getpromise.R

In crowding/nse: Tools for Lazy and Non-Standard Evaluation

context("Promise extraction")

`%is%` <- expect_equal

test_that("can recover environments of arguments", {
  f1 <- function(a, ...) { #a=one@top, two@top
    b <- 1
    where = "f1"
    f2(b, where, ...) #b, where, two
  }
  f2 <- function(a, ...) { # a=b@f1, where@f1, two@top
    b <- 2
    where <- "f2"
    f3(b, where, ...) #b@f2, where@f2, where@f1, two@top
  }
  f3 <- function(a, b, c, ...) { #a=b@f2, b=where@f2, c=where@f1, two@top
    arg_expr(a) %is% quote(b)
    arg_expr(b) %is% quote(where)
    arg_expr(c) %is% quote(where)
    exprs(dots(...)) %is% alist(two)
    arg_env(a)$where %is% "f2"
    arg_env(b)$where %is% "f2"
    arg_env(c)$where %is% "f1"
    arg_env(c)$where %is% "f1"
    envs(dots(...))[[1]]$where %is% "top"
  }
  where <- "top"
  f1(one, two)
})

test_that("arg_env error on forced promise", {
  f1 <- function(x) arg_env(x)
  f2 <- function(...) {
    list(...)
    f1(...)
  }
  expect_warning(f2(12+12), "forced")
  expect_equal(f2(124), emptyenv())
})

test_that("arg_value forced vs unforced promise", {

  f1 <- function(x, y, yy, yyy, yyyy) {
    force(y)
    z <- y
    expect_error(arg_value(x), "forced")
    expect_error(arg_value(yy), "forced")
    expect_error(arg_value(yyy), "forced")
    expect_error(arg_value(yyyy), "forced")
    force(yy)
    force(yyy)
    force(yyyy)
    arg_value(y) %is% 24
    arg_value(z) %is% 24
    arg_value(yy) %is% quote(x)
    arg_value(yyy) %is% quote(x+y)
    arg_value(yyyy) %is% list(1, 2, 3)
  }
  f1(13+13, 12+12, quote(x), quote(x+y), list(1, 2, 3))

})

test_that("weird primitive-dispatch promise behavior", {

  local({
    called <- FALSE
    c.cl <- function(...) {
      #not the original expression but its forced value!
      arg_expr(..1) %is% structure(list(1), class="cl")
      arg_env(..1) %is% parent.env(environment())
      arg_value(..1) %is% structure(list(1), class="cl")
      forced(arg(..1)) %is% TRUE
      is_forced(..1) %is% c(..1=TRUE)
      expr(arg(..1)) %is% arg_expr(..1)
      env(arg(..1)) %is% arg_env(..1)
      value(arg(..1)) %is% arg_value(..1)
      called %is% TRUE                 # even though!
      is_forced(..2) %is% c(..2=FALSE) # !!!!
      arg_expr(..2) %is% TRUE # it's the value at least
      is_forced(..3) %is% c(..3=FALSE)
      arg_expr(..3) %is% quote(dont+eval+me)
      # this would then be the workaround for c() over-evaluating?
      l <- lapply(dots_exprs(...),
             function(x)
               if (is.language(x)) call("quote", x) else unclass(x))
      do.call("c", l)
    }
    c(
      structure(list(1), class="cl"),
      (function() called <<- TRUE)(),
      quote(dont+eval+me))
  })

})

test_that("arg_expr should not force promise", {
  e <- environment()
  # Ugh, when testthat fails here it runs an as.list.environment on
  # the environment...
  f <- function(x) {
    expect_equal(arg_expr(x), quote(y+z))
    expect_identical(arg_env(x), e)
    expect_equal(arg_expr(x), quote(y+z))
    expect_identical(arg_env(x), e)
  }
  f(y+z)
})

test_that("arg_expr and arg_env fudge when could have been literal.", {
  # R will usually do a small optimization by not bothering to
  # construct promises for arguments that are a literal in the
  # source. Therefore we will have to allow these cases with arg_expr
  # and arg_env -- returning emptyenv when it is safe to do so.
  e <- environment()

  normal <- function(x) {
    list(arg_expr(x), arg_env(x))
  }
  expect_identical(normal(2000+3000), list(quote(2000+3000), environment()))

  # force optimization of literals
  f <- (function() normal(5000))
  f <- compiler::cmpfun(f)
  expect_identical(f(), list(5000, emptyenv()))
})

test_that("arg_expr and arg_env when expression is already forced.", {
  # But when the promise is forced?
  force_then_expr <- function(x) {
    force(x)
    arg_expr(x)
  }
  force_then_env <- function(x) {
    force(x)
    arg_env(x)
  }
  force_then_expr(2000+3000) %is% quote(2000+3000)
  expect_warning(force_then_env(2000+3000) %is% emptyenv(), "forced")
  force_then_expr(5000) %is% 5000 # not a promise
  force_then_env(5000) %is% emptyenv() #not a promise
  force_then_expr(5000L) %is% 5000L #not a promise
  force_then_env(5000L) %is% emptyenv() #not a promise
  force_then_expr(quote(x)) %is% quote(quote(x)) #language object
  expect_warning(force_then_env(quote(x)), "forced")
})

test_that("arg_expr and arg_env when expression is not a promise", {
  # and what about bindings that are not promises?
     nonpromise_expr <- function(x) {
       y <- x
       arg_expr(y)
     }
     nonpromise_env <- function(x) {
       y <- x
       arg_env(y)
     }
     nonpromise_expr(2000+3000) %is% 5000
     nonpromise_env("hello") %is% emptyenv()
     expect_warning(nonpromise_expr(c(1000, 2000)) %is% c(1000, 2000))
     nonpromise_env(c(1000, 2000)) %is% emptyenv()
     expect_warning(nonpromise_expr(quote(hello)) %is% quote(quote(hello)))
     expect_warning(nonpromise_env(quote(2+2)) %is% emptyenv())
})

test_that("is_promise and is_forced and is_literal and is_missing", {

  # a is source literal (when running from testthat/compiled function)
  # b is lazy unforced
  # c is lazy forced (as well as not function-mode)
  # d (not an argument) is not lazy (so forced) or could be literal
  # e is missing
  dbg <- function(f, f_,
                  a, b, c, e) {
    d <- (c)
    list(f(a, b, c, d, e),
         #f("a", "b", "c", "d", "e"), # not when compiled/installed!
         f_(c("a", "b", "c", "d", "e"), environment()),
         f_(alist(a, b, c, d, e), environment()),
         f_(dots(a=a, b=b, c=c, d=d, e=e)),
         c(a=f_(quo(a)), b=f_(quo(b)), c=f_(quo(c)), d=f_(quo(d)), e=f_(quo(e))))
    }

  both <- function(data, cmp) {
    ccll <- match.call()
    force(data)
    withCallingHandlers({
      expect_equal(data[[1]], cmp)
      expect_equal(data[[2]], cmp)
      expect_equal(data[[3]], cmp)
      expect_equal(data[[4]], cmp)
      expect_equal(data[[5]], cmp)
    }, error=function(e) {
      message(deparse(ccll))
      message(deparse(data[[1]]))
      message(deparse(data[[2]]))
      message(deparse(data[[3]]))
      message(deparse(data[[4]]))
      message(deparse(data[[5]]))
      message(deparse(cmp))
      e
    })
  }

  x <- function() {
    both(dbg(is_missing, is_missing_, 1000, 10+10, 10+10, ),
         c(a=FALSE, b=FALSE, c=FALSE, d=FALSE, e=TRUE))

    both(dbg(is_promise, is_promise_, 1000, 10+10, 10+10, ),
         # the first FALSE is TRUE when not compiled
         c(a=FALSE, b=TRUE, c=TRUE, d=FALSE, e=FALSE))

    both(dbg(is_forced, is_forced_, 1000, 10+10, 10+10, ),
         c(a=TRUE, b=FALSE, c=TRUE, d=TRUE, e=FALSE))

    both(dbg(is_literal, is_literal_, 1000, 10+10, 10+10, ),
         c(a=TRUE, b=FALSE, c=FALSE, d=TRUE, e=TRUE))
  }

  #force inlining literals
  x <- compiler::cmpfun(x)
  x()
})

test_that("unfound var", {
  expect_error(is_forced(dd5), "not found")
})

test_that("arg_get from promises", {
  set_arg(x, quo(4, environment()))
  is_promise(x) %is% c(x = TRUE)
  is_literal(x) %is% c(x = TRUE)
  is_forced(x) %is% c(x = FALSE)

  set_arg(x, quo_(c("a", "a"), environment()))
  is_promise(x) %is% c(x = TRUE)
  is_literal(x) %is% c(x = FALSE)
  is_forced(x) %is% c(x = FALSE)

  set_arg(x, forced_quo_(c("a", "a")))
  is_promise(x) %is% c(x = TRUE)
  is_literal(x) %is% c(x = FALSE)
  is_forced(x) %is% c(x = TRUE)

  set_arg(x, forced_quo_(c("a")))
  is_promise(x) %is% c(x = TRUE)
  is_literal(x) %is% c(x = TRUE)
  is_forced(x) %is% c(x = TRUE)

  # natural forced promise that has evaluated to missing.
  (function(x) {
    is_forced(x) %is% c(x = FALSE)
    is_promise(x) %is% c(x = TRUE)
    is_literal(x) %is% c(x = FALSE)
    is_missing(x) %is% c(x = FALSE)
    force(x);
    is_forced(x) %is% c(x = TRUE)
    is_promise(x) %is% c(x = TRUE)
    is_literal(x) %is% c(x = FALSE)
    is_missing(x) %is% c(x = TRUE)
    arg_value(x)
    expect_true(identical(arg_value(x), missing_value()))
    a <- arg(x)
    forced(a) %is% TRUE
    missing_(a) %is% TRUE
  })(quote(expr=))

  # and artificially:
  set_arg(x, forced_quo_(quote(expr=)))
  is_forced(x) %is% c(x = TRUE)
  is_promise(x) %is% c(x = TRUE)
  is_literal(x) %is% c(x = FALSE)
  is_missing(x) %is% c(x = TRUE)
  expect_true(identical(arg_value(x), missing_value()))

  a <- 5
  set_arg(x, force_(quo(a)))
  arg_expr(x) %is% quote(a)
  is_promise(x) %is% c(x = TRUE)
  is_literal(x) %is% c(x = FALSE)
  is_forced(x) %is% c(x = TRUE)
  is_missing(x) %is% c(x = FALSE)
  expect_warning(arg_env(x) %is% emptyenv(), "forced")

  set_arg(x, forced_quo_(identity))
  identical(arg_expr(x), identity)
  is_promise(x) %is% c(x = TRUE)
  is_literal(x) %is% c(x = FALSE)
  is_forced(x) %is% c(x = TRUE)
  is_missing(x) %is% c(x = FALSE)

  xx <- arg(x)
  forced(xx) %is% TRUE

  x <- quote(x)
  expect_warning(arg(x), "promise")
  set_arg(x, forced_quo_(c(3, 4)))
  expect_warning(arg_env(x), "forced")
  is_missing(x) %is% c(x = FALSE)

  x <- list(x)
  expect_warning(arg(x), "promise")
  expect_warning(arg(x), "promise")
  expect_warning(arg(x), "promise")

  dots2env(dots(a, b))
})


test_that("get_arg when var has a non-promise expression", {
  x <- quote(y)
  expect_warning(expect_identical(arg_env(x), emptyenv()), "promise")
  expect_warning(expect_identical(arg_expr(x), quote(quote(y))), "promise")
  is_literal(x) %is% c(x = FALSE)
  is_forced(x) %is% c(x = TRUE)
  is_missing(x) %is% c(x = FALSE)
})

test_that("empty arguments return missing value and empty environment", {
  f1 <- function(x) arg_env(x)
  f2 <- function(x) arg_expr(x)
  expect_identical(f1(), emptyenv())
  expect_identical(f2(), missing_value())
})

test_that("get dotslists of args direct", {
  f1 <- function(x, y) arg_list(x, b=y)
  d <- f1(x=one.arg, two.arg)
  names(d) %is% c("", "b")
  exprs(d) %is% alist(one.arg, b=two.arg)
  expect_identical(envs(d), list(environment(), b=environment()))
})

test_that("circular unwrap detection", {
  f <- function(a = b, b = c, c = a) {
    missing(a)
    is_missing(a)
  }
  f(c=1) %is% c(a = FALSE)
  expect_error(f())
})

test_that("args mirrors arg names by default", {
  f1 <- function(x, y) arg_list(x, y)
  d <- f1(x=one.arg, two.arg)
  names(d) %is% c("x", "y")
})

test_that("get dotslist of args by name", {
  f1 <- function(x, y) arg_list_(c("x", b="y"), environment())
  d <- f1(x=one.arg, two.arg)
  names(d) %is% c("", "b")
  exprs(d) %is% alist(one.arg, b=two.arg)
  expect_identical(envs(d), list(environment(), b=environment()))
})

test_that("get dotslists handles missing arguments", {
  f1 <- function(x, y) arg_list(x, b=y)
  d <- f1(, two.arg)
  missing_(exprs(d)) %is% c(TRUE, b=FALSE)
  expect_identical(envs(d), list(emptyenv(), b=environment()))
})

test_that("error when symbol is not bound", {
  f <- function(x) arg_env(yweqr)
  expect_error(f(), "not")
  f <- function(x) arg_expr(yqwer)
  expect_error(f(), "not")
  f <- function(x) args(yafsd)
  expect_error(f(), "not")
  f <- function(x) is_missing_("yyyyy", environment())
  expect_error(f(), "not")
  f <- function(x) is_missing_(quo(yyyyy))
  expect_error(f(), "not")
})

test_that("empty dots accessors return empty lists", {
  length(dots()) %is% 0
  length(dots_exprs()) %is% 0
  length(dots_envs()) %is% 0
  length(is_forced()) %is% 0
  length(is_missing()) %is% 0
  length(is_literal()) %is% 0
  length(is_promise()) %is% 0
  length(forced(arg_list())) %is% 0
  length(missing_(arg_list())) %is% 0
})

test_that("get args by character", {
  f <- function(...) {
    arg("...")
  }
  expect_error(f())

  ff <- function(a, b, what) {
    arg_(what)
  }
  expr(ff(foo, bar, "b")) %is% quote(bar)
  expect_error(ff(foo, bar, "..."))

  g <- function(a, b, ...) {
    arg_list_(c("a", "b", "..."), environment())
  }

  exprs(g(a=foo, c=baz, q=quux, b=bar)) %is%
    alist(a=foo, b = bar, c=baz, q=quux)

  ff <- function(x, y) arg_expr("y")
  ff(foo, bar) %is% quote(bar)
})


test_that("is_missing_ unwraps naturally created promise chains", {
  f <- function(a, b, c, d, e) {
    x <- is_missing_(c("a", "b", "c", "d", "e"), environment())
    y <- missing_(arg_list(a, b, c, d, e))
    z <- is_missing_(dots(a=a, b=b, c=c, d=d, e=e))
    x %is% y
    y %is% z
    x
  }
  g <- function(...) f(...)
  h <- function(A, B, C, D, E) g(A, B, C, D, E)
  x <- 10
  y <- missing_value()
  f( , 10, x, y, (y)) %is% c(a=TRUE, b=FALSE, c=FALSE, d=TRUE, e=FALSE);
  g( , 10, x, y, (y)) %is% c(a=TRUE, b=FALSE, c=FALSE, d=TRUE, e=FALSE);
  h( , 10, x, y, (y)) %is% c(a=TRUE, b=FALSE, c=FALSE, d=TRUE, e=FALSE);
})

test_that("is_missing_ unwraps explicitly created promise chains?", {
  a <- 1
  b <- missing_value()
  e0 <- dots2env(dots(w=b, x=a, y="no", z=))
  e1 <- dots2env(dots_(alist(a=w, b=x, c=y, d=z), e0))
  target <- c(a = TRUE, b = FALSE, c = FALSE, d = TRUE)
  is_missing_(c("a", "b", "c", "d"), e1) %is% target
  missing_(arg_list_(c("a", "b", "c", "d"), e1)) %is% target
  is_missing_(dots_(alist(a=a, b=b, c=c, d=d), e1)) %is% target
})

test_that("R_MissingValue bound directly", {
  x <- missing_value()
  (function(x) arg_env(x))() %is% emptyenv()
  expect_true(missing_( (function(x) arg_expr(x))() ))
  expect_true(missing_( (function(x) arg_list(x))() ))
  expect_true(is_literal(x))
})

test_that("missing_ matches R behavior with unwrapping", {
  delayedAssign("aa", )
  delayedAssign("bb", aa)
  delayedAssign("cc", asdlkhj)
  delayedAssign("dd", asdlkjh + alsiduj)

  f <- function(e,f,g,h) {
    cmp <- base::c(aa = TRUE, bb = TRUE, cc = FALSE, dd = FALSE,
                   e = missing(e), f = missing(f), g = missing(g), h = missing(h))
    is_missing.tst <- is_missing(aa, bb, cc, dd, e, f, g, h)
    missing_dots.tst <- missing_(dots(aa=aa, bb=bb, cc=cc, dd=dd, e=e, f=f, g=g, h=h))
    missing_args.tst <- missing_(arg_list(aa, bb, cc, dd, e, f, g, h))
    missing_quo.tst <- c(aa = missing_(quo(aa)),
                         bb = missing_(quo(bb)),
                         cc = missing_(quo(cc)),
                         dd = missing_(quo(dd)),
                         e = missing_(quo(e)),
                         f = missing_(quo(f)),
                         g = missing_(quo(g)),
                         h = missing_(quo(h)))
    cmp %is% is_missing.tst
    cmp %is% missing_dots.tst
    cmp %is% missing_args.tst
    cmp %is% missing_quo.tst
  }
  f(aa, bb, cc, dd)
})

test_that("getting promises handles DDVAL (..1 etc)", {
  brace <- function(...) {
    e <- arg_env(..1)
    f <- arg_expr(..2)
    do.call(`{`, list(...), envir=e)
  }

  x <- 1
  y <- quote(x+3)
  brace(x, y) %is% 4
})

test_that("ddvals", {
  x <- {function(...) arg_list(..1, ..2)}(a, b, c)
  exprs(x) %is% alist("..1" = a, "..2" = b)
})

all.identical <- function(list) {
  falsefalse <- environment() #unique sigil for this invocation
  ident <- function(x, y) if (identical(x, y)) x else falsefalse
  answer <- Reduce(ident, list)
  !identical(answer, falsefalse)
}

test_that("environment to dots", {
  capture <- function(a=plan, ..., z=thingy) {
    environment()
  }

  captured <- capture(one + two, f=four, five)
  d <- env2dots(captured)

  sort(names(d)) %is% c("", "a", "f", "z")
  names(d)[[order(names(d))[[1]]]] <- "anewname"
  (exprs(d)[sort(names(d))]
   %is% alist(a=one + two, anewname=five, f=four, z=thingy))
  expect_true(all.identical(envs(d)[c("anewname", "a", "f")]))
  expect_false(identical(envs(d)[["z"]], envs(d)[["a"]]))
})

test_that("dotlist to environment", {
  got <- FALSE
  id <- function(x) {
    got <<- TRUE;
    x
  }
  a <- dots(a=one, b=two, c=three, four, five, d=id(4))
  e <- dots2env(a)
  sort(ls(e)) %is% c("a", "b", "c", "d")
  got %is% FALSE
  e$d %is% 4
  got %is% TRUE
  substitute(b+c, e) %is% quote(two + three)
  substitute(list(...), e) %is% quote(list(four, five))

  # use existing, env, appending to ...
  test <- function(a, b, ...) {
    dots2env(dots(c=five, d=six, seven, eight), environment())
  }
  e2 <- test(one, two, three, four)
  substitute(list(a, b, c, d), e2) %is% quote(list(one, two, five, six))
  substitute(list(...), e2) %is% quote(list(three, four, seven, eight))
})

test_that("arg_expr doesn't lookup literals as if they were variables", {
  ## > (function(x) arg_expr(x))(1)
  ## Error in arg_expr_(arg_expr_(quote(name), environment()), env) (from getpromise.R#104) : 
  ##   Variable `1` was not found.
  (function(x) arg_expr(x))(1) %is% 1
})

test_that("arg_expr doesn't over-unwrap...", {
  f <- function(x) arg_expr(x)
  g <- function(x) f(x)
  h <- function(x) g(x)
  f(3) %is% quote(3)
  g(3) %is% quote(x)
  h(3) %is% quote(x)
})

test_that("locate var", {
  x <- function() {
    x <- 1
    y <- function() {
      y <- 1
      z <- function() {
        nx <- sort(names(locate(x)))
        nx_ <- sort(names(locate_(quote(x))))
        ny <- sort(names(locate(y)))
        nyf <- sort(names(locate(y, mode = "function")))
        ny_x <- sort(names(locate(y, env = locate(x))))
        nx %is% c("x", "y")
        nx_ %is% c("x", "y")
        ny %is% c("y", "z")
        nyf %is% c("x", "y")
        ny_x %is% c("x", "y")
      }
      z()
    }
    y()
  }
  x()
})

test_that("Locate var that is attached", {
  envz <- NULL
  envy <- NULL
  yyy <- function() {
    yyy <- 1
    envy <<- environment()
    zzz <- function() {
      zzz <- function() NULL
      envz <<- environment()
    }
    zzz()
  }
  yyy()

  expect_false(exists("zzz"))
  on.exit(detach("envz"), add=TRUE)
  attach(envz)
  # attach actually makes a new environment with just the imported symbols.
  expect_true(exists("zzz", envir=globalenv()))
  expect_false(exists("yyy", mode="numeric", envir=globalenv()))
  expect_true(exists("yyy", envir=envz, mode="numeric"))
  expect_identical(locate(zzz, env=globalenv())$z, envz$z)
})

test_that("locate forced and unforced", {

  wyz <- function() NULL
  loc <- "global"
  forced <- 0
  fx <- function(wyz) {
    loc <- "outer"
    function(mode) {
      loc <- "inner"
      locate_("wyz", environment(), mode=mode)
    }
  }
  fy <- fx({forced <- forced + 1})

  forced %is% 0
  fy("any")$loc %is% "outer"
  forced %is% 0
  fy("function")$loc %is% "global" # should force then skip over...
  forced %is% 1
  fy("function")$loc %is% "global"
  forced %is% 1

  wyz <- 4
  forced <- 0
  fy <- fx({forced <- forced+1; function(x) NULL})
  fy("any")$loc %is% "outer"
  forced %is% 0
  fy("function")$loc %is% "outer" # should force then skip over...
  forced %is% 1
  fy("function")$loc %is% "outer"
  forced %is% 1
})

test_that("locate list", {
  xe <- environment()
  x <- function() {
    ye <- environment()
    y <- function() {
      ze <- environment()
      z <- function() {
        exyz <- list(xe, ye, ze)
        expect_error(locate_(c("x", "y", "z")), "list")
        ff <- locate_(alist(x, y, z))
        ff %is% exyz
        ll <- locate_.list(c("x", "y", "z"))
        ll %is% exyz
      }
      z()
    }
    y()
  }
  x()
})


test_that("locate dots", {
  x <- function(...) {
    y <- function() {
      i <- locate_(quote(...), environment())
      k <- locate_("...", environment())
      j <- locate( (...) )
      expect_error(locate("...", mode = "function"))
      expect_identical(i, k)
      expect_identical(j, k)
      expect_false(identical(i, environment()))
    }
    y
  }
  f <- x(a, b, c)
  f()
})

test_that("locate function, forcing in process", {
  x <- function(...) {
    y <- function(x) {
      expect_false(is_forced(x))
      locate(x, mode="function")$x %is% xx
      expect_true(is_forced(x))
    }
    y(2+2)
  }
  xx <- x
  x()
})

test_that("unwrap quotation", {
  f <- function(r, q) {
    g(r, q)
  }
  g <- function(y, q) {
    h(y, q)
  }
  h <- function(z, q) {
    q(z)
  }

  f(1 + 2, function(x) unwrap(arg(x), TRUE)) %is% quo(1+2)
  expr(f(1 + 2, function(x) unwrap(arg(x), FALSE))) %is% quote(y)
  expr(f(1 + 2, function(x) unwrap(quo(x), FALSE))) %is% quote(z)
  expr(f(1 + 2, function(x) unwrap(quo(x), TRUE))) %is% quote(1+2)
  f((400), function(x) unwrap(quo(x), TRUE)) %is% quo((400))

  ff <- function() {
    f(400, function(x) unwrap(quo(x), TRUE))
  }
  ff <- compiler::cmpfun(ff)
  expr(ff()) %is% quote(r)
})

test_that("is_default", {
  g <- function() {
    f <- function(x = "this is my default") is_default(x)
    expect_true(f())
    expect_false(f("no"))
    expect_false(f("this is my default"))
  }

  h <- compiler::cmpfun(g)
  body(g) <- body(g) # strip compilation if any
  g()
  h()

  g <- function() {
    f <- function(x = two+two) is_default(x)
    expect_true(f())
    expect_false(f("no"))
    expect_false(f(two+two))
  }

  h <- compiler::cmpfun(g)
  body(g) <- body(g)
  g()
  h()
})

test_that("is_default et al in enclosed function", {

  f <-function() {
    g <- function(x = foo-bar) {
      h <- function() {
        c(is_default(x), is_promise(x), is_missing(x), is_forced(x), is_literal(x))
      }
      h()
    }
    g
  }
  f <- compiler::cmpfun(f)

  ff <- function() {
    g_inst <- f()
    g_inst()        %is% c(x=TRUE,  x=TRUE,  x=FALSE, x=FALSE, x=FALSE)
    g_inst(12)      %is% c(x=FALSE, x=TRUE, x=FALSE, x=FALSE, x=TRUE)
    g_inst(x=hello) %is% c(x=FALSE, x=TRUE,  x=FALSE, x=FALSE, x=FALSE)
  }
  ff <- compiler::cmpfun(ff)

  ff()
})