giles
4504b8ae5e
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 33s
lib/guest/test-runner.sx — per-suite mutable state {:pass :fail :fails}
+ refl-test recorder + refl-test-report. Replaces the identical
4-define harness that appears in 142+ test files across the codebase.
Each migrated file goes from:
(define X-test-pass 0)
(define X-test-fail 0)
(define X-test-fails (list))
(define X-test (fn (name actual expected) (if (= actual expected)
(set! X-test-pass (+ X-test-pass 1)) (begin ...))))
;; ... tests ...
(define X-tests-run! (fn () {:total ... :passed ... :failed ... :fails ...}))
to:
(define X-suite (refl-make-test-suite))
(define X-test (fn (n a e) (refl-test X-suite n a e)))
;; ... tests ...
(define X-tests-run! (fn () (refl-test-report X-suite)))
All 322 Kernel tests pass unchanged (parse 62, eval 36, vau 38,
standard 127, encap 19, hygiene 26, metacircular 14). 84 LoC removed.
Migration is mechanical (the prefix is the only difference between
suites); /tmp/migrate_harness.py drives the regex. Other guests
(Tcl, Smalltalk, APL, CL, Erlang, Haskell, etc.) migrated in
subsequent commits.
298 lines
8.4 KiB
Plaintext
298 lines
8.4 KiB
Plaintext
;; 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-suite (refl-make-test-suite))
|
|
(define kv-test (fn (n a e) (refl-test kv-suite n a e)))
|
|
|
|
(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)
|
|
|
|
;; ── Multi-expression body (implicit $sequence) ──────────────────
|
|
|
|
(kv-test "lambda: two body forms — value of last"
|
|
(kv-eval-src "(($lambda (n) (+ n 1) (+ n 10)) 5)" (kv-make-env)) 15)
|
|
|
|
(kv-test "lambda: three body forms"
|
|
(kv-eval-src "(($lambda (n) n (+ n 1) (+ n 2)) 10)" (kv-make-env)) 12)
|
|
|
|
(kv-test "vau: two body forms"
|
|
(kv-eval-src "(($vau (a b) _ a (list a b)) 7 8)" (kv-make-env))
|
|
(list 7 8))
|
|
|
|
(kv-test "lambda: $define! in early body visible in later body"
|
|
(kv-eval-src
|
|
"(($lambda (n) ($define! double (+ n n)) double) 6)"
|
|
(kv-make-env)) 12)
|
|
|
|
(kv-test "lambda: zero-arg multi-body"
|
|
(kv-eval-src "(($lambda () 1 2 3))" (kv-make-env)) 3)
|
|
|
|
(define kv-tests-run! (fn () (refl-test-report kv-suite)))
|