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

;; lib/kernel/tests/vau.sx — exercises lib/kernel/runtime.sx.
;;
;; Verifies the Phase 3 promise: user-defined operatives and applicatives
;; constructible from inside the language. Tests build a Kernel
;; base-env, bind a few helper applicatives (+, *, list, =, $if), and
;; run programs that construct and use custom combiners.

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

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

(define kv-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))

(define
  kv-make-env
  (fn
    ()
    (let
      ((env (kernel-base-env)))
      (kernel-env-bind!
        env
        "+"
        (kernel-make-primitive-applicative
          (fn (args) (+ (first args) (nth args 1)))))
      (kernel-env-bind!
        env
        "*"
        (kernel-make-primitive-applicative
          (fn (args) (* (first args) (nth args 1)))))
      (kernel-env-bind!
        env
        "-"
        (kernel-make-primitive-applicative
          (fn (args) (- (first args) (nth args 1)))))
      (kernel-env-bind!
        env
        "="
        (kernel-make-primitive-applicative
          (fn (args) (= (first args) (nth args 1)))))
      (kernel-env-bind!
        env
        "list"
        (kernel-make-primitive-applicative (fn (args) args)))
      (kernel-env-bind!
        env
        "cons"
        (kernel-make-primitive-applicative
          (fn (args) (cons (first args) (nth args 1)))))
      (kernel-env-bind!
        env
        "$quote"
        (kernel-make-primitive-operative (fn (args dyn-env) (first args))))
      (kernel-env-bind!
        env
        "$if"
        (kernel-make-primitive-operative
          (fn
            (args dyn-env)
            (if
              (kernel-eval (first args) dyn-env)
              (kernel-eval (nth args 1) dyn-env)
              (kernel-eval (nth args 2) dyn-env)))))
      env)))

;; ── $vau: builds an operative ───────────────────────────────────
(kv-test
  "vau: identity returns first arg unevaluated"
  (kv-eval-src "(($vau (a) _ a) hello)" (kv-make-env))
  "hello")

(kv-test
  "vau: returns args as raw expressions"
  (kv-eval-src "(($vau (a b) _ (list a b)) (+ 1 2) (+ 3 4))" (kv-make-env))
  (list (list "+" 1 2) (list "+" 3 4)))

(kv-test
  "vau: env-param is a kernel env"
  (kernel-env? (kv-eval-src "(($vau () e e))" (kv-make-env)))
  true)

(kv-test
  "vau: returns operative"
  (kernel-operative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
  true)

(kv-test
  "vau: returns operative not applicative"
  (kernel-applicative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
  false)

(kv-test
  "vau: zero-arg body"
  (kv-eval-src "(($vau () _ 42))" (kv-make-env))
  42)

(kv-test
  "vau: static-env closure captured"
  (let
    ((outer (kv-make-env)))
    (kernel-env-bind! outer "captured" 17)
    (let
      ((op (kv-eval-src "($vau () _ captured)" outer))
        (caller (kv-make-env)))
      (kernel-env-bind! caller "captured" 99)
      (kernel-combine op (list) caller)))
  17)

(kv-test
  "vau: env-param exposes caller's dynamic env"
  (let
    ((outer (kv-make-env)))
    (kernel-env-bind! outer "x" 1)
    (let
      ((op (kv-eval-src "($vau () e e)" outer)) (caller (kv-make-env)))
      (kernel-env-bind! caller "x" 2)
      (let
        ((e-val (kernel-combine op (list) caller)))
        (kernel-env-lookup e-val "x"))))
  2)

;; ── $lambda: applicatives evaluate their args ───────────────────
(kv-test
  "lambda: identity"
  (kv-eval-src "(($lambda (x) x) 42)" (kv-make-env))
  42)

(kv-test
  "lambda: addition"
  (kv-eval-src "(($lambda (x y) (+ x y)) 3 4)" (kv-make-env))
  7)

(kv-test
  "lambda: args are evaluated before bind"
  (kv-eval-src "(($lambda (x) x) (+ 2 3))" (kv-make-env))
  5)

(kv-test
  "lambda: zero args"
  (kv-eval-src "(($lambda () 99))" (kv-make-env))
  99)

(kv-test
  "lambda: returns applicative"
  (kernel-applicative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
  true)

(kv-test
  "lambda: returns applicative not operative"
  (kernel-operative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
  false)

(kv-test
  "lambda: higher-order"
  (kv-eval-src "(($lambda (f) (f 10)) ($lambda (x) (+ x 1)))" (kv-make-env))
  11)

;; ── wrap / unwrap as user-callable applicatives ─────────────────

(kv-test
  "wrap: makes applicative from operative"
  (kernel-applicative? (kv-eval-src "(wrap ($vau (x) _ x))" (kv-make-env)))
  true)

(kv-test
  "wrap: result evaluates its arg"
  (kv-eval-src "((wrap ($vau (x) _ x)) (+ 1 2))" (kv-make-env))
  3)

(kv-test
  "unwrap: extracts operative from applicative"
  (kernel-operative? (kv-eval-src "(unwrap ($lambda (x) x))" (kv-make-env)))
  true)

(kv-test
  "wrap/unwrap roundtrip preserves identity"
  (kv-eval-src
    "(($lambda (op) (= op (unwrap (wrap op)))) ($vau (x) _ x))"
    (kv-make-env))
  true)

;; ── operative? / applicative? as user-visible predicates ────────

(kv-test
  "operative? on vau result"
  (kv-eval-src "(operative? ($vau (x) _ x))" (kv-make-env))
  true)

(kv-test
  "operative? on lambda result"
  (kv-eval-src "(operative? ($lambda (x) x))" (kv-make-env))
  false)

(kv-test
  "applicative? on lambda result"
  (kv-eval-src "(applicative? ($lambda (x) x))" (kv-make-env))
  true)

(kv-test
  "applicative? on vau result"
  (kv-eval-src "(applicative? ($vau (x) _ x))" (kv-make-env))
  false)

(kv-test
  "operative? on number"
  (kv-eval-src "(operative? 42)" (kv-make-env))
  false)

;; ── Build BOTH layers from user code ────────────────────────────
;; The headline Phase 3 test: defining an operative on top of an
;; applicative defined on top of a vau.

(kv-test
  "custom: applicative + operative compose"
  (let
    ((env (kv-make-env)))
    (kernel-env-bind! env "square" (kv-eval-src "($lambda (x) (* x x))" env))
    (kv-eval-src "(square 4)" env))
  16)

(kv-test "custom: operative captures argument syntax"
  ;; ($capture x) returns the raw expression `x`, regardless of value.
  (let ((env (kv-make-env)))
    (kernel-env-bind! env "$capture"
      (kv-eval-src "($vau (form) _ form)" env))
    (kv-eval-src "($capture (+ 1 2))" env))
  (list "+" 1 2))

(kv-test "custom: applicative re-wraps an operative"
  ;; Build a captured operative, then wrap it into an applicative that
  ;; evaluates args before re-entry. This exercises wrap+$vau composed.
  (let ((env (kv-make-env)))
    (kernel-env-bind! env "id-app"
      (kv-eval-src "(wrap ($vau (x) _ x))" env))
    (kv-eval-src "(id-app (+ 10 20))" env))
  30)

;; ── Error cases ──────────────────────────────────────────────────

(kv-test
  "vau: rejects non-list formals"
  (guard (e (true :raised)) (kv-eval-src "($vau x _ x)" (kv-make-env)))
  :raised)

(kv-test
  "vau: rejects non-symbol formal"
  (guard (e (true :raised)) (kv-eval-src "($vau (1) _ x)" (kv-make-env)))
  :raised)

(kv-test
  "vau: rejects non-symbol env-param"
  (guard (e (true :raised)) (kv-eval-src "($vau (x) 7 x)" (kv-make-env)))
  :raised)

(kv-test
  "vau: too few args at call site"
  (guard
    (e (true :raised))
    (kv-eval-src "(($vau (x y) _ x) 1)" (kv-make-env)))
  :raised)

(kv-test
  "vau: too many args at call site"
  (guard
    (e (true :raised))
    (kv-eval-src "(($vau (x) _ x) 1 2)" (kv-make-env)))
  :raised)

(kv-test
  "wrap: rejects non-operative"
  (guard (e (true :raised)) (kv-eval-src "(wrap 42)" (kv-make-env)))
  :raised)

(kv-test
  "unwrap: rejects non-applicative"
  (guard (e (true :raised)) (kv-eval-src "(unwrap 42)" (kv-make-env)))
  :raised)

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