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