spec: define-type special form — constructors, predicates, accessors (20 tests)

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 <noreply@anthropic.com>
This commit is contained in:
2026-04-26 17:56:50 +00:00
parent 3fb0212414
commit 6c87210728
4 changed files with 306 additions and 37 deletions

View File

@@ -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.

View File

@@ -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);

View File

@@ -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

149
spec/tests/test-adt.sx Normal file
View File

@@ -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))))))