giles
1f49242ae3
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>
359 lines
10 KiB
Plaintext
359 lines
10 KiB
Plaintext
(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)))))
|
|
(deftest
|
|
"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")))))
|
|
(deftest
|
|
"match binds field to variable"
|
|
(do
|
|
(define-type Wrapper (Wrap val))
|
|
(assert= 42 (match (Wrap 42) ((Wrap v) v)))
|
|
(assert= "hi" (match (Wrap "hi") ((Wrap v) v)))))
|
|
(deftest
|
|
"match zero-arg constructor"
|
|
(do
|
|
(define-type Signal (On) (Off))
|
|
(assert= "on" (match (On) ((On) "on") ((Off) "off")))
|
|
(assert= "off" (match (Off) ((On) "on") ((Off) "off")))))
|
|
(deftest
|
|
"match multi-field constructor binds all fields"
|
|
(do
|
|
(define-type Vec2 (V2 x y))
|
|
(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= 0 (match (None2) ((Some2 v) v) (else 0)))))
|
|
(deftest
|
|
"match else catches non-adt values"
|
|
(do
|
|
(assert= "other" (match 42 ((else) "other") (else "other")))
|
|
(assert= "other" (match "str" (else "other")))))
|
|
(deftest
|
|
"match returns body expression value"
|
|
(do
|
|
(define-type Num (Num-of 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))))))
|
|
(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)))))
|
|
(deftest
|
|
"match nested adt constructor pattern"
|
|
(do
|
|
(define-type Tree2 (Leaf2) (Node2 left val right))
|
|
(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= "hello" (match "hello" ("hello" "hello") (else "other")))))
|
|
(deftest
|
|
"match symbol binding pattern"
|
|
(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)))
|
|
(match (A-val) ((B-val) "b")))
|
|
(assert ok))))
|
|
(deftest
|
|
"match result used in further computation"
|
|
(do
|
|
(define-type Num2 (N v))
|
|
(assert=
|
|
30
|
|
(+
|
|
(match (N 10) ((N v) v))
|
|
(match (N 20) ((N v) v))))))
|
|
(deftest
|
|
"match with define"
|
|
(do
|
|
(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)))
|
|
(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))))))
|
|
(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)))))))
|
|
(deftest
|
|
"match else binding captures value"
|
|
(do
|
|
(define-type Coin2 (Heads2) (Tails2))
|
|
(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))))))
|
|
(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))))))
|