rose-ash/lib/kernel/tests/standard.sx

;; lib/kernel/tests/standard.sx — exercises the Kernel standard env.
;;
;; Phase 4 tests verify that the standard env is rich enough to run
;; classic Kernel programs: factorial via recursion, list operations,
;; first-class environment manipulation. Each test starts from a fresh
;; standard env via `(kernel-standard-env)`.

(define ks-test-pass 0)
(define ks-test-fail 0)
(define ks-test-fails (list))

(define
  ks-test
  (fn
    (name actual expected)
    (if
      (= actual expected)
      (set! ks-test-pass (+ ks-test-pass 1))
      (begin
        (set! ks-test-fail (+ ks-test-fail 1))
        (append! ks-test-fails {:name name :actual actual :expected expected})))))

(define
  ks-eval
  (fn (src) (kernel-eval (kernel-parse src) (kernel-standard-env))))

(define ks-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))

(define
  ks-eval-all
  (fn (src env) (kernel-eval-program (kernel-parse-all src) env)))

;; ── $if ──────────────────────────────────────────────────────────
(ks-test "if: true branch" (ks-eval "($if #t 1 2)") 1)
(ks-test "if: false branch" (ks-eval "($if #f 1 2)") 2)
(ks-test "if: predicate"
  (ks-eval "($if (<=? 1 2) ($quote yes) ($quote no))") "yes")
(ks-test
  "if: untaken branch not evaluated"
  (ks-eval "($if #t 42 nope)")
  42)

;; ── $define! + arithmetic ───────────────────────────────────────
(ks-test
  "define!: returns value"
  (let ((env (kernel-standard-env))) (ks-eval-in "($define! x 5)" env))
  5)

(ks-test
  "define!: bound in env"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in "($define! x 5)" env)
    (ks-eval-in "x" env))
  5)

(ks-test "arith: +" (ks-eval "(+ 2 3)") 5)
(ks-test "arith: -" (ks-eval "(- 10 4)") 6)
(ks-test "arith: *" (ks-eval "(* 6 7)") 42)
(ks-test "arith: /" (ks-eval "(/ 20 5)") 4)
(ks-test "cmp: <  true" (ks-eval "(< 1 2)") true)
(ks-test "cmp: <  false" (ks-eval "(< 2 1)") false)
(ks-test "cmp: >=" (ks-eval "(>=? 2 2)") true)
(ks-test "cmp: <=" (ks-eval "(<=? 2 3)") true)
(ks-test "cmp: =" (ks-eval "(=? 7 7)") true)

;; ── $sequence ────────────────────────────────────────────────────
(ks-test "sequence: empty" (ks-eval "($sequence)") nil)
(ks-test "sequence: single" (ks-eval "($sequence 99)") 99)
(ks-test
  "sequence: multi-effect"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in "($sequence ($define! a 1) ($define! b 2) (+ a b))" env))
  3)

;; ── list primitives ──────────────────────────────────────────────
(ks-test
  "list: builds"
  (ks-eval "(list 1 2 3)")
  (list 1 2 3))
(ks-test "list: empty" (ks-eval "(list)") (list))
(ks-test
  "cons: prepend"
  (ks-eval "(cons 0 (list 1 2 3))")
  (list 0 1 2 3))
(ks-test "car: head" (ks-eval "(car (list 10 20 30))") 10)
(ks-test
  "cdr: tail"
  (ks-eval "(cdr (list 10 20 30))")
  (list 20 30))
(ks-test "length: 3" (ks-eval "(length (list 1 2 3))") 3)
(ks-test "length: 0" (ks-eval "(length (list))") 0)
(ks-test "null?: empty" (ks-eval "(null? (list))") true)
(ks-test "null?: nonempty" (ks-eval "(null? (list 1))") false)
(ks-test "pair?: empty" (ks-eval "(pair? (list))") false)
(ks-test "pair?: nonempty" (ks-eval "(pair? (list 1))") true)

;; ── $quote ───────────────────────────────────────────────────────
(ks-test "quote: symbol" (ks-eval "($quote foo)") "foo")
(ks-test
  "quote: list"
  (ks-eval "($quote (+ 1 2))")
  (list "+" 1 2))

;; ── boolean / not ────────────────────────────────────────────────
(ks-test "not: true" (ks-eval "(not #t)") false)
(ks-test "not: false" (ks-eval "(not #f)") true)

;; ── factorial ────────────────────────────────────────────────────
(ks-test
  "factorial: 5!"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in
      "($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
      env)
    (ks-eval-in "(factorial 5)" env))
  120)

(ks-test
  "factorial: 0! = 1"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in
      "($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
      env)
    (ks-eval-in "(factorial 0)" env))
  1)

(ks-test
  "factorial: 10!"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in
      "($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
      env)
    (ks-eval-in "(factorial 10)" env))
  3628800)

;; ── recursive list operations ────────────────────────────────────
(ks-test
  "sum: recursive over list"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in
      "($define! sum ($lambda (xs) ($if (null? xs) 0 (+ (car xs) (sum (cdr xs))))))"
      env)
    (ks-eval-in "(sum (list 1 2 3 4 5))" env))
  15)

(ks-test
  "len: recursive count"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in
      "($define! mylen ($lambda (xs) ($if (null? xs) 0 (+ 1 (mylen (cdr xs))))))"
      env)
    (ks-eval-in "(mylen (list 1 2 3 4))" env))
  4)

(ks-test
  "map-add1: build new list"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in
      "($define! add1-all ($lambda (xs) ($if (null? xs) (list) (cons (+ 1 (car xs)) (add1-all (cdr xs))))))"
      env)
    (ks-eval-in "(add1-all (list 10 20 30))" env))
  (list 11 21 31))

;; ── eval as a first-class applicative ────────────────────────────
(ks-test
  "eval: applies to constructed form"
  (ks-eval "(eval (list ($quote +) 2 3) (get-current-environment))")
  5)

(ks-test
  "eval: with a fresh make-environment"
  (guard
    (e (true :raised))
    (ks-eval "(eval ($quote (+ 1 2)) (make-environment))"))
  :raised)

(ks-test
  "eval: in extended env sees parent's bindings"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in "($define! shared 7)" env)
    (ks-eval-in
      "(eval ($quote shared) (make-environment (get-current-environment)))"
      env))
  7)

;; ── get-current-environment ──────────────────────────────────────
(ks-test
  "get-current-environment: returns env"
  (kernel-env? (ks-eval "(get-current-environment)"))
  true)

(ks-test
  "get-current-environment: contains $if"
  (let
    ((env (ks-eval "(get-current-environment)")))
    (kernel-env-has? env "$if"))
  true)

(ks-test
  "make-environment: empty"
  (let ((env (ks-eval "(make-environment)"))) (kernel-env-has? env "$if"))
  false)

(ks-test
  "make-environment: child sees parent"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in "($define! marker 123)" env)
    (let
      ((child (ks-eval-in "(make-environment (get-current-environment))" env)))
      (kernel-env-has? child "marker")))
  true)

;; ── closures and lexical scope ───────────────────────────────────
(ks-test
  "closure: captures binding"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in
      "($define! make-adder ($lambda (n) ($lambda (x) (+ x n))))"
      env)
    (ks-eval-in "($define! add5 (make-adder 5))" env)
    (ks-eval-in "(add5 10)" env))
  15)

(ks-test
  "closure: nested lookups"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in
      "($define! curry-add ($lambda (a) ($lambda (b) ($lambda (c) (+ a (+ b c))))))"
      env)
    (ks-eval-in "(((curry-add 1) 2) 3)" env))
  6)

;; ── operative defined in standard env can reach $define! ─────────
(ks-test
  "custom: define-via-vau"
  (let
    ((env (kernel-standard-env)))
    (ks-eval-in
      "($define! $let-it ($vau (name expr) e ($sequence ($define! tmp (eval expr e)) (eval (list ($quote $define!) name (list ($quote $quote) tmp)) e) tmp)))"
      env)
    (ks-eval-in "($let-it z 77)" env)
    (ks-eval-in "z" env))
  77)

(define ks-tests-run! (fn () {:total (+ ks-test-pass ks-test-fail) :passed ks-test-pass :failed ks-test-fail :fails ks-test-fails}))