source: project/matchable/matchable-test.scm @ 5888

Last change on this file since 5888 was 5888, checked in by Alex Shinn, 12 years ago

Fixing quasiquote patterns.

File size: 7.0 KB
Line 
1
2;; (require-extension syntactic-closures)
3;; (load "./matchable.scm")
4
5;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6;; SRFI-64 subset
7
8(define *pass* 0)
9(define *fail* 0)
10(define *start* 0)
11
12(define (run-test name thunk expect eq pass-msg fail-msg)
13  (let ((result (thunk)))
14    (cond
15      ((eq expect result)
16       (set! *pass* (+ *pass* 1))
17       (format-result pass-msg name expect result))
18      (else
19       (set! *fail* (+ *fail* 1))
20       (format-result fail-msg name expect result)))))
21
22(define (format-result ls name expect result)
23  (let lp ((ls ls))
24    (cond
25      ((null? ls) (newline))
26      ((eq? (car ls) 'expect) (display expect) (lp (cdr ls)))
27      ((eq? (car ls) 'result) (display result) (lp (cdr ls)))
28      ((eq? (car ls) 'name) (if name (begin (display #\space) (display name))) (lp (cdr ls)))
29      (else (display (car ls)) (lp (cdr ls))))))
30
31(define (test-begin . o)
32  (set! *pass* 0)
33  (set! *fail* 0)
34  (set! *start* (current-milliseconds)))
35
36(define (format-float n prec)
37  (let* ((str (number->string n))
38         (len (string-length str)))
39    (let lp ((i (- len 1)))
40      (cond
41        ((negative? i)
42         (string-append str "." (make-string prec #\0)))
43        ((eqv? #\. (string-ref str i))
44         (let ((diff (+ 1 (- prec (- len i)))))
45           (cond
46             ((positive? diff)
47              (string-append str (make-string diff #\0)))
48             ((negative? diff)
49              (substring str 0 (+ i prec 1)))
50             (else
51              str))))
52        (else
53         (lp (- i 1)))))))
54
55(define (format-percent num denom)
56  (let ((x (if (zero? denom) num (exact->inexact (/ num denom)))))
57    (format-float (* 100 x) 2)))
58
59(define (test-end . o)
60  (let ((end (current-milliseconds))
61        (total (+ *pass* *fail*)))
62    (printf "  ~A tests completed in ~A seconds\n"
63            total (format-float (exact->inexact (/ (- end *start*) 1000)) 3))
64    (printf "  ~A (~A%) tests passed\n"
65            *pass* (format-percent *pass* total))
66    (printf "  ~A (~A%) tests failed\n"
67            *fail* (format-percent *fail* total))))
68
69(define-syntax test-assert
70  (syntax-rules ()
71    ((_ name expr) (run-assert name (lambda () expr)))
72    ((_ expr) (run-assert 'expr (lambda () expr)))))
73
74(define (run-equal name thunk expect eq)
75  (run-test name thunk expect eq
76            '("(PASS)" name)
77            '("(FAIL)" name ": expected " expect " but got " result)))
78
79(define-syntax test-equal
80  (syntax-rules ()
81    ((_ name expr value eq) (run-equal name (lambda () expr) value eq))
82    ((_ name expr value) (run-equal name (lambda () expr) value equal?))
83    ((_ expr value) (run-assert 'expr (lambda () expr) value equal?))))
84
85;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86;; run tests
87
88(test-begin "match")
89
90(test-equal "any" (match 'any (_ 'ok)) 'ok)
91(test-equal "symbol" (match 'ok (x x)) 'ok)
92(test-equal "number" (match 28 (28 'ok)) 'ok)
93(test-equal "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok)
94(test-equal "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok)
95(test-equal "null" (match '() (() 'ok)) 'ok)
96(test-equal "pair" (match '(ok) ((x) x)) 'ok)
97(test-equal "vector" (match '#(ok) (#(x) x)) 'ok)
98(test-equal "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok)
99(test-equal "and empty" (match '(o k) ((and) 'ok)) 'ok)
100(test-equal "and single" (match 'ok ((and x) x)) 'ok)
101(test-equal "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok)
102(test-equal "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok)
103(test-equal "or single" (match 'ok ((or x) 'ok)) 'ok)
104(test-equal "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok)
105(test-equal "not" (match 28 ((not (a . b)) 'ok)) 'ok)
106(test-equal "pred" (match 28 ((? number?) 'ok)) 'ok)
107(test-equal "named pred" (match 28 ((? number? x) (+ x 1))) 29)
108
109(test-equal "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok)
110(test-equal "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok)
111(test-equal "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok)
112
113(test-equal "ellipses"
114            (match '((a . 1) (b . 2) (c . 3))
115              (((x . y) ___) (list x y)))
116            '((a b c) (1 2 3)))
117
118(test-equal "real ellipses"
119            (match '((a . 1) (b . 2) (c . 3))
120              (((x . y) ...) (list x y)))
121            '((a b c) (1 2 3)))
122
123(test-equal "vector ellipses"
124            (match '#(1 2 3 (a . 1) (b . 2) (c . 3))
125              (#(a b c (hd . tl) ...) (list a b c hd tl)))
126            '(1 2 3 (a b c) (1 2 3)))
127
128(test-equal "pred ellipses"
129            (match '(1 2 3)
130              (((? odd? n) ___) n)
131              (((? number? n) ___) n))
132            '(1 2 3))
133
134(test-equal "failure continuation"
135            (match '(1 2)
136              ((a . b) (=> next) (if (even? a) 'fail (next)))
137              ((a . b) 'ok))
138            'ok)
139
140(test-equal "let"
141            (match-let ((x 'ok) (y '(o k)))
142              y)
143            '(o k))
144
145(test-equal "let*"
146            (match-let* ((x 'f) (y 'o) ((z w) (list y x)))
147              (list x y z w))
148            '(f o o f))
149
150(test-equal "getter car"
151            (match '(1 . 2) (((get! a) . b) (list (a) b)))
152            '(1 2))
153
154(test-equal "getter cdr"
155            (match '(1 . 2) ((a . (get! b)) (list a (b))))
156            '(1 2))
157
158(test-equal "getter vector"
159            (match '#(1 2 3) (#((get! a) b c) (list (a) b c)))
160            '(1 2 3))
161
162(test-equal "setter car"
163            (let ((x '(1 . 2)))
164              (match x (((set! a) . b) (a 3)))
165              x)
166            '(3 . 2))
167
168(test-equal "setter cdr"
169            (let ((x '(1 . 2)))
170              (match x ((a . (set! b)) (b 3)))
171              x)
172            '(1 . 3))
173
174(test-equal "setter vector"
175            (let ((x '#(1 2 3)))
176              (match x (#(a (set! b) c) (b 0)))
177              x)
178            '#(1 0 3))
179
180(define-record point x y)
181
182(test-equal "record"
183            (match (make-point 123 456) (($ point x y) (list x y)))
184            '(123 456))
185
186(test-equal "record nested"
187            (match (make-point 123 '(456 789)) (($ point x (y z)) (list x y z)))
188            '(123 456 789))
189
190(test-equal "record getter"
191            (let ((p (make-point 123 456)))
192              (match p (($ point x (get! y)) (list x (y)))))
193            '(123 456))
194
195(test-equal "record setter"
196            (let ((p (make-point 123 456)))
197              (match p (($ point x (set! y)) (y 789)))
198              (list (point-x p) (point-y p)))
199            '(123 789))
200
201(test-equal "single tail"
202            (match '((a . 1) (b . 2) (c . 3))
203              (((x . y) ... last) (list x y last)))
204            '((a b) (1 2) (c . 3)))
205
206(test-equal "single tail 2"
207            (match '((a . 1) (b . 2) 3)
208              (((x . y) ... last) (list x y last)))
209            '((a b) (1 2) 3))
210
211(test-equal "multiple tail"
212            (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
213              (((x . y) ... u v w) (list x y u v w)))
214            '((a b) (1 2) (c . 3) (d . 4) (e . 5)))
215
216(test-equal "Riastradh quasiquote"
217            (match '(1 2 3) (`(1 ,b ,c) (list b c)))
218            '(2 3))
219
220(test-end "match")
221
Note: See TracBrowser for help on using the repository browser.