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