tests/testthat/test-runtime.R

In arl: Embedded Lisp Dialect

# Tests for CompiledRuntime (R/runtime.R): compiled code execution and helpers

# Helper installation tests
thin <- make_cran_thinner()

test_that("install_helpers() creates all required helpers", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()
  engine_field(eng, "compiled_runtime")$install_helpers(test_env)

  # Check all documented helpers exist
  expected_helpers <- c(
    ".__env", ".__quote", ".__true_p", ".__assign_pattern",
    ".__help", ".__subscript_call", "quasiquote",
    ".__delay", ".__defmacro", ".__macro_quasiquote",
    ".__module", ".__import"
  )

  for (helper in expected_helpers) {
    expect_true(exists(helper, envir = test_env, inherits = FALSE),
                info = sprintf("Helper %s should exist", helper))
  }
})

test_that("install_helpers() locks all bindings", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()
  engine_field(eng, "compiled_runtime")$install_helpers(test_env)

  helpers <- c(".__env", ".__quote", ".__true_p", "quasiquote")

  for (helper in helpers) {
    expect_true(bindingIsLocked(helper, test_env),
                info = sprintf("Helper %s should be locked", helper))
  }
})

test_that("install_helpers() skips already locked bindings", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()

  # Pre-lock a binding
  test_env$.__module <- TRUE
  lockBinding(".__module", test_env)

  # Should not error
  expect_silent(engine_field(eng, "compiled_runtime")$install_helpers(test_env))

  # Original value preserved
  expect_true(test_env$.__module)
})

test_that("install_helpers() sets arl_doc attributes", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()
  engine_field(eng, "compiled_runtime")$install_helpers(test_env)

  # Check a non-primitive function has arl_doc
  fn <- test_env$.__true_p
  expect_false(is.null(attr(fn, "arl_doc")))
  expect_true("description" %in% names(attr(fn, "arl_doc")))
  expect_true(grepl("INTERNAL:", attr(fn, "arl_doc")$description))
})

test_that(".__true_p helper handles truthiness correctly", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()
  engine_field(eng, "compiled_runtime")$install_helpers(test_env)

  true_p <- test_env$.__true_p

  # FALSE and NULL are falsy
  expect_false(true_p(FALSE))
  expect_false(true_p(NULL))

  # 0 is also falsy (follows R semantics)
  expect_false(true_p(0))

  # Everything else is truthy
  expect_true(true_p(TRUE))
  expect_true(true_p(""))
  expect_true(true_p(list()))
  expect_true(true_p(NA))
})

test_that(".__env helper points to current environment", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()
  engine_field(eng, "compiled_runtime")$install_helpers(test_env)

  expect_identical(test_env$.__env, test_env)
})

test_that(".__quote helper wraps base::quote", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()
  engine_field(eng, "compiled_runtime")$install_helpers(test_env)

  expect_identical(test_env$.__quote, base::quote)
})

# Module compilation tests
test_that("module_compiled() creates and registers module", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  engine_field(eng, "compiled_runtime")$module_compiled(
    "test-mod",
    c("foo"),
    FALSE,
    FALSE,
    list(quote(foo <- 42)),
    NULL,
    eng$get_env()
  )

  expect_true(engine_field(eng, "env")$module_registry$exists("test-mod"))
  entry <- engine_field(eng, "env")$module_registry$get("test-mod")
  expect_equal(entry$exports, c("foo"))
})

test_that("module_compiled() evaluates body expressions", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  engine_field(eng, "compiled_runtime")$module_compiled(
    "test-mod",
    c("foo", "bar"),
    FALSE,
    FALSE,
    list(quote(foo <- 42), quote(bar <- "test")),
    NULL,
    eng$get_env()
  )

  entry <- engine_field(eng, "env")$module_registry$get("test-mod")
  expect_equal(entry$env$foo, 42)
  expect_equal(entry$env$bar, "test")
})

test_that("module_compiled() handles export_all flag", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  engine_field(eng, "compiled_runtime")$module_compiled(
    "test-mod",
    character(0),
    TRUE,
    FALSE,
    list(quote(foo <- 42), quote(bar <- "test"), quote(baz <- 99)),
    NULL,
    eng$get_env()
  )

  entry <- engine_field(eng, "env")$module_registry$get("test-mod")
  exports <- entry$exports

  expect_true("foo" %in% exports)
  expect_true("bar" %in% exports)
  expect_true("baz" %in% exports)
  expect_false(".__module" %in% exports)  # Should be excluded
})

test_that("export-all excludes symbols imported from other modules", {
  thin()
  eng <- make_engine(load_prelude = FALSE)

  tmp_dir <- tempfile()
  dir.create(tmp_dir)
  on.exit(unlink(tmp_dir, recursive = TRUE), add = TRUE)

  # Provider module
  writeLines(c(
    "(module provider-mod",
    "  (export provided-fn)",
    "  (define provided-fn (lambda () 42)))"
  ), file.path(tmp_dir, "provider-mod.arl"))

  # Consumer module using export-all that imports provider-mod
  writeLines(c(
    "(module consumer",
    "  (export-all)",
    "  (import provider-mod :refer :all)",
    "  (define own-fn (lambda () (provided-fn))))"
  ), file.path(tmp_dir, "consumer.arl"))

  old_wd <- getwd()
  setwd(tmp_dir)
  on.exit(setwd(old_wd), add = TRUE)

  eng$load_file_in_env(file.path(tmp_dir, "consumer.arl"))

  entry <- engine_field(eng, "env")$module_registry$get("consumer")
  exports <- entry$exports

  # own-fn should be exported (defined in the module body)
  expect_true("own-fn" %in% exports)
  # provided-fn should NOT be re-exported (came from import)
  expect_false("provided-fn" %in% exports)
})

test_that("module_compiled() marks module environment", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  engine_field(eng, "compiled_runtime")$module_compiled(
    "test-mod",
    c("foo"),
    FALSE,
    FALSE,
    list(quote(foo <- 42)),
    NULL,
    eng$get_env()
  )

  entry <- engine_field(eng, "env")$module_registry$get("test-mod")
  expect_true(entry$env$.__module)
  expect_true(bindingIsLocked(".__module", entry$env))
})

test_that("module_compiled() creates path alias when src_file provided", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  tmp_file <- tempfile(fileext = ".arl")
  writeLines("(module test (export foo) (define foo 42))", tmp_file)
  on.exit(unlink(tmp_file))

  engine_field(eng, "compiled_runtime")$module_compiled(
    "test-mod",
    c("foo"),
    FALSE,
    FALSE,
    list(quote(foo <- 42)),
    tmp_file,
    eng$get_env()
  )

  # Should be accessible by both name and path
  abs_path <- arl:::normalize_path_absolute(tmp_file)
  expect_true(engine_field(eng, "env")$module_registry$exists("test-mod"))
  expect_true(engine_field(eng, "env")$module_registry$exists(abs_path))
})

test_that("module_compiled() installs helpers in module environment", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  engine_field(eng, "compiled_runtime")$module_compiled(
    "test-mod",
    c("foo"),
    FALSE,
    FALSE,
    list(quote(foo <- 42)),
    NULL,
    eng$get_env()
  )

  entry <- engine_field(eng, "env")$module_registry$get("test-mod")
  mod_env <- entry$env

  # Check that helpers are installed
  expect_true(exists(".__env", envir = mod_env, inherits = FALSE))
  expect_true(exists(".__quote", envir = mod_env, inherits = FALSE))
})

# Import handling tests
test_that("import_compiled() by module name loads stdlib module", {
  thin()
  eng <- make_engine()
  test_env <- new.env(parent = eng$get_env())

  # Import a simple stdlib module (types is one of the core modules)
  # Module names are passed as symbols in compiled code
  engine_field(eng, "compiled_runtime")$import_compiled(as.symbol("types"), test_env)

  # Check that some exported functions are now accessible (via proxy in parent chain)
  expect_true(exists("even?", envir = test_env, inherits = TRUE))
  expect_true(exists("odd?", envir = test_env, inherits = TRUE))
  expect_true(is.function(get("even?", envir = test_env)))
})

test_that("import_compiled() by module name as symbol", {
  thin()
  eng <- make_engine()
  test_env <- new.env(parent = eng$get_env())

  # Import using a symbol (which is how compiled code calls it)
  module_name_sym <- as.symbol("display")
  engine_field(eng, "compiled_runtime")$import_compiled(module_name_sym, test_env, refer = TRUE)

  # Check that some exported functions from display are now accessible
  expect_true(exists("string-concat", envir = test_env, inherits = TRUE))
  expect_true(is.function(get("string-concat", envir = test_env)))
})

test_that("import_compiled() errors on missing module", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env(parent = eng$get_env())

  expect_error(
    engine_field(eng, "compiled_runtime")$import_compiled("nonexistent-module-xyz", test_env),
    "Module not found"
  )
})

test_that("import_compiled() loads module only once", {
  thin()
  eng <- make_engine()
  test_env1 <- new.env(parent = eng$get_env())
  test_env2 <- new.env(parent = eng$get_env())

  # Import the same module twice into different environments (using symbols)
  engine_field(eng, "compiled_runtime")$import_compiled(as.symbol("functional"), test_env1, refer = TRUE)
  engine_field(eng, "compiled_runtime")$import_compiled(as.symbol("functional"), test_env2, refer = TRUE)

  # Both should get the same module (accessible via proxy)
  expect_true(exists("map", envir = test_env1, inherits = TRUE))
  expect_true(exists("map", envir = test_env2, inherits = TRUE))

  # The functions should be identical (same object from the shared registry,
  # accessed through active bindings that forward to the same module env)
  expect_identical(get("map", envir = test_env1), get("map", envir = test_env2))
})

test_that("import_compiled() by path loads and attaches exports", {
  thin()
  eng <- make_engine(load_prelude = FALSE)

  # Create a temporary .arl file with a simple module
  tmp_file <- tempfile(fileext = ".arl")
  writeLines(c(
    "(module test-import",
    "  (export test-value)",
    "  (define test-value 123))"
  ), tmp_file)
  on.exit(unlink(tmp_file))

  # Import using absolute path (strings are treated as paths by import_compiled)
  test_env <- new.env(parent = eng$get_env())
  engine_field(eng, "compiled_runtime")$import_compiled(tmp_file, test_env, refer = TRUE)

  # Check that the exported value is accessible via proxy
  expect_true(exists("test-value", envir = test_env, inherits = TRUE))
  expect_equal(get("test-value", envir = test_env), 123)
})

test_that("import_compiled() attaches exports to target environment", {
  thin()
  eng <- make_engine()
  test_env <- new.env(parent = eng$get_env())

  # Import a module (using symbol)
  engine_field(eng, "compiled_runtime")$import_compiled(as.symbol("types"), test_env, refer = TRUE)

  # Proxy-based imports are accessible via inheritance, not in ls()
  # Check specific exports from types module
  expect_true(exists("number?", envir = test_env, inherits = TRUE))
  expect_true(exists("string?", envir = test_env, inherits = TRUE))
  expect_true(exists("list?", envir = test_env, inherits = TRUE))

  # Verify these are actually functions
  expect_true(is.function(get("number?", envir = test_env)))
  expect_true(is.function(get("string?", envir = test_env)))
  expect_true(is.function(get("list?", envir = test_env)))
})

# Quasiquote tests
test_that("quasiquote_compiled() returns simple values unchanged", {
  thin()
  eng <- make_engine(load_prelude = FALSE)

  expect_equal(engine_field(eng, "compiled_runtime")$quasiquote_compiled(42, eng$get_env()), 42)
  expect_equal(engine_field(eng, "compiled_runtime")$quasiquote_compiled("test", eng$get_env()), "test")
  expect_equal(engine_field(eng, "compiled_runtime")$quasiquote_compiled(TRUE, eng$get_env()), TRUE)
})

test_that("quasiquote_compiled() handles unquote", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  env <- eng$get_env()
  env$x <- 42

  expr <- as.call(list(as.symbol("list"), as.call(list(as.symbol("unquote"), as.symbol("x")))))
  result <- engine_field(eng, "compiled_runtime")$quasiquote_compiled(expr, eng$get_env())

  # Result should be (list 42)
  expect_true(is.call(result))
  expect_equal(result[[2]], 42)
})

test_that("quasiquote_compiled() handles unquote-splicing", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  env <- eng$get_env()
  env$lst <- list(1, 2, 3)

  expr <- as.call(list(
    as.symbol("list"),
    as.call(list(as.symbol("unquote-splicing"), as.symbol("lst")))
  ))
  result <- engine_field(eng, "compiled_runtime")$quasiquote_compiled(expr, eng$get_env())

  # Result should be (list 1 2 3)
  expect_true(is.call(result))
  expect_equal(length(result), 4)  # list + 3 elements
  expect_equal(result[[2]], 1)
  expect_equal(result[[3]], 2)
  expect_equal(result[[4]], 3)
})

test_that("quasiquote_compiled() handles nested quasiquote", {
  thin()
  eng <- make_engine(load_prelude = FALSE)

  expr <- as.call(list(
    as.symbol("quasiquote"),
    as.call(list(as.symbol("unquote"), quote(x)))
  ))
  result <- engine_field(eng, "compiled_runtime")$quasiquote_compiled(expr, eng$get_env())

  # Nested quasiquote increases depth, so unquote is not evaluated
  expect_true(is.call(result))
  expect_equal(as.character(result[[1]]), "quasiquote")
})

test_that("quasiquote_compiled() errors on misplaced unquote-splicing", {
  thin()
  eng <- make_engine(load_prelude = FALSE)

  # unquote-splicing not in list context should error
  expr <- as.call(list(as.symbol("unquote-splicing"), as.symbol("x")))

  expect_error(
    engine_field(eng, "compiled_runtime")$quasiquote_compiled(expr, eng$get_env()),
    "can only appear in list context"
  )
})

test_that("quasiquote_compiled() requires exactly one argument", {
  thin()
  eng <- make_engine(load_prelude = FALSE)

  # quasiquote with wrong number of args
  expr <- as.call(list(as.symbol("quasiquote")))
  expect_error(
    engine_field(eng, "compiled_runtime")$quasiquote_compiled(expr, eng$get_env()),
    "requires exactly 1 argument"
  )
})

test_that("quasiquote_compiled() preserves quoted expressions", {
  thin()
  eng <- make_engine(load_prelude = FALSE)

  expr <- quote(quote(foo))
  result <- engine_field(eng, "compiled_runtime")$quasiquote_compiled(expr, eng$get_env())

  # Quoted expressions should pass through unchanged
  expect_equal(result, expr)
})

# Macro definition tests
test_that("defmacro_compiled() creates macro in macro registry", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- eng$get_env()

  engine_field(eng, "compiled_runtime")$defmacro_compiled(
    "test-macro",
    list(as.symbol("x")),
    quote(x),
    "Test macro",
    test_env
  )

  macro_registry <- engine_field(eng, "env")$macro_registry_env(test_env, create = FALSE)
  expect_true(exists("test-macro", envir = macro_registry, inherits = FALSE))
})

test_that("defmacro_compiled() handles begin body", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- eng$get_env()

  body <- as.call(list(as.symbol("begin"), quote(x), quote(y)))

  engine_field(eng, "compiled_runtime")$defmacro_compiled(
    "test-macro",
    list(as.symbol("x"), as.symbol("y")),
    body,
    NULL,
    test_env
  )

  macro_registry <- engine_field(eng, "env")$macro_registry_env(test_env, create = FALSE)
  expect_true(exists("test-macro", envir = macro_registry, inherits = FALSE))
})

test_that("defmacro_compiled() handles non-begin body", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- eng$get_env()

  engine_field(eng, "compiled_runtime")$defmacro_compiled(
    "simple-macro",
    list(as.symbol("x")),
    quote(x),
    NULL,
    test_env
  )

  macro_registry <- engine_field(eng, "env")$macro_registry_env(test_env, create = FALSE)
  expect_true(exists("simple-macro", envir = macro_registry, inherits = FALSE))
})

test_that("defmacro_compiled() preserves doc list", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- eng$get_env()

  engine_field(eng, "compiled_runtime")$defmacro_compiled(
    "documented-macro",
    list(as.symbol("x")),
    quote(x),
    list(
      description = "This is a documented macro",
      examples = "(documented-macro 1)"
    ),
    test_env
  )

  macro_registry <- engine_field(eng, "env")$macro_registry_env(test_env, create = FALSE)
  macro_fn <- macro_registry$`documented-macro`

  doc <- attr(macro_fn, "arl_doc")
  expect_false(is.null(doc))
  expect_equal(doc$description, "This is a documented macro")
  expect_equal(doc$examples, "(documented-macro 1)")
})

# Promise/delay tests
test_that("promise_new_compiled() creates Promise", {
  thin()
  eng <- make_engine(load_prelude = FALSE)

  promise <- engine_field(eng, "compiled_runtime")$promise_new_compiled(quote(1 + 1), eng$get_env())

  expect_true(inherits(promise, "ArlPromise"))
})

test_that("promise_new_compiled() delays evaluation", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  env <- eng$get_env()
  env$side_effect <- 0

  promise <- engine_field(eng, "compiled_runtime")$promise_new_compiled(
    quote(side_effect <- side_effect + 1),
    eng$get_env()
  )

  # Side effect should not have happened yet
  expect_equal(engine_field(eng, "env")$env$side_effect, 0)
})

test_that("promise_new_compiled() evaluates when forced", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  env <- eng$get_env()
  env$x <- 42

  promise <- engine_field(eng, "compiled_runtime")$promise_new_compiled(quote(x * 2), env = env)

  result <- promise$value()
  expect_equal(result, 84)
})

test_that("promise_new_compiled() caches result", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  env <- eng$get_env()
  env$counter <- 0

  promise <- engine_field(eng, "compiled_runtime")$promise_new_compiled(
    quote({ counter <- counter + 1; counter }),
    env = env
  )

  result1 <- promise$value()
  result2 <- promise$value()

  # Should only evaluate once
  expect_equal(result1, 1)
  expect_equal(result2, 1)
  expect_equal(env$counter, 1)
})

# eval_compiled tests
test_that("eval_compiled() evaluates compiled expressions", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()

  result <- engine_field(eng, "compiled_runtime")$eval_compiled(quote(1 + 1), test_env)

  expect_equal(result, 2)
})

test_that("eval_compiled() installs helpers", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()

  engine_field(eng, "compiled_runtime")$eval_compiled(quote(NULL), test_env)

  # Helpers should be installed
  expect_true(exists(".__env", envir = test_env, inherits = FALSE))
})

test_that("eval_compiled() handles visibility", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()

  # Visible result
  result1 <- withVisible(engine_field(eng, "compiled_runtime")$eval_compiled(quote(42), test_env))
  expect_true(result1$visible)

  # Invisible result
  result2 <- withVisible(engine_field(eng, "compiled_runtime")$eval_compiled(quote(invisible(42)), test_env))
  expect_false(result2$visible)
})

test_that("eval_compiled() manages environment stack", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()

  # Stack should be empty initially
  initial_stack_len <- length(engine_field(eng, "env")$env_stack)

  result <- engine_field(eng, "compiled_runtime")$eval_compiled(quote(42), test_env)

  # Stack should be back to initial state after evaluation
  final_stack_len <- length(engine_field(eng, "env")$env_stack)
  expect_equal(final_stack_len, initial_stack_len)
})

# subscript_call_compiled tests
test_that("subscript_call_compiled() handles $ operator", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()
  obj <- list(foo = 42)

  result <- engine_field(eng, "compiled_runtime")$subscript_call_compiled("$", list(obj, "foo"), test_env)

  expect_equal(result, 42)
})

test_that("subscript_call_compiled() handles [ operator", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()
  vec <- c(1, 2, 3)

  result <- engine_field(eng, "compiled_runtime")$subscript_call_compiled("[", list(vec, 2), test_env)

  expect_equal(result, 2)
})

test_that("subscript_call_compiled() handles [[ operator", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()
  lst <- list(a = 10, b = 20)

  result <- engine_field(eng, "compiled_runtime")$subscript_call_compiled("[[", list(lst, "b"), test_env)

  expect_equal(result, 20)
})

test_that("subscript_call_compiled() requires valid operator name", {
  thin()
  eng <- make_engine(load_prelude = FALSE)
  test_env <- new.env()

  expect_error(
    engine_field(eng, "compiled_runtime")$subscript_call_compiled(123, list(), test_env),
    "must be a single string"
  )
})

# ============================================================================
# Env$assign (lexical scoping)
# ============================================================================

test_that("Env$assign creates binding in current environment (lexical scoping)", {
  thin()
  root <- new.env(parent = emptyenv())
  root$x <- 1
  child <- new.env(parent = root)

  # assign (used by define) should create a NEW binding in the current env,
  # not modify the parent env - this is proper lexical scoping
  Env$new(child)$assign("x", 2)
  expect_equal(root$x, 1)  # parent unchanged
  expect_true(exists("x", envir = child, inherits = FALSE))  # new binding in child
  expect_equal(child$x, 2)  # child has value 2
})

test_that("Env$assign falls back to current env when binding not found", {
  thin()
  parent_env <- new.env(parent = emptyenv())
  child <- new.env(parent = parent_env)

  Env$new(child)$assign("z", 3)
  expect_true(exists("z", envir = child, inherits = FALSE))
  expect_false(exists("z", envir = parent_env, inherits = FALSE))
})