kernel: Phase 5 encapsulations + promise demo + 19 tests [nothing]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
make-encapsulation-type returns (encapsulator predicate decapsulator). Fresh empty dict per call as family identity — SX dict reference equality gives unique per-family opacity. Encap/decap/pred close over the family marker; foreign values fail both predicate and decap. Classic promise demo: (force (delay (lambda () (+ 19 23)))) → 42.
This commit is contained in:
@@ -310,6 +310,72 @@
|
||||
kernel-equal?-applicative
|
||||
(knl-bin-app "equal?" (fn (a b) (= a b))))
|
||||
|
||||
;; ── Encapsulations: Kernel's opaque-type idiom ──────────────────
|
||||
;;
|
||||
;; (make-encapsulation-type) → (encapsulator predicate decapsulator)
|
||||
;;
|
||||
;; Each call returns three applicatives over a fresh family identity.
|
||||
;; - (encapsulator V) → an opaque wrapper around V.
|
||||
;; - (predicate V) → true iff V was wrapped by THIS family.
|
||||
;; - (decapsulator W) → the inner value; errors on wrong family.
|
||||
;;
|
||||
;; Family identity is a fresh empty dict; SX compares dicts by reference,
|
||||
;; so two `(make-encapsulation-type)` calls return distinct families.
|
||||
;;
|
||||
;; Pattern usage (Phase 5 lacks destructuring, so accessors are explicit):
|
||||
;; ($define! triple (make-encapsulation-type))
|
||||
;; ($define! wrap-promise (car triple))
|
||||
;; ($define! promise? (car (cdr triple)))
|
||||
;; ($define! unwrap-promise (car (cdr (cdr triple))))
|
||||
|
||||
(define kernel-make-encap-type-impl
|
||||
(fn (args)
|
||||
(cond
|
||||
((not (= (length args) 0))
|
||||
(error "make-encapsulation-type: expects 0 arguments"))
|
||||
(:else
|
||||
(let ((family {}))
|
||||
(let ((encap
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (vargs)
|
||||
(cond
|
||||
((not (= (length vargs) 1))
|
||||
(error "encapsulator: expects 1 argument"))
|
||||
(:else
|
||||
{:knl-tag :encap
|
||||
:family family
|
||||
:value (first vargs)})))))
|
||||
(pred
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (vargs)
|
||||
(cond
|
||||
((not (= (length vargs) 1))
|
||||
(error "predicate: expects 1 argument"))
|
||||
(:else
|
||||
(let ((v (first vargs)))
|
||||
(and (dict? v)
|
||||
(= (get v :knl-tag) :encap)
|
||||
(= (get v :family) family))))))))
|
||||
(decap
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (vargs)
|
||||
(cond
|
||||
((not (= (length vargs) 1))
|
||||
(error "decapsulator: expects 1 argument"))
|
||||
(:else
|
||||
(let ((v (first vargs)))
|
||||
(cond
|
||||
((not (and (dict? v)
|
||||
(= (get v :knl-tag) :encap)))
|
||||
(error "decapsulator: not an encapsulation"))
|
||||
((not (= (get v :family) family))
|
||||
(error "decapsulator: wrong family"))
|
||||
(:else (get v :value))))))))))
|
||||
(list encap pred decap)))))))
|
||||
|
||||
(define kernel-make-encap-type-applicative
|
||||
(kernel-make-primitive-applicative kernel-make-encap-type-impl))
|
||||
|
||||
(define
|
||||
kernel-standard-env
|
||||
(fn
|
||||
@@ -348,4 +414,6 @@
|
||||
(kernel-env-bind! env "null?" kernel-null?-applicative)
|
||||
(kernel-env-bind! env "pair?" kernel-pair?-applicative)
|
||||
(kernel-env-bind! env "not" kernel-not-applicative)
|
||||
(kernel-env-bind! env "make-encapsulation-type"
|
||||
kernel-make-encap-type-applicative)
|
||||
env)))
|
||||
|
||||
Reference in New Issue
Block a user