Commit | Line | Data |
---|---|---|
d967913f LC |
1 | ;;;; match.test --- (ice-9 match) -*- mode: scheme; coding: utf-8; -*- |
2 | ;;;; | |
d10f7b57 | 3 | ;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. |
d967913f LC |
4 | ;;;; |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | (define-module (test-match) | |
20 | #:use-module (ice-9 match) | |
5fcb7b3c | 21 | #:use-module (srfi srfi-9) |
d967913f LC |
22 | #:use-module (test-suite lib)) |
23 | ||
24 | (define exception:match-error | |
25 | (cons 'match-error "^.*$")) | |
26 | ||
5fcb7b3c LC |
27 | (define-record-type rtd-2-slots |
28 | (make-2-slot-record a b) | |
29 | two-slot-record? | |
30 | (a slot-first) | |
31 | (b slot-second)) | |
32 | ||
33 | (define-record-type rtd-3-slots | |
34 | (make-3-slot-record a b c) | |
35 | three-slot-record? | |
36 | (a slot-one) | |
37 | (b slot-two) | |
38 | (c slot-three)) | |
39 | ||
d967913f LC |
40 | \f |
41 | (with-test-prefix "matches" | |
42 | ||
43 | (pass-if "wildcard" | |
44 | (match "hello" (_ #t))) | |
45 | ||
46 | (pass-if "symbol" | |
47 | (match 'foo ('foo #t))) | |
48 | ||
49 | (pass-if "string" | |
50 | (match "bar" ("bar" #t))) | |
51 | ||
52 | (pass-if "number" | |
53 | (match 777 (777 #t))) | |
54 | ||
55 | (pass-if "char" | |
56 | (match #\g (#\g #t))) | |
57 | ||
58 | (pass-if "sexp" | |
59 | (match '(a b c) ('(a b c) #t))) | |
60 | ||
61 | (pass-if "predicate" | |
62 | (match '(a 1 2) | |
63 | (('a (and (? odd?) one) (? even?)) | |
64 | (= one 1)))) | |
65 | ||
66 | (pass-if "list" | |
67 | (let ((lst '(a b c))) | |
68 | (match lst | |
69 | ((x y z) | |
70 | (equal? (list x y z) lst))))) | |
71 | ||
72 | (pass-if "list rest..." | |
73 | (let ((lst '(a b c))) | |
74 | (match lst | |
75 | ((x rest ...) | |
76 | (and (eq? x 'a) (equal? rest '(b c))))))) | |
77 | ||
78 | (pass-if "list . rest" | |
79 | (let ((lst '(a b c))) | |
80 | (match lst | |
81 | ((x . rest) | |
82 | (and (eq? x 'a) (equal? rest '(b c))))))) | |
83 | ||
1ffed5aa LC |
84 | (pass-if "list ..1" |
85 | (match '(a b c) | |
86 | ((x ..1) | |
87 | (equal? x '(a b c))))) | |
88 | ||
89 | (pass-if "list ..1, with predicate" | |
90 | (match '(a b c) | |
91 | (((and x (? symbol?)) ..1) | |
92 | (equal? x '(a b c))))) | |
93 | ||
f2ee6341 LC |
94 | (pass-if "list ..1, nested" |
95 | (match '((1 2) (3 4)) | |
96 | (((x ..1) ..1) | |
97 | (equal? x '((1 2) (3 4)))))) | |
98 | ||
d967913f LC |
99 | (pass-if "tree" |
100 | (let ((tree '(one (two 2) (three 3 (and 4 (and 5)))))) | |
101 | (match tree | |
102 | (('one ('two x) ('three y ('and z '(and 5)))) | |
5fcb7b3c LC |
103 | (equal? (list x y z) '(2 3 4)))))) |
104 | ||
8f6dfb9a AW |
105 | (pass-if "and, unique names" |
106 | (let ((tree '(1 2))) | |
107 | (match tree | |
108 | ((and (a 2) (1 b)) | |
109 | (equal? 3 (+ a b)))))) | |
110 | ||
111 | (pass-if "and, same names" | |
112 | (let ((a '(1 2))) | |
113 | (match a | |
114 | ((and (a 2) (1 b)) | |
115 | (equal? 3 (+ a b)))))) | |
116 | ||
5fcb7b3c LC |
117 | (with-test-prefix "records" |
118 | ||
119 | (pass-if "all slots, bind" | |
120 | (let ((r (make-3-slot-record 1 2 3))) | |
121 | (match r | |
122 | (($ rtd-3-slots a b c) | |
123 | (equal? (list a b c) '(1 2 3)))))) | |
124 | ||
125 | (pass-if "all slots, literals" | |
126 | (let ((r (make-3-slot-record 1 2 3))) | |
127 | (match r | |
128 | (($ rtd-3-slots 1 2 3) | |
129 | #t)))) | |
130 | ||
131 | (pass-if "2 slots" | |
132 | (let ((r (make-3-slot-record 1 2 3))) | |
133 | (match r | |
134 | (($ rtd-3-slots x y) | |
135 | (equal? (list x y) '(1 2)))))) | |
136 | ||
137 | (pass-if "RTD correctly checked" | |
138 | (let ((r (make-2-slot-record 1 2))) | |
139 | (match r | |
140 | (($ rtd-3-slots a b) | |
141 | #f) | |
142 | (($ rtd-2-slots a b) | |
143 | (equal? (list a b) '(1 2)))))) | |
144 | ||
145 | (pass-if "getter" | |
146 | (match (make-2-slot-record 1 2) | |
147 | (($ rtd-2-slots (get! first) (get! second)) | |
148 | (equal? (list (first) (second)) '(1 2))))) | |
149 | ||
150 | (pass-if "setter" | |
151 | (let ((r (make-2-slot-record 1 2))) | |
152 | (match r | |
153 | (($ rtd-2-slots (set! set-first!) (set! set-second!)) | |
154 | (set-first! 'one) | |
155 | (set-second! 'two) | |
156 | (equal? (list (slot-first r) (slot-second r)) | |
157 | '(one two)))))))) | |
d967913f LC |
158 | |
159 | \f | |
160 | (with-test-prefix "doesn't match" | |
161 | ||
162 | (pass-if-exception "tree" | |
163 | exception:match-error | |
164 | (match '(a (b c)) | |
1ffed5aa LC |
165 | ((foo (bar)) #t))) |
166 | ||
167 | (pass-if-exception "list ..1" | |
168 | exception:match-error | |
169 | (match '() | |
170 | ((x ..1) #f))) | |
171 | ||
172 | (pass-if-exception "list ..1, with predicate" | |
173 | exception:match-error | |
174 | (match '(a 0) | |
175 | (((and x (? symbol?)) ..1) | |
5fcb7b3c LC |
176 | (equal? x '(a b c))))) |
177 | ||
178 | (with-test-prefix "records" | |
179 | ||
180 | (pass-if "not a record" | |
181 | (match "hello" | |
182 | (($ rtd-2-slots) #f) | |
183 | (_ #t))) | |
184 | ||
185 | (pass-if-exception "too many slots" | |
186 | exception:out-of-range | |
187 | (let ((r (make-3-slot-record 1 2 3))) | |
188 | (match r | |
189 | (($ rtd-3-slots a b c d) | |
190 | #f)))))) | |
191 | ||
192 | \f | |
193 | ;;; | |
194 | ;;; Upstream tests, from Chibi-Scheme (3-clause BSD license). | |
195 | ;;; | |
196 | ||
197 | (let-syntax ((load (syntax-rules () | |
198 | ((_ file) #t))) | |
199 | (test (syntax-rules () | |
200 | ((_ name expected expr) | |
201 | (pass-if name | |
202 | (equal? expected expr))))) | |
203 | (test-begin (syntax-rules () | |
204 | ((_ name) #t))) | |
205 | (test-end (syntax-rules () | |
206 | ((_) #t)))) | |
207 | (with-test-prefix "upstream tests" | |
d10f7b57 | 208 | (include-from-path "tests/match.test.upstream"))) |