test_that("promises are created", {
  env <- child_env(NULL)

  env_bind_lazy(env, foo = bar <- "bar")
  expect_false(env_has(current_env(), "bar"))

  force(env$foo)
  expect_true(env_has(current_env(), "bar"))

  env_bind_lazy(env, stop = stop("forced"))
  expect_error(env$stop, "forced")
})

test_that("env_bind_active() creates active bindings", {
  env <- env()
  env_bind_active(env, a = function() "foo")
  expect_identical(env$a, "foo")
  expect_identical(env$a, "foo")
})

test_that("env_poke() returns previous value", {
  env <- env(env(empty_env(), bar = "bar"))
  expect_identical(env_poke(env, "foo", "foo"), zap())
  expect_identical(env_poke(env, "foo", "FOO"), "foo")
  expect_identical(env_poke(env, "bar", "foo", inherit = TRUE), "bar")
})

test_that("env_poke() creates binding if `create` is TRUE", {
  env <- new_environment()
  env_poke(env, "foo", "foo")
  expect_identical(env_get(env, "foo"), "foo")

  expect_error(
    env_poke(env, "bar", "BAR", create = FALSE),
    "Can't find existing binding"
  )
  env_poke(env, "foo", "FOO", create = FALSE)
  expect_identical(env_get(env, "foo"), "FOO")
})

test_that("env_poke() inherits from parents if `inherit` is TRUE", {
  env <- child_env(new_environment(), foo = "foo")
  env <- child_env(env)

  env_has(env, "foo")
  env_has(env, "foo", TRUE)

  env_poke(env, "foo", "FOO", inherit = TRUE, create = FALSE)
  expect_identical(env_get(env_parent(env), "foo", inherit = FALSE), "FOO")

  expect_error(
    env_poke(env, "bar", "bar", inherit = TRUE, create = FALSE),
    "Can't find existing binding"
  )
  expect_error(
    env_poke(env, "bar", "bar", inherit = TRUE),
    "Can't find existing binding"
  )

  env_poke(env, "bar", "bar", inherit = TRUE, create = TRUE)
  expect_identical(env_get(env, "bar"), "bar")
})

test_that("env_get() evaluates promises and active bindings", {
  e <- env()
  env_bind_lazy(e, x = 1)
  env_bind_active(e, y = function() 2)

  expect_equal(env_get(e, "x"), 1)
  expect_equal(env_get(e, "y"), 2)
})

test_that("env_get_list() retrieves multiple bindings", {
  env <- env(foo = 1L, bar = 2L)
  expect_identical(env_get_list(env, c("foo", "bar")), list(foo = 1L, bar = 2L))

  baz <- 0L
  expect_error(env_get_list(env, "baz"), "Can't find")
  expect_identical(
    env_get_list(env, c("foo", "baz"), inherit = TRUE),
    list(foo = 1L, baz = 0L)
  )
})

test_that("local_bindings binds temporarily", {
  env <- env(foo = "foo", bar = "bar")

  local({
    old <- local_bindings(.env = env, foo = "FOO", bar = "BAR", baz = "BAZ")
    expect_identical(old, list3(foo = "foo", bar = "bar", baz = zap()))
    temp_bindings <- env_get_list(env, c("foo", "bar", "baz"))
    expect_identical(temp_bindings, list(foo = "FOO", bar = "BAR", baz = "BAZ"))
  })

  bindings <- env_get_list(env, c("foo", "bar"))
  expect_identical(bindings, list(foo = "foo", bar = "bar"))
  expect_false(env_has(env, "baz"))
})

test_that("local_bindings() restores in correct order", {
  foo <- "start"

  local({
    local_bindings(foo = "foo")
    expect_identical(foo, "foo")

    local_bindings(foo = "bar")
    expect_identical(foo, "bar")
  })

  expect_identical(foo, "start")
})

test_that("with_bindings() evaluates with temporary bindings", {
  foo <- "foo"
  baz <- "baz"
  expect_identical(with_bindings(paste(foo, baz), foo = "FOO"), "FOO baz")
  expect_identical(foo, "foo")
})

test_that("env_unbind() with `inherits = TRUE` only removes first match", {
  env <- env(foo = "foo")
  child <- env(env, foo = "foo")

  env_unbind(child, "foo", inherit = TRUE)
  expect_false(env_has(child, "foo"))
  expect_true(env_has(env, "foo"))
})

test_that("env_bind() requires named elements", {
  expect_error(env_bind(env(), 1), "some elements are not named")
  expect_error(env_bind(env(), !!!list(1)), "some elements are not named")
})

test_that("env_bind() works with empty unnamed lists", {
  expect_no_error(env_bind(env()))
  expect_no_error(env_bind(env(), !!!list()))
})

test_that("env_names() unserialises unicode", {
  env <- env(`<U+5E78><U+798F>` = "foo")
  expect_identical(env_names(env), "\u5E78\u798F")
})

test_that("env_has() returns a named vector", {
  expect_identical(
    env_has(env(a = TRUE), c("a", "b", "c")),
    c(a = TRUE, b = FALSE, c = FALSE)
  )
})

test_that("env_unbind() doesn't warn if binding doesn't exist (#177)", {
  expect_no_warning(env_unbind(env(), c("foo", "bar")))
})

test_that("env_get() and env_get_list() accept default value", {
  env <- env(a = 1)

  expect_error(env_get(env, "b"), "Can't find")
  expect_error(env_get_list(env, "b"), "Can't find")

  expect_identical(env_get(env, "b", default = "foo"), "foo")
  expect_identical(
    env_get_list(env, c("a", "b"), default = "foo"),
    list(a = 1, b = "foo")
  )
})

test_that("env_get() without default fails", {
  expect_snapshot(error = TRUE, cnd_class = TRUE, {
    env_get(env(), "foobar")
    env_get_list(env(), "foobar")
  })

  fn <- function(env, default) env_get(env, "_foobar", default = default)
  expect_error(fn(env()), "Can't find")
})

test_that("env_get() evaluates `default` lazily", {
  expect_equal(env_get(env(a = 1), "a", default = stop("tilt")), 1)
})

test_that("env_bind_active() uses as_function()", {
  env_bind_active(current_env(), foo = ~ 2 + 3)
  expect_identical(foo, 5)
})

test_that("env_bind_active() and env_bind_lazy() redefine bindings", {
  env <- env(a = 1, b = 2)
  env_bind_active(env, a = ~"foo")
  env_bind_lazy(env, b = "bar")
  expect_identical(c(env$a, env$b), c("foo", "bar"))
})

test_that("binding predicates detect special bindings", {
  env <- env()
  env_bind_active(env, a = ~ toupper("foo"))
  env_bind_lazy(env, b = toupper("foo"))
  env_bind(env, c = toupper("foo"), d = "irrelevant")

  expect_identical(
    env_binding_are_active(env, c("a", "b", "c")),
    c(a = TRUE, b = FALSE, c = FALSE)
  )
  expect_identical(
    env_binding_are_lazy(env, c("a", "b", "c")),
    c(a = FALSE, b = TRUE, c = FALSE)
  )

  force(env$b)
  expect_identical(
    env_binding_are_lazy(env, c("a", "b", "c")),
    c(a = FALSE, b = FALSE, c = FALSE)
  )

  env <- env(a = 1, b = 2)
  expect_identical(env_binding_are_active(env), c(a = FALSE, b = FALSE))
  expect_identical(env_binding_are_lazy(env), c(a = FALSE, b = FALSE))
})

test_that("applies predicates to all bindings by default", {
  env <- env()
  env_bind_active(env, a = ~ toupper("foo"))
  env_bind_lazy(env, b = toupper("foo"))
  env_bind(env, c = toupper("foo"))
  expect_identical(
    env_binding_are_active(env),
    c(a = TRUE, b = FALSE, c = FALSE)
  )
  expect_identical(env_binding_are_lazy(env), c(a = FALSE, b = TRUE, c = FALSE))
})

test_that("env_binding_are_active() doesn't force promises", {
  env <- env()
  env_bind_lazy(env, foo = stop("kaboom"))
  expect_no_error(env_binding_are_active(env))
  expect_identical(env_binding_are_lazy(env), lgl(foo = TRUE))
  expect_identical(env_binding_are_lazy(env), lgl(foo = TRUE))
})

test_that("env_binding_are_active() doesn't trigger active bindings (#1376)", {
  env <- env()
  env_bind_active(env, foo = ~ stop("kaboom"))
  expect_no_error(env_binding_are_active(env))
  expect_identical(env_binding_are_active(env), lgl(foo = TRUE))
  expect_identical(env_binding_are_lazy(env), lgl(foo = FALSE))
})

test_that("env_binding_type_sum() detects types", {
  env <- env()
  env_bind_active(env, a = ~"foo")
  env_bind_lazy(env, b = identity("foo"))
  env_bind(env, c = "foo", d = 1L, e = 2)

  expect_error(env_binding_type_sum(env, 1L), "must be a character vector")

  types <- c(a = "active", b = "lazy", c = "chr", d = "int", e = "dbl")
  expect_identical(env_binding_type_sum(env), types)
})

test_that("can lock and unlock bindings", {
  env <- env(a = "A", b = "B")
  expect_identical(env_binding_are_locked(env), lgl(a = FALSE, b = FALSE))

  expect_identical(env_binding_lock(env, "a"), lgl(a = FALSE))

  locked <- env_binding_are_locked(env)
  expect_identical(locked, lgl(a = TRUE, b = FALSE))

  expect_identical(env_binding_unlock(env), locked)
  expect_identical(env_binding_are_locked(env), lgl(a = FALSE, b = FALSE))
})

test_that("can pluck missing arg from environment", {
  env <- env(x = missing_arg())
  expect_identical(env_get(env, "x"), missing_arg())
  expect_identical(env_get_list(env, "x"), list(x = missing_arg()))

  skip("Failing")
  child <- env(env)
  env_get(child, "x", inherit = TRUE)
})

test_that("can call local_bindings() and with_bindings() without arguments", {
  expect_no_error(local_bindings())
  expect_no_error(with_bindings("foo"))
})

test_that("can bind missing args", {
  e <- env()

  expect_no_error(env_bind(e, foo = ))
  expect_identical(e$foo, missing_arg())

  args <- list(bar = expr(), baz = expr())
  expect_no_error(env_bind(e, !!!args))
  expect_identical(env_get_list(e, c("bar", "baz")), args)
})

test_that("can remove bindings by supplying zaps", {
  empty <- env()
  expect_no_error(env_bind(empty, foo = zap()))

  env <- env(foo = "foo", bar = "bar")
  env_bind(env, foo = zap(), bar = zap())
  expect_identical(env_names(env), chr())

  env <- env(foo = "foo", bar = "bar")
  env_bind(env, !!!rep_named(c("foo", "bar"), list(zap())))
  expect_identical(env_names(env), chr())

  env <- env(foo = "foo", bar = "bar")
  env_bind_active(env, foo = zap())
  expect_identical(env_names(env), "bar")

  env_bind_lazy(env, bar = !!zap())
  expect_identical(env_names(env), chr())

  env_bind(current_env(), !!!rep_named(c("foo", "bar"), list(zap())))
})

test_that("env_bind_lazy() supports quosures", {
  env <- env()
  foo <- "foo"

  quo <- local({
    foo <- "quux"
    quo(paste(foo, "bar"))
  })

  env_bind_lazy(env, x = !!quo)
  expect_identical(env$x, "quux bar")

  foo <- "FOO"
  expect_identical(env$x, "quux bar")
})

test_that("env_bind_active() supports quosures", {
  env <- env()
  foo <- "foo"

  env_bind_active(env, x = quo(paste(foo, "bar")))
  expect_identical(env$x, "foo bar")

  foo <- "FOO"
  expect_identical(env$x, "FOO bar")
})

test_that("env_bind_lazy() supports nested quosures", {
  env <- env()

  quo <- local({
    lhs <- "quux"
    rhs <- local({
      rhs <- "hunoz"
      quo(rhs)
    })
    quo(paste(lhs, !!rhs))
  })

  env_bind_lazy(env, x = !!quo)
  expect_identical(env$x, "quux hunoz")
})

test_that("env_bind_active() supports nested quosures", {
  env <- env()

  quo <- local({
    lhs <- "quux"
    rhs <- local({
      rhs <- "hunoz"
      quo(rhs)
    })
    quo(paste(lhs, !!rhs))
  })

  env_bind_active(env, x = quo)
  expect_identical(env$x, "quux hunoz")

  quo <- quo_set_env(quo, env(lhs = "QUUX"))
  env_bind_active(env, x = quo)
  expect_identical(env$x, "QUUX hunoz")
})

test_that("env_get() survives native encoding", {
  with_non_utf8_locale({
    e <- env(empty_env())
    funs <- list(function() 42)
    native <- enc2native("\u4e2d")
    s <- as_string(native)

    names(funs) <- native
    env_bind_active(e, !!!funs)
    names(funs) <- s
    env_bind_active(e, !!!funs)
    expect_equal(e[[s]], 42)
    expect_equal(e[[native]], 42)
  })
})

test_that("`env_binding_are_lazy()` type-checks `env` (#923)", {
  expect_error(env_binding_are_lazy("a", "b"), "must be an environment")
})

test_that("env_poke() zaps (#1012)", {
  env <- env(zapzap = 1)
  env_poke(env, "zapzap", zap())
  expect_false(env_has(env, "zapzap"))

  env <- env(env(zapzap = 1))
  env_poke(env, "zapzap", zap())
  expect_false(env_has(env, "zapzap"))
  expect_true(env_has(env, "zapzap", inherit = TRUE))

  env_poke(env, "zapzap", zap(), inherit = TRUE)
  expect_false(env_has(env, "zapzap", inherit = TRUE))
})

test_that("env_poke() doesn't warn when unrepresentable characters are serialised", {
  if (is_windows && getRversion() < "4.2") {
    return()
  }

  with_non_utf8_locale({
    e <- env(empty_env())
    nm <- get_alien_lang_string()

    expect_no_warning(env_poke(e, nm, NA))

    skip_if_no_utf8_marker()
    nms <- env_names(e)
    expect_equal(Encoding(nms), "UTF-8")
  })
})

test_that("new_environment() supports non-list data", {
  env <- new_environment(c(a = 1))
  expect_equal(typeof(env), "environment")
  expect_equal(env$a, 1)
})

test_that("`%<~%` assigns lazily", {
  x %<~% 1
  expect_equal(x, 1)

  x %<~% stop("foo")
  expect_error(x, "foo")

  # Can reassign over a throwing promise
  x %<~% stop("bar")
  expect_error(x, "bar")
})

test_that("env_get() and env_get_list() handle `last` argument", {
  top <- env(foo = "foo")
  mid <- env(top)
  low <- env(mid)

  expect_equal(
    env_get(low, "foo", inherit = TRUE, default = "null"),
    "foo"
  )
  expect_equal(
    env_get(low, "foo", inherit = TRUE, last = mid, default = "null"),
    "null"
  )
  expect_equal(
    env_get(low, "foo", inherit = TRUE, last = low, default = "null"),
    "null"
  )

  expect_equal(
    env_get_list(low, "foo", inherit = TRUE, default = "null"),
    list(foo = "foo")
  )
  expect_equal(
    env_get_list(low, "foo", inherit = TRUE, last = mid, default = "null"),
    list(foo = "null")
  )
  expect_equal(
    env_get_list(low, "foo", inherit = TRUE, last = low, default = "null"),
    list(foo = "null")
  )
})

test_that("env_cache() works (#1081)", {
  e <- env(a = "foo")

  # Returns existing binding
  expect_equal(
    env_cache(e, "a", "default"),
    "foo"
  )

  # Creates a `b` binding and returns its default value
  expect_equal(
    env_cache(e, "b", "default"),
    "default"
  )

  # Now `b` is defined
  expect_equal(e$b, "default")
  expect_equal(e$a, "foo")
})

test_that("env_get(last = ) checks for empty env when last is disconnected (#1208)", {
  out <- env_get(
    emptyenv(),
    "_foobar",
    default = "_fallback",
    inherit = TRUE,
    last = globalenv()
  )
  expect_equal(out, "_fallback")
})


# Promise chain unwrapping ------------------------------------------------
# `...` expansion via `promiseArgs()` wraps each dot element with
# `mkPROMISE(CAR(h), rho)`, creating a promise chain where PRCODE of
# the outer promise is the original inner PROMSXP.

test_that("env_binding_type() unwraps chains to detect forced state", {
  g <- function(x) env_binding_type(environment(), as.name("x"))
  f <- function(...) { force(..1); g(...) }
  expect_equal(f(1 + 1), "forced")
})

test_that("env_binding_type() unwraps chains to detect delayed state", {
  g <- function(x) env_binding_type(environment(), as.name("x"))
  f <- function(...) g(...)
  expect_equal(f(1 + 1), "delayed")
})

test_that("env_binding_delayed_expr() unwraps chains to the outermost expression", {
  g <- function(x) env_binding_delayed_expr(environment(), as.name("x"))
  f <- function(...) g(...)
  expect_equal(f(x + y), quote(x + y))
})

test_that("env_binding_delayed_env() unwraps chains to the outermost environment", {
  g <- function(x) env_binding_delayed_env(environment(), as.name("x"))
  f <- function(...) g(...)

  caller_env <- current_env()
  result <- f(x + y)
  expect_identical(result, caller_env)
})

test_that("env_binding_forced_expr() unwraps chains to detect forced promise", {
  g <- function(x) { force(x); env_binding_forced_expr(environment(), as.name("x")) }
  f <- function(...) g(...)
  foo <- 1
  expect_equal(f(foo), quote(foo))
})

test_that("env_binding_forced_expr() unwraps when outer wrapper is forced", {
  g <- function(x) env_binding_forced_expr(environment(), as.name("x"))
  f <- function(...) { force(..1); g(...) }
  foo <- 1
  expect_equal(f(foo), quote(foo))
})

test_that("env_binding_delayed_expr() errors on forced chain", {
  g <- function(x) env_binding_delayed_expr(environment(), as.name("x"))
  f <- function(...) { force(..1); g(...) }
  expect_error(f(1 + 1), "not a delayed binding")
})

test_that("env_binding_delayed_env() errors on forced chain", {
  g <- function(x) env_binding_delayed_env(environment(), as.name("x"))
  f <- function(...) { force(..1); g(...) }
  expect_error(f(1 + 1), "not a delayed binding")
})

test_that("deeper `...` chains unwrap correctly for bindings", {
  g <- function(x) env_binding_type(environment(), as.name("x"))
  mid <- function(...) g(...)
  f <- function(...) { force(..1); mid(...) }
  expect_equal(f(1 + 1), "forced")
})

test_that("deeper `...` chains unwrap correctly for delayed accessors", {
  get_expr <- function(x) env_binding_delayed_expr(environment(), as.name("x"))
  get_env <- function(x) env_binding_delayed_env(environment(), as.name("x"))
  mid_expr <- function(...) get_expr(...)
  deep_expr <- function(...) mid_expr(...)
  mid_env <- function(...) get_env(...)
  deep_env <- function(...) mid_env(...)
  e <- current_env()
  expect_equal(deep_expr(x + y), quote(x + y))
  expect_identical(deep_env(x + y), e)
})

test_that("deeper `...` chains unwrap correctly for forced accessor", {
  inner <- function(x) env_binding_forced_expr(environment(), as.name("x"))
  mid <- function(...) inner(...)
  f <- function(...) { force(..1); mid(...) }
  foo <- 1
  expect_equal(f(foo), quote(foo))
})


# env_syms ----------------------------------------------------------------

test_that("env_syms() returns list of symbols", {
  e <- env(a = 1, b = 2, c = 3, `.__hidden__.` = 4)
  syms <- env_syms(e)

  expect_type(syms, "list")
  expect_length(syms, 4L)
  expect_true(all(map_lgl(syms, is_symbol)))
  expect_setequal(
    map_chr(syms, as_string),
    c("a", "b", "c", ".__hidden__.")
  )
})

test_that("env_syms() returns empty list for empty env", {
  expect_identical(env_syms(env()), list())
})

test_that("env_syms() validates input", {
  expect_error(env_syms(1), "environment")
})
