~ chicken-core (chicken-5) /tests/match-test.scm

  1(import (chicken load))
  2
  3(load-relative "test.scm")
  4
  5;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6;; run tests
  7
  8(test-begin "match")
  9
 10(test-equal "any" (match 'any (_ 'ok)) 'ok)
 11(test-equal "symbol" (match 'ok (x x)) 'ok)
 12(test-equal "number" (match 28 (28 'ok)) 'ok)
 13(test-equal "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok)
 14(test-equal "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok)
 15(test-equal "null" (match '() (() 'ok)) 'ok)
 16(test-equal "pair" (match '(ok) ((x) x)) 'ok)
 17(test-equal "vector" (match '#(ok) (#(x) x)) 'ok)
 18(test-equal "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok)
 19(test-equal "and empty" (match '(o k) ((and) 'ok)) 'ok)
 20(test-equal "and single" (match 'ok ((and x) x)) 'ok)
 21(test-equal "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok)
 22(test-equal "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok)
 23(test-equal "or single" (match 'ok ((or x) 'ok)) 'ok)
 24(test-equal "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok)
 25(test-equal "not" (match 28 ((not (a . b)) 'ok)) 'ok)
 26(test-equal "pred" (match 28 ((? number?) 'ok)) 'ok)
 27(test-equal "named pred" (match 28 ((? number? x) (+ x 1))) 29)
 28
 29(test-equal "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok)
 30(test-equal "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok)
 31(test-equal "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok)
 32
 33(test-equal "ellipses"
 34            (match '((a . 1) (b . 2) (c . 3))
 35              (((x . y) ___) (list x y)))
 36            '((a b c) (1 2 3)))
 37
 38(test-equal "real ellipses"
 39            (match '((a . 1) (b . 2) (c . 3))
 40              (((x . y) ...) (list x y)))
 41            '((a b c) (1 2 3)))
 42
 43(test-equal "vector ellipses"
 44            (match '#(1 2 3 (a . 1) (b . 2) (c . 3))
 45              (#(a b c (hd . tl) ...) (list a b c hd tl)))
 46            '(1 2 3 (a b c) (1 2 3)))
 47
 48(test-equal "pred ellipses"
 49            (match '(1 2 3)
 50              (((? odd? n) ___) n)
 51              (((? number? n) ___) n))
 52            '(1 2 3))
 53
 54(test-equal "failure continuation"
 55            (match '(1 2)
 56              ((a . b) (=> next) (if (even? a) 'fail (next)))
 57              ((a . b) 'ok))
 58            'ok)
 59
 60(test-equal "let"
 61            (match-let ((x 'ok) (y '(o k)))
 62              y)
 63            '(o k))
 64
 65(test-equal "let*"
 66            (match-let* ((x 'f) (y 'o) ((z w) (list y x)))
 67              (list x y z w))
 68            '(f o o f))
 69
 70(test-equal "getter car"
 71            (match '(1 . 2) (((get! a) . b) (list (a) b)))
 72            '(1 2))
 73
 74(test-equal "getter cdr"
 75            (match '(1 . 2) ((a . (get! b)) (list a (b))))
 76            '(1 2))
 77
 78(test-equal "getter vector"
 79            (match '#(1 2 3) (#((get! a) b c) (list (a) b c)))
 80            '(1 2 3))
 81
 82(test-equal "setter car"
 83            (let ((x '(1 . 2)))
 84              (match x (((set! a) . b) (a 3)))
 85              x)
 86            '(3 . 2))
 87
 88(test-equal "setter cdr"
 89            (let ((x '(1 . 2)))
 90              (match x ((a . (set! b)) (b 3)))
 91              x)
 92            '(1 . 3))
 93
 94(test-equal "setter vector"
 95            (let ((x '#(1 2 3)))
 96              (match x (#(a (set! b) c) (b 0)))
 97              x)
 98            '#(1 0 3))
 99
100(test-equal "single tail"
101            (match '((a . 1) (b . 2) (c . 3))
102              (((x . y) ... last) (list x y last)))
103            '((a b) (1 2) (c . 3)))
104
105(test-equal "single tail 2"
106            (match '((a . 1) (b . 2) 3)
107              (((x . y) ... last) (list x y last)))
108            '((a b) (1 2) 3))
109
110(test-equal "multiple tail"
111            (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
112              (((x . y) ... u v w) (list x y u v w)))
113            '((a b) (1 2) (c . 3) (d . 4) (e . 5)))
114
115(test-equal "Riastradh quasiquote"
116            (match '(1 2 3) (`(1 ,b ,c) (list b c)))
117            '(2 3))
118
119(test-end "match")
120
121(test-exit)