source: project/release/4/matchable/tags/3.5/tests/run.scm @ 33292

Last change on this file since 33292 was 33292, checked in by Alex Shinn, 5 years ago

Adding missing files (fixes issue #1275).

File size: 4.6 KB
Line 
1#;(include "../matchable.scm")
2(use matchable)
3
4(use test)
5
6(test-begin "match")
7
8(test-group "simple"
9  (test-error "no matching" (match 0 (1 'ok)))
10
11  (test "any"  'ok (match 'any (_ 'ok)))
12  (test "symbol"  'ok (match 'ok (x x)))
13  (test "number"  'ok (match 28 (28 'ok)))
14  (test "string"  'ok (match "good" ("bad" 'fail) ("good" 'ok)))
15  (test "literal symbol"  'ok (match 'good ('bad 'fail) ('good 'ok)))
16  (test "null"  'ok (match '() (() 'ok)))
17  (test "pair"  'ok (match '(ok) ((x) x)))
18  (test "vector"  'ok (match '#(ok) (#(x) x)))
19  (test "any doubled"  'ok (match '(1 2) ((_ _) 'ok)))
20  (test "and empty"  'ok (match '(o k) ((and) 'ok)))
21  (test "and single"  'ok (match 'ok ((and x) x)))
22  (test "and double"  'ok (match 'ok ((and (? symbol?) y) 'ok)))
23  (test "or empty"  'ok (match '(o k) ((or) 'fail) (else 'ok)))
24  (test "or single"  'ok (match 'ok ((or x) 'ok)))
25  (test "or double"  'ok (match 'ok ((or (? symbol? y) y) y)))
26  (test "not"  'ok (match 28 ((not (a . b)) 'ok)))
27  (test "pred"  'ok (match 28 ((? number?) 'ok)))
28  (test "named pred"  29 (match 28 ((? number? x) (+ x 1)))))
29
30(test-group "duplicate symbols"
31  (test "duplicate symbols pass"  'ok (match '(ok . ok) ((x . x) x)))
32  (test "duplicate symbols fail"  'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
33  (test "duplicate symbols samth"  'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x))))
34
35(test-group "ellipses"
36  (test "ellipses"
37        '((a b c) (1 2 3))
38        (match '((a . 1) (b . 2) (c . 3))
39               (((x . y) ___) (list x y))))
40
41  (test "real ellipses"
42        '((a b c) (1 2 3))
43        (match '((a . 1) (b . 2) (c . 3))
44               (((x . y) ...) (list x y))))
45
46  (test "vector ellipses"
47        '(1 2 3 (a b c) (1 2 3))
48        (match '#(1 2 3 (a . 1) (b . 2) (c . 3))
49               (#(a b c (hd . tl) ...) (list a b c hd tl))))
50
51  (test "pred ellipses"
52        '(1 2 3)
53        (match '(1 2 3)
54               (((? odd? n) ___) n)
55               (((? number? n) ___) n))))
56
57(test "failure continuation"
58      'ok
59      (match '(1 2)
60             ((a . b) (=> next) (if (even? a) 'fail (next)))
61             ((a . b) 'ok)))
62
63(test-group "let"
64  (test "let"
65        '(o k)
66        (match-let ((x 'ok) (y '(o k)))
67                   y))
68
69  (test "let*"
70        '(f o o f)
71        (match-let* ((x 'f) (y 'o) ((z w) (list y x)))
72                    (list x y z w))))
73
74(test-group "getter/setter"
75  (test "getter car"
76        '(1 2)
77        (match '(1 . 2) (((get! a) . b) (list (a) b))))
78
79  (test "getter cdr"
80        '(1 2)
81        (match '(1 . 2) ((a . (get! b)) (list a (b)))))
82
83  (test "getter vector"
84        '(1 2 3)
85        (match '#(1 2 3) (#((get! a) b c) (list (a) b c))))
86
87  (test "setter car"
88        '(3 . 2)
89        (let ((x '(1 . 2)))
90          (match x (((set! a) . b) (a 3)))
91          x))
92
93  (test "setter cdr"
94        '(1 . 3)
95        (let ((x '(1 . 2)))
96          (match x ((a . (set! b)) (b 3)))
97          x))
98
99  (test "setter vector"
100        '#(1 0 3)
101        (let ((x '#(1 2 3)))
102          (match x (#(a (set! b) c) (b 0)))
103          x)))
104
105#+(not alexpander)
106(test-group "records"
107  (define-record point x y)
108  (define-record-type my-box (make-my-box x) box? (x get-my-box-x))
109
110  (test "record"
111        '(123 456)
112        (match (make-point 123 456) (($ point x y) (list x y))))
113
114  (test "record with different predicate name"
115        'ok
116        (match (make-my-box 'ok) (($ my-box x) x)))
117
118  (test "record with literals"
119        456
120        (match (make-point 123 456)
121          (($ point 123 x) x)
122          (else #f)))
123
124  (test-error "record with @ pattern should fail"
125        (match (make-point 123 456) ((@ point (x a) (y b)) 'ok)))
126
127
128  (test "record nested"
129        '(123 456 789)
130        (match (make-point 123 '(456 789)) (($ point x (y z)) (list x y z))))
131
132  (test "record getter"
133        '(123 456)
134        (let ((p (make-point 123 456)))
135          (match p (($ point x (get! y)) (list x (y))))))
136
137  (test "record setter"
138        '(123 789)
139        (let ((p (make-point 123 456)))
140          (match p (($ point x (set! y)) (y 789)))
141          (list (point-x p) (point-y p)))))
142
143(test-group "tails"
144  (test "single tail"
145        '((a b) (1 2) (c . 3))
146        (match '((a . 1) (b . 2) (c . 3))
147               (((x . y) ... last) (list x y last))))
148
149  (test "single tail 2"
150        '((a b) (1 2) 3)
151        (match '((a . 1) (b . 2) 3)
152               (((x . y) ... last) (list x y last))))
153
154  (test "multiple tail"
155        '((a b) (1 2) (c . 3) (d . 4) (e . 5))
156        (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
157               (((x . y) ... u v w) (list x y u v w)))))
158
159(test "Riastradh quasiquote"
160      '(2 3)
161      (match '(1 2 3) (`(1 ,b ,c) (list b c))))
162
163(test-end "match")
164
165(test-exit)
Note: See TracBrowser for help on using the repository browser.