tests/testthat/test-stdlib-control.R

In arl: Embedded Lisp Dialect

# Comprehensive control flow tests: when, unless, cond, case, and, or, not, xor, try

engine <- make_engine()

# ============================================================================
# NEW: Comprehensive control flow macro tests
# ============================================================================

thin <- make_cran_thinner()

test_that("when evaluates body when test is truthy", {
  thin()
  env <- new.env(parent = baseenv())
  toplevel_env(engine, env = env)
  import_stdlib_modules(engine, c("control"), env = env)

  # Truthy test
  result <- engine$eval(engine$read("(when #t 42)")[[1]], env = env)
  expect_equal(result, 42)

  # Falsy test returns #nil
  result <- engine$eval(engine$read("(when #f 42)")[[1]], env = env)
  expect_null(result)

  # Truthy value (non-boolean)
  result <- engine$eval(engine$read("(when 1 'success)")[[1]], env = env)
  expect_equal(as.character(result), "success")

  # With side effects
  engine$eval(engine$read("(define x 0)")[[1]], env = env)
  engine$eval(engine$read("(when #t (set! x 10))")[[1]], env = env)
  expect_equal(get("x", envir = env), 10)

  # False condition - no side effects
  engine$eval(engine$read("(set! x 0)")[[1]], env = env)
  engine$eval(engine$read("(when #f (set! x 20))")[[1]], env = env)
  expect_equal(get("x", envir = env), 0)

  # Multiple body forms
  result <- engine$eval(
    engine$read("(when #t (define x 5) (+ x 10))")[[1]], env = env)
  expect_equal(result, 15)
})

test_that("unless evaluates body when test is falsy", {
  thin()
  env <- new.env(parent = baseenv())
  toplevel_env(engine, env = env)
  import_stdlib_modules(engine, c("control"), env = env)

  # Falsy test
  result <- engine$eval(engine$read("(unless #f 42)")[[1]], env = env)
  expect_equal(result, 42)

  # Truthy test returns #nil
  result <- engine$eval(engine$read("(unless #t 42)")[[1]], env = env)
  expect_null(result)

  # Falsy value (non-boolean)
  result <- engine$eval(engine$read("(unless #f 'success)")[[1]], env = env)
  expect_equal(as.character(result), "success")

  # With side effects
  engine$eval(engine$read("(define x 0)")[[1]], env = env)
  engine$eval(engine$read("(unless #f (set! x 10))")[[1]], env = env)
  expect_equal(get("x", envir = env), 10)

  # True condition - no side effects
  engine$eval(engine$read("(set! x 0)")[[1]], env = env)
  engine$eval(engine$read("(unless #t (set! x 20))")[[1]], env = env)
  expect_equal(get("x", envir = env), 0)

  # Multiple body forms
  result <- engine$eval(
    engine$read("(unless #f (define x 5) (+ x 10))")[[1]], env = env)
  expect_equal(result, 15)
})

test_that("cond selects first matching clause", {
  thin()
  env <- new.env(parent = baseenv())
  toplevel_env(engine, env = env)
  import_stdlib_modules(engine, c("control"), env = env)

  # First clause matches
  result <- engine$eval(
    engine$read("(cond (#t 'first) (#t 'second))")[[1]], env = env)
  expect_equal(as.character(result), "first")

  # Second clause matches
  result <- engine$eval(
    engine$read("(cond (#f 'first) (#t 'second))")[[1]], env = env)
  expect_equal(as.character(result), "second")

  # Else clause
  result <- engine$eval(
    engine$read("(cond (#f 'first) (#f 'second) (else 'third))")[[1]], env = env)
  expect_equal(as.character(result), "third")

  # With expressions
  result <- engine$eval(
    engine$read("(cond ((= 1 2) 'first) ((= 2 2) 'second) (else 'third))")[[1]], env = env)
  expect_equal(as.character(result), "second")

  # No matching clause without else returns #nil
  result <- engine$eval(engine$read("(cond (#f 'first) (#f 'second))")[[1]], env = env)
  expect_null(result)

  # Multiple expressions in body
  result <- engine$eval(
    engine$read("(cond (#t (define x 5) (+ x 10)))")[[1]], env = env)
  expect_equal(result, 15)
})

test_that("case branches on key equality (Scheme syntax)", {
  thin()
  env <- new.env(parent = baseenv())
  toplevel_env(engine, env = env)
  import_stdlib_modules(engine, c("control"), env = env)

  # Match first case — datums are lists
  result <- engine$eval(
    engine$read("(case 1 ((1) 'one) ((2) 'two) ((3) 'three))")[[1]], env = env)
  expect_equal(as.character(result), "one")

  # Match middle case
  result <- engine$eval(
    engine$read("(case 2 ((1) 'one) ((2) 'two) ((3) 'three))")[[1]], env = env)
  expect_equal(as.character(result), "two")

  # Match last case
  result <- engine$eval(
    engine$read("(case 3 ((1) 'one) ((2) 'two) ((3) 'three))")[[1]], env = env)
  expect_equal(as.character(result), "three")

  # Else clause
  result <- engine$eval(
    engine$read("(case 4 ((1) 'one) ((2) 'two) (else 'other))")[[1]], env = env)
  expect_equal(as.character(result), "other")

  # No matching case without else returns #nil
  result <- engine$eval(engine$read("(case 5 ((1) 'one) ((2) 'two))")[[1]], env = env)
  expect_null(result)

  # Works with symbols — datums are auto-quoted
  result <- engine$eval(
    engine$read("(case 'b ((a) 'first) ((b) 'second) ((c) 'third))")[[1]], env = env)
  expect_equal(as.character(result), "second")

  # Multiple expressions in body
  result <- engine$eval(
    engine$read("(case 1 ((1) (define x 10) (* x 2)) ((2) 'two))")[[1]], env = env)
  expect_equal(result, 20)

  # Multi-datum clause
  result <- engine$eval(
    engine$read("(case 2 ((1 2 3) 'small) ((4 5 6) 'big))")[[1]], env = env)
  expect_equal(as.character(result), "small")

  result <- engine$eval(
    engine$read("(case 5 ((1 2 3) 'small) ((4 5 6) 'big))")[[1]], env = env)
  expect_equal(as.character(result), "big")

  # Multi-datum with else
  result <- engine$eval(
    engine$read("(case 99 ((1 2 3) 'small) ((4 5 6) 'big) (else 'other))")[[1]], env = env)
  expect_equal(as.character(result), "other")

  # Key expression is evaluated only once
  engine$eval(engine$read("(define counter 0)")[[1]], env = env)
  result <- engine$eval(
    engine$read("(case (begin (set! counter (+ counter 1)) 2)
                   ((1) 'one) ((2) 'two) ((3) 'three))")[[1]], env = env)
  expect_equal(as.character(result), "two")
  expect_equal(get("counter", envir = env), 1)  # key evaluated exactly once
})

# ============================================================================
# Existing tests below
# ============================================================================


test_that("and macro works", {
  thin()
  env <- new.env()

  # Define and macro
  engine$eval(engine$read("(defmacro and2 (first second) `(if ,first ,second #f))")[[1]], env = env)

  result <- engine$eval(engine$read("(and2 #t #t)")[[1]], env = env)
  expect_true(result)

  result <- engine$eval(engine$read("(and2 #t #f)")[[1]], env = env)
  expect_false(result)

  result <- engine$eval(engine$read("(and2 #f #t)")[[1]], env = env)
  expect_false(result)
})

test_that("or macro works", {
  thin()
  env <- new.env()

  # Define or macro
  engine$eval(engine$read("(defmacro or2 (first second) `(if ,first #t ,second))")[[1]], env = env)

  result <- engine$eval(engine$read("(or2 #t #f)")[[1]], env = env)
  expect_true(result)

  result <- engine$eval(engine$read("(or2 #f #t)")[[1]], env = env)
  expect_true(result)

  result <- engine$eval(engine$read("(or2 #f #f)")[[1]], env = env)
  expect_false(result)
})

test_that("and/or with zero arguments return identity values", {
  thin()
  env <- new.env(parent = baseenv())
  toplevel_env(engine, env = env)

  # (and) with no args returns #t (Scheme identity for and)
  expect_true(engine$eval(engine$read("(and)")[[1]], env = env))

  # (or) with no args returns #f (Scheme identity for or)
  expect_false(engine$eval(engine$read("(or)")[[1]], env = env))
})

test_that("variadic and/or short-circuit correctly", {
  thin()
  env <- new.env(parent = baseenv())
  toplevel_env(engine, env = env)
  import_stdlib_modules(engine, c("control"), env = env)

  result <- engine$eval(engine$read("(and #t 1 2 3)")[[1]], env = env)
  expect_equal(result, 3)

  result <- engine$eval(engine$read("(or #f 1 2)")[[1]], env = env)
  expect_equal(result, 1)

  engine$eval(engine$read("(define x 0)")[[1]], env = env)
  result <- engine$eval(engine$read("(and #f (begin (set! x 1) x))")[[1]], env = env)
  expect_false(result)
  expect_equal(get("x", envir = env), 0)

  result <- engine$eval(engine$read("(or #t (begin (set! x 2) x))")[[1]], env = env)
  expect_true(result)
  expect_equal(get("x", envir = env), 0)
})

test_that("not function works", {
  thin()
  env <- new.env()
  toplevel_env(engine, env = env)

  expect_false(engine$eval(engine$read("(not #t)")[[1]], env = env))
  expect_true(engine$eval(engine$read("(not #f)")[[1]], env = env))
  expect_false(engine$eval(engine$read("(not 42)")[[1]], env = env))
})

test_that("try with only error handler works", {
  thin()
  env <- new.env()
  toplevel_env(engine, env = env)

  # Success case
  result <- get("try", envir = env)(
    function() 42,
    function(e) "error"
  )
  expect_equal(result, 42)

  # Error case
  result <- get("try", envir = env)(
    function() stop("boom"),
    function(e) "caught"
  )
  expect_equal(result, "caught")
})

test_that("try with only finally handler works", {
  thin()
  env <- new.env()
  toplevel_env(engine, env = env)

  # Track whether finally ran
  finally_ran <- FALSE

  # Success case
  result <- get("try", envir = env)(
    function() 42,
    NULL,
    function() finally_ran <<- TRUE
  )
  expect_equal(result, 42)
  expect_true(finally_ran)

  # Error case (finally should run but error should propagate)
  finally_ran <- FALSE
  expect_error({
    get("try", envir = env)(
      function() stop("boom"),
      NULL,
      function() finally_ran <<- TRUE
    )
  })
  expect_true(finally_ran)
})

test_that("try with both handlers works", {
  thin()
  env <- new.env()
  toplevel_env(engine, env = env)

  # Track execution
  finally_ran <- FALSE

  # Error caught and finally runs
  result <- get("try", envir = env)(
    function() stop("boom"),
    function(e) "caught",
    function() finally_ran <<- TRUE
  )
  expect_equal(result, "caught")
  expect_true(finally_ran)

  # Success and finally runs
  finally_ran <- FALSE
  result <- get("try", envir = env)(
    function() 99,
    function(e) "error",
    function() finally_ran <<- TRUE
  )
  expect_equal(result, 99)
  expect_true(finally_ran)
})

# ============================================================================
# Coverage: try via R-level calls with explicit #f / NULL handlers
# ============================================================================

test_that("try with no handlers (thunk only)", {
  thin()
  env <- new.env()
  toplevel_env(engine, env = env)

  # Just thunk, no error or finally handler
  result <- get("try", envir = env)(function() 99)
  expect_equal(result, 99)
})

test_that("try errors when thunk is not a function", {
  thin()
  env <- new.env()
  toplevel_env(engine, env = env)

  expect_error(get("try", envir = env)(42), "expects a function as first argument")
})

test_that("try errors when error handler is not a function", {
  thin()
  env <- new.env()
  toplevel_env(engine, env = env)

  expect_error(get("try", envir = env)(function() 1, 42), "error handler must be a function")
})

test_that("try errors when finally handler is not a function", {
  thin()
  env <- new.env()
  toplevel_env(engine, env = env)

  expect_error(get("try", envir = env)(function() 1, NULL, 42), "finally handler must be a function")
})

# ============================================================================
# Looping constructs: until, loop/recur
# ============================================================================

test_that("until macro repeats until test is truthy", {
  thin()
  env <- new.env(parent = baseenv())
  toplevel_env(engine, env = env)
  import_stdlib_modules(engine, c("looping"), env = env)

  result <- engine$eval(
    engine$read("(begin (define i 0) (until (= i 3) (set! i (+ i 1))) i)")[[1]],
    env = env
  )
  expect_equal(result, 3)
})

test_that("loop/recur iterates with rebinding", {
  thin()
  env <- new.env(parent = baseenv())
  toplevel_env(engine, env = env)
  import_stdlib_modules(engine, c("looping"), env = env)

  result <- engine$eval(
    engine$read("(loop ((i 0) (acc 0)) (if (< i 5) (recur (+ i 1) (+ acc i)) acc))")[[1]],
    env = env
  )
  expect_equal(result, 10)

  result <- engine$eval(
    engine$read("(loop ((x 1)) (+ x 2))")[[1]],
    env = env
  )
  expect_equal(result, 3)

  result <- engine$eval(
    engine$read("(loop ((i 0) (sum 0)) (if (< i 3) (recur (+ i 1) (+ sum (loop ((j 0) (acc 0)) (if (< j 2) (recur (+ j 1) (+ acc 1)) acc)))) sum))")[[1]],
    env = env
  )
  expect_equal(result, 6)

  result <- engine$eval(
    engine$read("(loop ((n 5) (acc 1)) (if (< n 2) acc (recur (- n 1) (* acc n))))")[[1]],
    env = env
  )
  expect_equal(result, 120)

  result <- engine$eval(
    engine$read("(loop ((xs (list 1 2 3)) (sum 0)) (if (null? xs) sum (recur (cdr xs) (+ sum (car xs)))))")[[1]],
    env = env
  )
  expect_equal(result, 6)
})

test_that("recur errors outside loop", {
  thin()
  env <- new.env(parent = baseenv())
  toplevel_env(engine, env = env)
  import_stdlib_modules(engine, c("looping"), env = env)

  expect_error(engine$eval(engine$read("(recur 1)")[[1]], env = env), "recur can only be used inside loop")
})