giles
6d39111992
Emit a warning when a `match` expression on an ADT value misses one or more constructors and lacks an `else`/`_` clause. Behaviour is non-fatal — the match still runs, the warning goes to stderr. - spec/evaluator.sx: helpers `match-clause-is-else?`, `match-clause-ctor-name`, `match-warn-non-exhaustive`, `match-check-exhaustiveness`. The latter reads the `*adt-registry*` (already populated by `define-type`), collects constructor patterns from clauses, and dedupes via an `*adt-warned*` env-bound dict so each (type, missing-set) warns once. Wired into `step-sf-match` via a `do` block before clause dispatch. - hosts/javascript/platform.py: `host-warn` primitive (`console.warn`) + matching `hostWarn` js-id helper so the JS-transpiled spec code can call it directly. Spec code reaches JS via `sx_build target=js`. - hosts/ocaml/lib/sx_runtime.ml + sx_primitives.ml: `host-warn` runtime helper (`prerr_endline`) and registered primitive. - hosts/ocaml/lib/sx_ref.ml: HAND-PATCHED. `step_sf_match` now calls a hand-written `match_check_exhaustiveness` that handles both `AdtValue` and back-compat dict-shape ADT values. The OCaml side is *not* retranspiled because regenerating sx_ref.ml drops several preamble fixes (seq_to_list, string->symbol mangling, empty-dict literal bug). Future retranspile must reapply this patch. - spec/tests/test-adt.sx: 5 new tests covering exhaustive, non-exhaustive (warning is non-fatal), `else` suppression, partial coverage with one missing constructor, and `_` wildcard suppression. Tests assert return values only — warnings go to stderr and are not captured. Warning format: `[sx] match: non-exhaustive — TypeName: missing Ctor1, Ctor2` Both hosts emit identical messages. Tests: OCaml 4540 → 4545 (+5), JS 2586 → 2591 (+5). Zero regressions. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
487 lines
14 KiB
Plaintext
487 lines
14 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)))))
|
|
(deftest
|
|
"match nested constructor sanity (Phase 6b)"
|
|
(do
|
|
(define-type MaybeP6b (JustP6b v) (NothingP6b))
|
|
(assert= 42 (match (JustP6b 42) ((JustP6b x) x) (else 0)))
|
|
(assert= 0 (match (NothingP6b) ((JustP6b x) x) (else 0)))))
|
|
(deftest
|
|
"match nested constructor binds inner fields"
|
|
(do
|
|
(define-type MaybeN (JustN v) (NothingN))
|
|
(define-type PairN (PairN-of a b))
|
|
(assert=
|
|
3
|
|
(match
|
|
(JustN (PairN-of 1 2))
|
|
((JustN (PairN-of a b)) (+ a b))
|
|
(else 0)))
|
|
(assert=
|
|
0
|
|
(match
|
|
(NothingN)
|
|
((JustN (PairN-of a b)) (+ a b))
|
|
(else 0)))))
|
|
(deftest
|
|
"match nested wildcard ignores inner field"
|
|
(do
|
|
(define-type MaybeW (JustW v) (NothingW))
|
|
(assert=
|
|
"yes"
|
|
(match (JustW 42) ((JustW _) "yes") (else "no")))
|
|
(assert=
|
|
"no"
|
|
(match (NothingW) ((JustW _) "yes") (else "no")))))
|
|
(deftest
|
|
"match nested literal pattern requires equality"
|
|
(do
|
|
(define-type MaybeL (JustL v) (NothingL))
|
|
(assert=
|
|
"literal"
|
|
(match (JustL 42) ((JustL 42) "literal") (else "var")))
|
|
(assert=
|
|
"var"
|
|
(match (JustL 7) ((JustL 42) "literal") (else "var")))))
|
|
(deftest
|
|
"match falls through nested literal to variable clause"
|
|
(do
|
|
(define-type MaybeF (JustF v) (NothingF))
|
|
(assert=
|
|
1
|
|
(match (JustF 1) ((JustF 99) "wrong") ((JustF x) x)))
|
|
(assert=
|
|
"wrong"
|
|
(match (JustF 99) ((JustF 99) "wrong") ((JustF x) x)))))
|
|
(deftest
|
|
"match deeply nested constructors bind innermost"
|
|
(do
|
|
(define-type Wrap1 (W1 inner))
|
|
(define-type Wrap2 (W2 inner))
|
|
(define-type Leaf3 (L3 n))
|
|
(assert=
|
|
7
|
|
(match
|
|
(W1 (W2 (L3 7)))
|
|
((W1 (W2 (L3 n))) n)
|
|
(else 0)))))
|
|
(deftest
|
|
"match nested constructor mixed bind and wildcard"
|
|
(do
|
|
(define-type PairM (PairM-of a b))
|
|
(define-type BoxM (BoxM-of inner))
|
|
(assert=
|
|
10
|
|
(match
|
|
(BoxM-of (PairM-of 10 99))
|
|
((BoxM-of (PairM-of x _)) x)
|
|
(else 0)))
|
|
(assert=
|
|
99
|
|
(match
|
|
(BoxM-of (PairM-of 10 99))
|
|
((BoxM-of (PairM-of _ y)) y)
|
|
(else 0)))))
|
|
(deftest
|
|
"match nested pattern fails when inner ctor differs"
|
|
(do
|
|
(define-type EitherX (LeftX v) (RightX v))
|
|
(define-type WrapX (WX inner))
|
|
(assert=
|
|
"right-1"
|
|
(match
|
|
(WX (RightX 1))
|
|
((WX (LeftX v)) (str "left-" v))
|
|
((WX (RightX v)) (str "right-" v))))
|
|
(assert=
|
|
"left-9"
|
|
(match
|
|
(WX (LeftX 9))
|
|
((WX (LeftX v)) (str "left-" v))
|
|
((WX (RightX v)) (str "right-" v))))))
|
|
(deftest
|
|
"exhaustive match runs without error"
|
|
(do
|
|
(define-type ExA1 (CaA1 v) (CbA1))
|
|
(assert= 1 (match (CaA1 1) ((CaA1 x) x) ((CbA1) 0)))
|
|
(assert= 0 (match (CbA1) ((CaA1 x) x) ((CbA1) 0)))))
|
|
(deftest
|
|
"non-exhaustive match still returns value (warning is non-fatal)"
|
|
(do
|
|
(define-type ExA2 (CaA2 v) (CbA2))
|
|
(assert= 9 (match (CaA2 9) ((CaA2 x) x)))))
|
|
(deftest
|
|
"match with else clause suppresses non-exhaustive warning"
|
|
(do
|
|
(define-type ExA3 (CaA3 v) (CbA3) (CcA3))
|
|
(assert= "a" (match (CaA3 1) ((CaA3 x) "a") (else "other")))
|
|
(assert= "other" (match (CbA3) ((CaA3 x) "a") (else "other")))))
|
|
(deftest
|
|
"match with all-but-one constructor still runs"
|
|
(do
|
|
(define-type ExA4 (CaA4 v) (CbA4) (CcA4))
|
|
(assert= 5 (match (CaA4 5) ((CaA4 x) x) ((CbA4) 0)))
|
|
(assert= 0 (match (CbA4) ((CaA4 x) x) ((CbA4) 0)))))
|
|
(deftest
|
|
"match wildcard pattern suppresses non-exhaustive warning"
|
|
(do
|
|
(define-type ExA5 (CaA5 v) (CbA5))
|
|
(assert= 7 (match (CaA5 7) ((CaA5 x) x) (_ 0)))
|
|
(assert= 0 (match (CbA5) ((CaA5 x) x) (_ 0))))))
|