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

;; lib/kernel/tests/encap.sx — exercises make-encapsulation-type.
;;
;; The Phase 5 Kernel idiom: build opaque types whose constructor,
;; predicate, and accessor are all standard Kernel applicatives. The
;; identity is per-call, so two `(make-encapsulation-type)` calls
;; produce non-interchangeable families.

(define ken-suite (refl-make-test-suite))
(define ken-test  (fn (n a e) (refl-test ken-suite n a e)))

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

;; A helper that builds a standard env with `encap`/`pred?`/`decap`
;; bound from a single call to make-encapsulation-type.
(define
  ken-make-encap-env
  (fn
    ()
    (let
      ((env (kernel-standard-env)))
      (ken-eval-in "($define! triple (make-encapsulation-type))" env)
      (ken-eval-in "($define! encap (car triple))" env)
      (ken-eval-in "($define! pred? (car (cdr triple)))" env)
      (ken-eval-in "($define! decap (car (cdr (cdr triple))))" env)
      env)))

;; ── construction ────────────────────────────────────────────────
(ken-test
  "make: returns 3-element list"
  (ken-eval-in "(length (make-encapsulation-type))" (kernel-standard-env))
  3)

(ken-test
  "make: first is applicative"
  (kernel-applicative?
    (ken-eval-in "(car (make-encapsulation-type))" (kernel-standard-env)))
  true)

(ken-test
  "make: second is applicative"
  (kernel-applicative?
    (ken-eval-in
      "(car (cdr (make-encapsulation-type)))"
      (kernel-standard-env)))
  true)

(ken-test
  "make: third is applicative"
  (kernel-applicative?
    (ken-eval-in
      "(car (cdr (cdr (make-encapsulation-type))))"
      (kernel-standard-env)))
  true)

;; ── round-trip ──────────────────────────────────────────────────
(ken-test
  "round-trip: number"
  (ken-eval-in "(decap (encap 42))" (ken-make-encap-env))
  42)

(ken-test
  "round-trip: string"
  (ken-eval-in "(decap (encap ($quote hello)))" (ken-make-encap-env))
  "hello")

(ken-test
  "round-trip: list"
  (ken-eval-in "(decap (encap (list 1 2 3)))" (ken-make-encap-env))
  (list 1 2 3))

;; ── predicate ───────────────────────────────────────────────────
(ken-test
  "pred?: wrapped value"
  (ken-eval-in "(pred? (encap 1))" (ken-make-encap-env))
  true)

(ken-test
  "pred?: raw value"
  (ken-eval-in "(pred? 1)" (ken-make-encap-env))
  false)

(ken-test
  "pred?: raw string"
  (ken-eval-in "(pred? ($quote foo))" (ken-make-encap-env))
  false)

(ken-test
  "pred?: raw list"
  (ken-eval-in "(pred? (list))" (ken-make-encap-env))
  false)

;; ── opacity: different families are not interchangeable ─────────
(ken-test
  "opacity: foreign value rejected by predicate"
  (let
    ((env (kernel-standard-env)))
    (ken-eval-in "($define! tA (make-encapsulation-type))" env)
    (ken-eval-in "($define! tB (make-encapsulation-type))" env)
    (ken-eval-in "($define! encA (car tA))" env)
    (ken-eval-in "($define! predB (car (cdr tB)))" env)
    (ken-eval-in "(predB (encA 42))" env))
  false)

(ken-test
  "opacity: decap rejects foreign value"
  (let
    ((env (kernel-standard-env)))
    (ken-eval-in "($define! tA (make-encapsulation-type))" env)
    (ken-eval-in "($define! tB (make-encapsulation-type))" env)
    (ken-eval-in "($define! encA (car tA))" env)
    (ken-eval-in "($define! decapB (car (cdr (cdr tB))))" env)
    (guard (e (true :raised)) (ken-eval-in "(decapB (encA 42))" env)))
  :raised)

(ken-test
  "opacity: decap rejects raw value"
  (guard
    (e (true :raised))
    (ken-eval-in "(decap 42)" (ken-make-encap-env)))
  :raised)

;; ── promise: classic Kernel encapsulation use case ──────────────
;; A "promise" wraps a thunk to compute on demand and memoises the
;; first result. Built entirely with the standard encap idiom.
(ken-test
  "promise: force returns thunk result"
  (let
    ((env (kernel-standard-env)))
    (ken-eval-in
      "($sequence\n         ($define! ptriple (make-encapsulation-type))\n         ($define! make-promise (car ptriple))\n         ($define! promise? (car (cdr ptriple)))\n         ($define! decode-promise (car (cdr (cdr ptriple))))\n         ($define! force ($lambda (p) ((decode-promise p))))\n         ($define! delay ($lambda (thunk) (make-promise thunk)))\n         (force (delay ($lambda () (+ 19 23)))))"
      env))
  42)

(ken-test
  "promise: promise? recognises its own type"
  (let
    ((env (kernel-standard-env)))
    (ken-eval-in
      "($sequence\n         ($define! ptriple (make-encapsulation-type))\n         ($define! make-promise (car ptriple))\n         ($define! promise? (car (cdr ptriple)))\n         (promise? (make-promise ($lambda () 42))))"
      env))
  true)

(ken-test
  "promise: promise? false on plain value"
  (let
    ((env (kernel-standard-env)))
    (ken-eval-in
      "($sequence\n         ($define! ptriple (make-encapsulation-type))\n         ($define! promise? (car (cdr ptriple)))\n         (promise? 99))"
      env))
  false)

;; ── independent families don't leak ─────────────────────────────
(ken-test
  "two families: distinct identity"
  (let
    ((env (kernel-standard-env)))
    (ken-eval-in
      "($sequence\n         ($define! t1 (make-encapsulation-type))\n         ($define! t2 (make-encapsulation-type))\n         ($define! enc1 (car t1))\n         ($define! pred2 (car (cdr t2)))\n         (pred2 (enc1 ($quote stuff))))"
      env))
  false)

(ken-test
  "same family: re-bound shares identity"
  (let
    ((env (kernel-standard-env)))
    (ken-eval-in
      "($sequence\n         ($define! t (make-encapsulation-type))\n         ($define! e (car t))\n         ($define! p (car (cdr t)))\n         ($define! d (car (cdr (cdr t))))\n         (list (p (e 7)) (d (e 7))))"
      env))
  (list true 7))

(define ken-tests-run! (fn () (refl-test-report ken-suite)))