From 6c872107289791ffcbc5f36797de4d21fdcc9444 Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 26 Apr 2026 17:56:50 +0000 Subject: [PATCH] =?UTF-8?q?spec:=20define-type=20special=20form=20?= =?UTF-8?q?=E2=80=94=20constructors,=20predicates,=20accessors=20(20=20tes?= =?UTF-8?q?ts)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds sf-define-type via register-special-form! in spec/evaluator.sx. ADT values are dicts {:_adt true :_type "T" :_ctor "C" :_fields (list ...)}. Each define-type call registers: ctor functions with arity checking, Name? type predicate, Ctor? constructor predicates, Ctor-field positional accessors, and populates *adt-registry* dict with type→[ctor-names] mapping. 20/20 JS tests pass in spec/tests/test-adt.sx. Co-Authored-By: Claude Sonnet 4.6 --- plans/agent-briefings/primitives-loop.md | 3 +- shared/static/scripts/sx-browser.js | 30 ++++- spec/evaluator.sx | 161 ++++++++++++++++++----- spec/tests/test-adt.sx | 149 +++++++++++++++++++++ 4 files changed, 306 insertions(+), 37 deletions(-) create mode 100644 spec/tests/test-adt.sx diff --git a/plans/agent-briefings/primitives-loop.md b/plans/agent-briefings/primitives-loop.md index fab5ce8b..2b088851 100644 --- a/plans/agent-briefings/primitives-loop.md +++ b/plans/agent-briefings/primitives-loop.md @@ -178,7 +178,7 @@ simulate sum types. A native `define-type` + `match` form eliminates this everyw CEK dispatch, exhaustiveness warnings via _adt_registry, recursive types, nested patterns, wildcard _, 3-phase impl plan (basic/nested/exhaustiveness), open questions on accessors/singletons/inspect. -- [ ] Spec: implement `define-type` special form in `spec/evaluator.sx`: +- [x] Spec: implement `define-type` special form in `spec/evaluator.sx`: `(define-type Name (Ctor1 field...) (Ctor2 field...) ...)` Creates constructor functions `Ctor1`, `Ctor2` + predicate `Name?`. @@ -686,6 +686,7 @@ Brief each language's loop agent (or do inline) after rebasing their branch onto _Newest first._ +- 2026-04-26: Phase 6 Spec define-type done — sf-define-type registered via register-special-form! in spec/evaluator.sx; AdtValue as {:_adt true :_type "..." :_ctor "..." :_fields (list ...)}; ctor fns + arity checking + Name?/Ctor? predicates + Ctor-field accessors; *adt-registry* dict populated per define-type call. 20/20 JS tests pass in spec/tests/test-adt.sx. OCaml define-type is next task. - 2026-04-26: Phase 6 Design done — plans/designs/sx-adt.md written. Covers define-type/match syntax, AdtValue CEK runtime, stepSfDefineType+MatchFrame dispatch, exhaustiveness warnings, recursive types, nested patterns, wildcard _. 3-phase impl plan. Next fire: Spec implement define-type. - 2026-04-26: Phase 5 complete — string buffer fully landed (d98b5fa2). 17 tests, 17/17 OCaml+JS. Phase 6 (ADTs) next. - 2026-04-26: Phase 5 Spec+OCaml+JS step done — StringBuffer of Buffer.t in sx_types.ml; make-string-buffer/append!/->string/length/string-buffer? in sx_primitives.ml; SxStringBuffer with _string_buffer marker + typeOf/dict? fixes in platform.py; JS rebuilt. 17/17 tests OCaml+JS. diff --git a/shared/static/scripts/sx-browser.js b/shared/static/scripts/sx-browser.js index 5b6dfbf9..48adc939 100644 --- a/shared/static/scripts/sx-browser.js +++ b/shared/static/scripts/sx-browser.js @@ -31,7 +31,7 @@ // ========================================================================= var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } }); - var SX_VERSION = "2026-04-26T17:04:43Z"; + var SX_VERSION = "2026-04-26T17:41:33Z"; function isNil(x) { return x === NIL || x === null || x === undefined; } function isSxTruthy(x) { return x !== false && !isNil(x); } @@ -2155,6 +2155,34 @@ PRIMITIVES["step-sf-let-match"] = stepSfLetMatch; })(); }; PRIMITIVES["step-eval-list"] = stepEvalList; + // sf-define-type + var sfDefineType = function(args, env) { return (function() { + var typeSym = first(args); + var ctorSpecs = rest(args); + return (function() { + var typeName = symbolName(typeSym); + var ctorNames = map(function(spec) { return symbolName(first(spec)); }, ctorSpecs); + if (isSxTruthy(!isSxTruthy(envHas(env, "*adt-registry*")))) { + envBind(env, "*adt-registry*", {}); +} + envGet(env, "*adt-registry*")[typeName] = ctorNames; + envBind(env, (String(typeName) + String("?")), function(v) { return (isSxTruthy(isDict(v)) && isSxTruthy(get(v, "_adt")) && sxEq(get(v, "_type"), typeName)); }); + { var _c = ctorSpecs; for (var _i = 0; _i < _c.length; _i++) { var spec = _c[_i]; (function() { + var cn = symbolName(first(spec)); + var fieldNames = map(function(f) { return symbolName(f); }, rest(spec)); + var arity = len(rest(spec)); + envBind(env, cn, function() { var ctorArgs = Array.prototype.slice.call(arguments, 0); return (isSxTruthy(!isSxTruthy(sxEq(len(ctorArgs), arity))) ? error((String(cn) + String(": expected ") + String(arity) + String(" args, got ") + String(len(ctorArgs)))) : {"_ctor": cn, "_type": typeName, "_adt": true, "_fields": ctorArgs}); }); + envBind(env, (String(cn) + String("?")), function(v) { return (isSxTruthy(isDict(v)) && isSxTruthy(get(v, "_adt")) && sxEq(get(v, "_ctor"), cn)); }); + return forEachIndexed(function(idx, fieldName) { return envBind(env, (String(cn) + String("-") + String(fieldName)), function(v) { return nth(get(v, "_fields"), idx); }); }, fieldNames); +})(); } } + return NIL; +})(); +})(); }; +PRIMITIVES["sf-define-type"] = sfDefineType; + + // (register-special-form! ...) + registerSpecialForm("define-type", sfDefineType); + // kont-extract-provides var kontExtractProvides = function(kont) { return (isSxTruthy(isEmpty(kont)) ? [] : (function() { var frame = first(kont); diff --git a/spec/evaluator.sx b/spec/evaluator.sx index b60623e3..be7f9a10 100644 --- a/spec/evaluator.sx +++ b/spec/evaluator.sx @@ -1898,6 +1898,67 @@ :else (step-eval-call head args env kont))))) (step-eval-call head args env kont)))))) +(define + sf-define-type + (fn + (args env) + (let + ((type-sym (first args)) (ctor-specs (rest args))) + (let + ((type-name (symbol-name type-sym)) + (ctor-names + (map (fn (spec) (symbol-name (first spec))) ctor-specs))) + (when + (not (env-has? env "*adt-registry*")) + (env-bind! env "*adt-registry*" {})) + (dict-set! (env-get env "*adt-registry*") type-name ctor-names) + (env-bind! + env + (str type-name "?") + (fn + (v) + (and (dict? v) (get v :_adt) (= (get v :_type) type-name)))) + (for-each + (fn + (spec) + (let + ((cn (symbol-name (first spec))) + (field-names (map (fn (f) (symbol-name f)) (rest spec))) + (arity (len (rest spec)))) + (env-bind! + env + cn + (fn + (&rest ctor-args) + (if + (not (= (len ctor-args) arity)) + (error + (str + cn + ": expected " + arity + " args, got " + (len ctor-args))) + {:_ctor cn :_type type-name :_adt true :_fields ctor-args}))) + (env-bind! + env + (str cn "?") + (fn + (v) + (and (dict? v) (get v :_adt) (= (get v :_ctor) cn)))) + (for-each-indexed + (fn + (idx field-name) + (env-bind! + env + (str cn "-" field-name) + (fn (v) (nth (get v :_fields) idx)))) + field-names))) + ctor-specs) + nil)))) + +(register-special-form! "define-type" sf-define-type) + (define kont-extract-provides (fn @@ -1932,6 +1993,14 @@ subs) (for-each (fn (sub) (cek-call sub (list kont))) subs)))))) +;; ═══════════════════════════════════════════════════════════════ +;; Part 10: Continue Phase — Frame Dispatch +;; +;; When phase="continue", pop the top frame and process the value. +;; Each frame type has its own handling: if frames check truthiness, +;; let frames bind the value, arg frames accumulate it, etc. +;; continue-with-call handles the final function/component dispatch. +;; ═══════════════════════════════════════════════════════════════ (define fire-provide-subscribers (fn @@ -1951,18 +2020,13 @@ subs) (for-each (fn (sub) (cek-call sub (list nil))) subs)))))) +;; Final call dispatch from arg frame — all args evaluated, invoke function. +;; Handles: lambda (bind params + TCO), component (keyword args + TCO), +;; native fn (direct call), continuation (resume), callcc continuation (escape). (define batch-begin! (fn () (set! *provide-batch-depth* (+ *provide-batch-depth* 1)))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 10: Continue Phase — Frame Dispatch -;; -;; When phase="continue", pop the top frame and process the value. -;; Each frame type has its own handling: if frames check truthiness, -;; let frames bind the value, arg frames accumulate it, etc. -;; continue-with-call handles the final function/component dispatch. -;; ═══════════════════════════════════════════════════════════════ (define batch-end! (fn @@ -1975,9 +2039,13 @@ (set! *provide-batch-queue* (list)) (for-each (fn (sub) (cek-call sub (list nil))) queue))))) -;; Final call dispatch from arg frame — all args evaluated, invoke function. -;; Handles: lambda (bind params + TCO), component (keyword args + TCO), -;; native fn (direct call), continuation (resume), callcc continuation (escape). +;; ═══════════════════════════════════════════════════════════════ +;; Part 11: Entry Points +;; +;; eval-expr-cek / trampoline-cek: CEK evaluation entry points. +;; eval-expr / trampoline: top-level bindings that override the +;; forward declarations from Part 5. +;; ═══════════════════════════════════════════════════════════════ (define step-sf-bind (fn @@ -2008,13 +2076,6 @@ (make-parameterize-frame bindings nil (list) body env) kont))))))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 11: Entry Points -;; -;; eval-expr-cek / trampoline-cek: CEK evaluation entry points. -;; eval-expr / trampoline: top-level bindings that override the -;; forward declarations from Part 5. -;; ═══════════════════════════════════════════════════════════════ (define syntax-rules-match (fn @@ -2186,7 +2247,10 @@ ((all-vars (syntax-rules-find-all-vars elem bindings))) (if (empty? all-vars) - (syntax-rules-instantiate-list template (+ i 2) bindings) + (syntax-rules-instantiate-list + template + (+ i 2) + bindings) (let ((count (len (get bindings (first all-vars)))) (expanded @@ -2209,7 +2273,10 @@ (syntax-rules-instantiate elem b))) (range count))) (rest-result - (syntax-rules-instantiate-list template (+ i 2) bindings))) + (syntax-rules-instantiate-list + template + (+ i 2) + bindings))) (append expanded rest-result)))) (cons (syntax-rules-instantiate elem bindings) @@ -2536,7 +2603,8 @@ (let ((proto-name (symbol-name (first args))) (raw-type-name (symbol-name (nth args 1))) - (type-name (slice raw-type-name 1 (- (len raw-type-name) 1))) + (type-name + (slice raw-type-name 1 (- (len raw-type-name) 1))) (method-defs (rest (rest args)))) (let ((proto (get *protocol-registry* proto-name))) @@ -2678,8 +2746,12 @@ (and (>= (len value) rest-idx) (every? - (fn (pair) (match-pattern (first pair) (nth pair 1) env)) - (zip (slice pattern 0 rest-idx) (slice value 0 rest-idx))) + (fn + (pair) + (match-pattern (first pair) (nth pair 1) env)) + (zip + (slice pattern 0 rest-idx) + (slice value 0 rest-idx))) (let ((rest-name (nth pattern (+ rest-idx 1)))) (env-bind! env (symbol-name rest-name) (slice value rest-idx)) @@ -2691,7 +2763,9 @@ (let ((pairs (zip pattern value))) (every? - (fn (pair) (match-pattern (first pair) (nth pair 1) env)) + (fn + (pair) + (match-pattern (first pair) (nth pair 1) env)) pairs))) :else (= pattern value)))) @@ -3354,7 +3428,8 @@ kont))))) ("reduce" (let - ((init (nth ordered 1)) (coll (nth ordered 2))) + ((init (nth ordered 1)) + (coll (nth ordered 2))) (if (empty? coll) (make-cek-value init env kont) @@ -3658,7 +3733,10 @@ (next-test (first next-clause))) (if (is-else-clause? next-test) - (make-cek-state (nth next-clause 1) fenv rest-k) + (make-cek-state + (nth next-clause 1) + fenv + rest-k) (make-cek-state next-test fenv @@ -3830,7 +3908,9 @@ (let ((d (dict))) (for-each - (fn (pair) (dict-set! d (first pair) (nth pair 1))) + (fn + (pair) + (dict-set! d (first pair) (nth pair 1))) completed) (make-cek-value d fenv rest-k)) (let @@ -4156,9 +4236,14 @@ (list) fenv (list) - (kont-push (make-wind-return-frame body-result fenv) rest-k))))) + (kont-push + (make-wind-return-frame body-result fenv) + rest-k))))) ("wind-return" - (make-cek-value (get frame "body-result") (get frame "env") rest-k)) + (make-cek-value + (get frame "body-result") + (get frame "env") + rest-k)) ("raise-eval" (let ((condition value) @@ -4183,7 +4268,9 @@ (kont-push (make-signal-return-frame fenv unwound-k) unwound-k) - (kont-push (make-raise-guard-frame fenv unwound-k) unwound-k)))))) + (kont-push + (make-raise-guard-frame fenv unwound-k) + unwound-k)))))) ("raise-guard" (do (set! *last-error-kont* rest-k) @@ -4317,9 +4404,7 @@ ((arg (if (empty? args) nil (first args))) (captured (callcc-continuation-data f)) (w-len (callcc-continuation-winders-len f))) - (do - (wind-escape-to w-len) - (make-cek-value arg env captured))) + (do (wind-escape-to w-len) (make-cek-value arg env captured))) (continuation? f) (let ((arg (if (empty? args) nil (first args))) @@ -4364,7 +4449,9 @@ " args, got " (len args)))) (for-each - (fn (pair) (env-bind! local (first pair) (nth pair 1))) + (fn + (pair) + (env-bind! local (first pair) (nth pair 1))) (zip params args)) (for-each (fn (p) (env-bind! local p nil)) @@ -4419,7 +4506,11 @@ (if (= match-val test-val) (make-cek-state body env kont) - (sf-case-step-loop match-val (slice clauses 2) env kont)))))))) + (sf-case-step-loop + match-val + (slice clauses 2) + env + kont)))))))) (define eval-expr-cek diff --git a/spec/tests/test-adt.sx b/spec/tests/test-adt.sx new file mode 100644 index 00000000..68e00b56 --- /dev/null +++ b/spec/tests/test-adt.sx @@ -0,0 +1,149 @@ +(defsuite + "algebraic-data-types" + (deftest + "constructor creates dict with adt marker" + (do + (define-type Maybe (Just value) (Nothing)) + (assert= true (get (Just 42) :_adt)))) + (deftest + "constructor stores type name" + (do + (define-type Shape (Circle radius) (Square side)) + (assert= "Shape" (get (Circle 5) :_type)) + (assert= "Shape" (get (Square 3) :_type)))) + (deftest + "constructor stores constructor name" + (do + (define-type Opt (Some val) (None)) + (assert= "Some" (get (Some 1) :_ctor)) + (assert= "None" (get (None) :_ctor)))) + (deftest + "constructor stores fields as list" + (do + (define-type Pair (Pair-of fst snd)) + (assert-equal + (list 1 2) + (get (Pair-of 1 2) :_fields)))) + (deftest + "zero-arg constructor has empty fields" + (do + (define-type Flag (Set) (Unset)) + (assert-equal (list) (get (Set) :_fields)) + (assert-equal (list) (get (Unset) :_fields)))) + (deftest + "type predicate true for all constructors" + (do + (define-type Expr (Num n) (Add left right) (Neg e)) + (assert= true (Expr? (Num 5))) + (assert= true (Expr? (Add (Num 1) (Num 2)))) + (assert= true (Expr? (Neg (Num 3)))))) + (deftest + "type predicate false for non-adt values" + (do + (define-type Box (Box-of x)) + (assert= false (Box? 42)) + (assert= false (Box? "hello")) + (assert= false (Box? nil)) + (assert= false (Box? (list 1 2))) + (assert= false (Box? {})))) + (deftest + "type predicate false for wrong adt type" + (do + (define-type AT (AV x)) + (define-type BT (BV x)) + (assert= false (AT? (BV 1))) + (assert= false (BT? (AV 1))))) + (deftest + "constructor predicate true for matching constructor" + (do + (define-type Result (Ok value) (Err msg)) + (assert= true (Ok? (Ok 42))) + (assert= true (Err? (Err "bad"))))) + (deftest + "constructor predicate false for wrong constructor" + (do + (define-type Coin (Heads) (Tails)) + (assert= false (Heads? (Tails))) + (assert= false (Tails? (Heads))))) + (deftest + "constructor predicate false for non-adt" + (do + (define-type Wrap (Wrapped x)) + (assert= false (Wrapped? 42)) + (assert= false (Wrapped? nil)) + (assert= false (Wrapped? "str")))) + (deftest + "single-field accessor returns field value" + (do + (define-type Holder (Held content)) + (assert= 99 (Held-content (Held 99))) + (assert= "hello" (Held-content (Held "hello"))))) + (deftest + "multi-field accessors return correct fields" + (do + (define-type Triple (Triple-of a b c)) + (let + ((t (Triple-of 10 20 30))) + (assert= 10 (Triple-of-a t)) + (assert= 20 (Triple-of-b t)) + (assert= 30 (Triple-of-c t))))) + (deftest + "tree constructors and accessors" + (do + (define-type Tree (Leaf) (Node left val right)) + (let + ((t (Node (Leaf) 5 (Node (Leaf) 3 (Leaf))))) + (assert= true (Node? t)) + (assert= 5 (Node-val t)) + (assert= true (Leaf? (Node-left t))) + (assert= true (Node? (Node-right t))) + (assert= 3 (Node-val (Node-right t)))))) + (deftest + "arity error on too few args" + (do + (define-type Pair2 (Pair2-of a b)) + (let + ((ok false)) + (guard (exn (else (set! ok true))) (Pair2-of 1)) + (assert ok)))) + (deftest + "arity error on too many args" + (do + (define-type Single (Single-of x)) + (let + ((ok false)) + (guard + (exn (else (set! ok true))) + (Single-of 1 2)) + (assert ok)))) + (deftest + "multiple types are independent" + (do + (define-type Color2 (Red2) (Green2) (Blue2)) + (define-type Suit (Hearts) (Diamonds) (Clubs) (Spades)) + (assert= false (Color2? (Hearts))) + (assert= false (Suit? (Red2))) + (assert= true (Color2? (Blue2))) + (assert= true (Suit? (Spades))))) + (deftest + "adt fields can hold any value" + (do + (define-type Container (Hold x)) + (assert-equal + (list 1 2 3) + (Hold-x (Hold (list 1 2 3)))) + (assert-equal {:a 1} (Hold-x (Hold {:a 1}))))) + (deftest + "adt-registry tracks type constructor names" + (do + (define-type Days (Mon) (Tue) (Wed) (Thu) (Fri)) + (assert-equal + (list "Mon" "Tue" "Wed" "Thu" "Fri") + (get *adt-registry* "Days")))) + (deftest + "constructors with same field name in different types are independent" + (do + (define-type P1 (P1-ctor value)) + (define-type P2 (P2-ctor value)) + (assert= 10 (P1-ctor-value (P1-ctor 10))) + (assert= 20 (P2-ctor-value (P2-ctor 20))))))