sx: step 5 — OCaml AdtValue + define-type + match
Native algebraic data type representation in the OCaml SX evaluator. Replaces the dict-based shim that simulated ADT values via tagged dicts. - sx_types.ml: add AdtValue variant + adt_value record (av_type, av_ctor, av_fields). type_of returns the type name (e.g. "Maybe"); inspect renders as a constructor call (e.g. "(Just 42)" or "(Nothing)"). - sx_runtime.ml: get_val handles AdtValue with :_adt/:_type/:_ctor/:_fields keys for back-compat with spec-level match-pattern code. - sx_primitives.ml: dict? returns true for AdtValue (so existing match dispatch keeps working); new adt? predicate distinguishes ADT values. - sx_ref.ml: sf_define_type now constructs AdtValue instead of Dict. Predicates (Name?, Ctor?) and accessors (Ctor-field) match on AdtValue with proper type/ctor name and field index checks. - spec/tests/test-adt.sx: 3 new tests covering type-of, adt?, and inspect. Tests: 4532 passed (was 4529 + 3 new), 1339 failed (unchanged baseline). All 43 ADT tests pass on the native representation. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -151,9 +151,15 @@
|
||||
"match dispatches on first matching constructor"
|
||||
(do
|
||||
(define-type Color (Red) (Green) (Blue))
|
||||
(assert= "red" (match (Red) ((Red) "red") ((Green) "green") ((Blue) "blue")))
|
||||
(assert= "green" (match (Green) ((Red) "red") ((Green) "green") ((Blue) "blue")))
|
||||
(assert= "blue" (match (Blue) ((Red) "red") ((Green) "green") ((Blue) "blue")))))
|
||||
(assert=
|
||||
"red"
|
||||
(match (Red) ((Red) "red") ((Green) "green") ((Blue) "blue")))
|
||||
(assert=
|
||||
"green"
|
||||
(match (Green) ((Red) "red") ((Green) "green") ((Blue) "blue")))
|
||||
(assert=
|
||||
"blue"
|
||||
(match (Blue) ((Red) "red") ((Green) "green") ((Blue) "blue")))))
|
||||
(deftest
|
||||
"match binds field to variable"
|
||||
(do
|
||||
@@ -170,13 +176,16 @@
|
||||
"match multi-field constructor binds all fields"
|
||||
(do
|
||||
(define-type Vec2 (V2 x y))
|
||||
(let ((v (V2 3 4)))
|
||||
(let
|
||||
((v (V2 3 4)))
|
||||
(assert= 7 (match v ((V2 a b) (+ a b)))))))
|
||||
(deftest
|
||||
"match with else clause"
|
||||
(do
|
||||
(define-type Opt2 (Some2 val) (None2))
|
||||
(assert= 10 (match (Some2 10) ((Some2 v) v) (else 0)))
|
||||
(assert=
|
||||
10
|
||||
(match (Some2 10) ((Some2 v) v) (else 0)))
|
||||
(assert= 0 (match (None2) ((Some2 v) v) (else 0)))))
|
||||
(deftest
|
||||
"match else catches non-adt values"
|
||||
@@ -187,48 +196,69 @@
|
||||
"match returns body expression value"
|
||||
(do
|
||||
(define-type Num (Num-of n))
|
||||
(assert= 100 (match (Num-of 10) ((Num-of n) (* n n))))))
|
||||
(assert=
|
||||
100
|
||||
(match (Num-of 10) ((Num-of n) (* n n))))))
|
||||
(deftest
|
||||
"match second arm fires when first does not match"
|
||||
(do
|
||||
(define-type Either (Left val) (Right val))
|
||||
(assert= "left-1" (match (Left 1) ((Left v) (str "left-" v)) ((Right v) (str "right-" v))))
|
||||
(assert= "right-2" (match (Right 2) ((Left v) (str "left-" v)) ((Right v) (str "right-" v))))))
|
||||
(assert=
|
||||
"left-1"
|
||||
(match
|
||||
(Left 1)
|
||||
((Left v) (str "left-" v))
|
||||
((Right v) (str "right-" v))))
|
||||
(assert=
|
||||
"right-2"
|
||||
(match
|
||||
(Right 2)
|
||||
((Left v) (str "left-" v))
|
||||
((Right v) (str "right-" v))))))
|
||||
(deftest
|
||||
"match wildcard _ in constructor pattern"
|
||||
(do
|
||||
(define-type Pair3 (Pair3-of a b))
|
||||
(assert= 5 (match (Pair3-of 5 99) ((Pair3-of x _) x)))
|
||||
(assert= 99 (match (Pair3-of 5 99) ((Pair3-of _ y) y)))))
|
||||
(assert=
|
||||
5
|
||||
(match (Pair3-of 5 99) ((Pair3-of x _) x)))
|
||||
(assert=
|
||||
99
|
||||
(match (Pair3-of 5 99) ((Pair3-of _ y) y)))))
|
||||
(deftest
|
||||
"match nested adt constructor pattern"
|
||||
(do
|
||||
(define-type Tree2 (Leaf2) (Node2 left val right))
|
||||
(let ((t (Node2 (Leaf2) 7 (Leaf2))))
|
||||
(let
|
||||
((t (Node2 (Leaf2) 7 (Leaf2))))
|
||||
(assert= 7 (match t ((Node2 _ v _) v)))
|
||||
(assert= true (match t ((Node2 (Leaf2) _ _) true) (else false))))))
|
||||
(deftest
|
||||
"match literal pattern"
|
||||
(do
|
||||
(assert= "zero" (match 0 (0 "zero") (else "nonzero")))
|
||||
(assert=
|
||||
"zero"
|
||||
(match 0 (0 "zero") (else "nonzero")))
|
||||
(assert= "hello" (match "hello" ("hello" "hello") (else "other")))))
|
||||
(deftest
|
||||
"match symbol binding pattern"
|
||||
(do
|
||||
(assert= 42 (match 42 (x x)))))
|
||||
(do (assert= 42 (match 42 (x x)))))
|
||||
(deftest
|
||||
"match no matching clause raises error"
|
||||
(do
|
||||
(define-type AB (A-val) (B-val))
|
||||
(let ((ok false))
|
||||
(guard (exn (else (set! ok true)))
|
||||
(let
|
||||
((ok false))
|
||||
(guard
|
||||
(exn (else (set! ok true)))
|
||||
(match (A-val) ((B-val) "b")))
|
||||
(assert ok))))
|
||||
(deftest
|
||||
"match result used in further computation"
|
||||
(do
|
||||
(define-type Num2 (N v))
|
||||
(assert= 30
|
||||
(assert=
|
||||
30
|
||||
(+
|
||||
(match (N 10) ((N v) v))
|
||||
(match (N 20) ((N v) v))))))
|
||||
@@ -238,41 +268,91 @@
|
||||
(define-type Tag (Tagged label value))
|
||||
(define get-label (fn (t) (match t ((Tagged lbl _) lbl))))
|
||||
(define get-value (fn (t) (match t ((Tagged _ val) val))))
|
||||
(let ((t (Tagged "name" 99)))
|
||||
(let
|
||||
((t (Tagged "name" 99)))
|
||||
(assert= "name" (get-label t))
|
||||
(assert= 99 (get-value t)))))
|
||||
(deftest
|
||||
"match three-field constructor"
|
||||
(do
|
||||
(define-type Triple2 (T3 a b c))
|
||||
(assert= 6 (match (T3 1 2 3) ((T3 a b c) (+ a b c))))))
|
||||
(assert=
|
||||
6
|
||||
(match
|
||||
(T3 1 2 3)
|
||||
((T3 a b c) (+ a b c))))))
|
||||
(deftest
|
||||
"match clauses tried in order"
|
||||
(do
|
||||
(define-type Expr2 (Lit n) (Add l r) (Mul l r))
|
||||
(define eval-expr2 (fn (e)
|
||||
(match e
|
||||
((Lit n) n)
|
||||
((Add l r) (+ (eval-expr2 l) (eval-expr2 r)))
|
||||
((Mul l r) (* (eval-expr2 l) (eval-expr2 r))))))
|
||||
(assert= 7 (eval-expr2 (Add (Lit 3) (Lit 4))))
|
||||
(assert= 12 (eval-expr2 (Mul (Lit 3) (Lit 4))))
|
||||
(assert= 11 (eval-expr2 (Add (Lit 2) (Mul (Lit 3) (Lit 3)))))))
|
||||
(define
|
||||
eval-expr2
|
||||
(fn
|
||||
(e)
|
||||
(match
|
||||
e
|
||||
((Lit n) n)
|
||||
((Add l r) (+ (eval-expr2 l) (eval-expr2 r)))
|
||||
((Mul l r) (* (eval-expr2 l) (eval-expr2 r))))))
|
||||
(assert=
|
||||
7
|
||||
(eval-expr2 (Add (Lit 3) (Lit 4))))
|
||||
(assert=
|
||||
12
|
||||
(eval-expr2 (Mul (Lit 3) (Lit 4))))
|
||||
(assert=
|
||||
11
|
||||
(eval-expr2
|
||||
(Add (Lit 2) (Mul (Lit 3) (Lit 3)))))))
|
||||
(deftest
|
||||
"match else binding captures value"
|
||||
(do
|
||||
(define-type Coin2 (Heads2) (Tails2))
|
||||
(assert= "Tails2" (match (Tails2) ((Heads2) "Heads2") (x (get x :_ctor))))))
|
||||
(assert=
|
||||
"Tails2"
|
||||
(match (Tails2) ((Heads2) "Heads2") (x (get x :_ctor))))))
|
||||
(deftest
|
||||
"match on adt with string field"
|
||||
(do
|
||||
(define-type Msg (Hello name) (Bye name))
|
||||
(assert= "Hello, Alice" (match (Hello "Alice") ((Hello n) (str "Hello, " n)) ((Bye n) (str "Bye, " n))))
|
||||
(assert= "Bye, Bob" (match (Bye "Bob") ((Hello n) (str "Hello, " n)) ((Bye n) (str "Bye, " n))))))
|
||||
(assert=
|
||||
"Hello, Alice"
|
||||
(match
|
||||
(Hello "Alice")
|
||||
((Hello n) (str "Hello, " n))
|
||||
((Bye n) (str "Bye, " n))))
|
||||
(assert=
|
||||
"Bye, Bob"
|
||||
(match
|
||||
(Bye "Bob")
|
||||
((Hello n) (str "Hello, " n))
|
||||
((Bye n) (str "Bye, " n))))))
|
||||
(deftest
|
||||
"type-of returns adt type name"
|
||||
(do
|
||||
(define-type Maybe2 (Just2 v) (Nothing2))
|
||||
(assert= "Maybe2" (type-of (Just2 7)))
|
||||
(assert= "Maybe2" (type-of (Nothing2)))))
|
||||
(deftest
|
||||
"adt? predicate distinguishes adt values"
|
||||
(do
|
||||
(define-type Box3 (Boxed3 x))
|
||||
(assert= true (adt? (Boxed3 1)))
|
||||
(assert= false (adt? 1))
|
||||
(assert= false (adt? "str"))
|
||||
(assert= false (adt? (list 1 2)))
|
||||
(assert= false (adt? {:a 1}))))
|
||||
(deftest
|
||||
"inspect renders adt as constructor call"
|
||||
(do
|
||||
(define-type Pt (Pt-of x y) (Origin))
|
||||
(assert= "(Pt-of 3 4)" (inspect (Pt-of 3 4)))
|
||||
(assert= "(Origin)" (inspect (Origin)))))
|
||||
(deftest
|
||||
"match nested pattern with variable binding"
|
||||
(do
|
||||
(define-type Box2 (Box2-of v))
|
||||
(define-type Inner (Inner-of n))
|
||||
(assert= 5 (match (Box2-of (Inner-of 5)) ((Box2-of (Inner-of n)) n)))))
|
||||
)
|
||||
(assert=
|
||||
5
|
||||
(match (Box2-of (Inner-of 5)) ((Box2-of (Inner-of n)) n))))))
|
||||
|
||||
Reference in New Issue
Block a user