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)

;; ── quasiquote ──────────────────────────────────────────────────
(ks-test "qq: plain atom"      (ks-eval "`hello") "hello")
(ks-test "qq: plain list"      (ks-eval "`(a b c)") (list "a" "b" "c"))
(ks-test "qq: unquote splices value"
  (let ((env (kernel-standard-env)))
    (ks-eval-in "($define! x 42)" env)
    (ks-eval-in "`(a ,x b)" env)) (list "a" 42 "b"))
(ks-test "qq: unquote-splicing splices list"
  (let ((env (kernel-standard-env)))
    (ks-eval-in "($define! xs (list 1 2 3))" env)
    (ks-eval-in "`(a ,@xs b)" env)) (list "a" 1 2 3 "b"))
(ks-test "qq: unquote-splicing at end"
  (let ((env (kernel-standard-env)))
    (ks-eval-in "($define! xs (list 9 8))" env)
    (ks-eval-in "`(a b ,@xs)" env)) (list "a" "b" 9 8))
(ks-test "qq: unquote-splicing at start"
  (let ((env (kernel-standard-env)))
    (ks-eval-in "($define! xs (list 1 2))" env)
    (ks-eval-in "`(,@xs c)" env)) (list 1 2 "c"))
(ks-test "qq: nested list with unquote inside"
  (let ((env (kernel-standard-env)))
    (ks-eval-in "($define! x 5)" env)
    (ks-eval-in "`(a (b ,x) c)" env))
  (list "a" (list "b" 5) "c"))
(ks-test "qq: error on bare unquote-splicing into non-list"
  (let ((env (kernel-standard-env)))
    (ks-eval-in "($define! x 42)" env)
    (guard (e (true :raised))
      (ks-eval-in "`(a ,@x b)" env)))
  :raised)

;; ── $cond / $when / $unless ─────────────────────────────────────
(ks-test "cond: first match"
  (ks-eval "($cond (#f 1) (#t 2) (#t 3))") 2)
(ks-test "cond: else fallback"
  (ks-eval "($cond (#f 1) (else 99))") 99)
(ks-test "cond: no match returns nil"
  (ks-eval "($cond (#f 1) (#f 2))") nil)
(ks-test "cond: empty clauses returns nil"
  (ks-eval "($cond)") nil)
(ks-test "cond: multi-expr body"
  (ks-eval "($cond (#t 1 2 3))") 3)
(ks-test "cond: doesn't evaluate untaken clauses"
  ;; If the second clause's test were evaluated, the unbound `nope` would error.
  (ks-eval "($cond (#t 7) (nope ignored))") 7)
(ks-test "cond: predicate evaluation"
  (let ((env (kernel-standard-env)))
    (ks-eval-in "($define! n 5)" env)
    (ks-eval-in "($cond ((< n 0) ($quote negative)) ((= n 0) ($quote zero)) (else ($quote positive)))" env))
  "positive")

(ks-test "when: true runs body"
  (ks-eval "($when #t 1 2 3)") 3)
(ks-test "when: false returns nil"
  (ks-eval "($when #f 1 2 3)") nil)
(ks-test "when: skips body when false"
  (ks-eval "($when #f nope)") nil)

(ks-test "unless: false runs body"
  (ks-eval "($unless #f 99)") 99)
(ks-test "unless: true returns nil"
  (ks-eval "($unless #t 99)") nil)
(ks-test "unless: skips body when true"
  (ks-eval "($unless #t nope)") nil)

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