rose-ash/spec/tests/test-adt.sx

(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
    "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)))))
)