Commit | Line | Data |
---|---|---|
ace75ab7 JG |
1 | ;;; r6rs-enums.test --- Test suite for R6RS (rnrs enums) |
2 | ||
3 | ;; Copyright (C) 2010 Free Software Foundation, Inc. | |
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 | \f | |
19 | ||
20 | (define-module (test-suite test-rnrs-enums) | |
21 | :use-module ((rnrs conditions) :version (6)) | |
22 | :use-module ((rnrs enums) :version (6)) | |
23 | :use-module ((rnrs exceptions) :version (6)) | |
24 | :use-module (test-suite lib)) | |
25 | ||
26 | (define-enumeration foo-enumeration (foo bar baz) make-foo-set) | |
27 | ||
28 | (with-test-prefix "enum-set-universe" | |
29 | (pass-if "universe of an enumeration is itself" | |
30 | (let ((et (make-enumeration '(a b c)))) | |
31 | (eq? (enum-set-universe et) et))) | |
32 | ||
33 | (pass-if "enum-set-universe returns universe" | |
34 | (let* ((et (make-enumeration '(a b c))) | |
35 | (es ((enum-set-constructor et) '(a b)))) | |
36 | (eq? (enum-set-universe es) et)))) | |
37 | ||
38 | (with-test-prefix "enum-set-indexer" | |
39 | (pass-if "indexer returns index of symbol in universe" | |
40 | (let* ((universe (make-enumeration '(a b c))) | |
41 | (set ((enum-set-constructor universe) '(a c))) | |
42 | (indexer (enum-set-indexer set))) | |
43 | (and (eqv? (indexer 'a) 0) (eqv? (indexer 'c) 2)))) | |
44 | ||
45 | (pass-if "indexer returns index of symbol in universe but not set" | |
46 | (let* ((universe (make-enumeration '(a b c))) | |
47 | (set ((enum-set-constructor universe) '(a c))) | |
48 | (indexer (enum-set-indexer set))) | |
49 | (eqv? (indexer 'b) 1))) | |
50 | ||
51 | (pass-if "indexer returns #f for symbol not in universe" | |
52 | (let* ((universe (make-enumeration '(a b c))) | |
53 | (set ((enum-set-constructor universe) '(a b c))) | |
54 | (indexer (enum-set-indexer set))) | |
55 | (eqv? (indexer 'd) #f)))) | |
56 | ||
57 | (with-test-prefix "enum-set->list" | |
58 | (pass-if "enum-set->list returns members in universe order" | |
59 | (let* ((universe (make-enumeration '(a b c d e))) | |
60 | (set ((enum-set-constructor universe) '(d a e c)))) | |
61 | (equal? (enum-set->list set) '(a c d e))))) | |
62 | ||
63 | (with-test-prefix "enum-set-member?" | |
64 | (pass-if "enum-set-member? is #t for set members" | |
65 | (let* ((universe (make-enumeration '(a b c))) | |
66 | (set ((enum-set-constructor universe) '(a b c)))) | |
67 | (enum-set-member? 'a set))) | |
68 | ||
69 | (pass-if "enum-set-member? is #f for set non-members" | |
70 | (let* ((universe (make-enumeration '(a b c))) | |
71 | (set ((enum-set-constructor universe) '(a b c)))) | |
72 | (not (enum-set-member? 'd set)))) | |
73 | ||
74 | (pass-if "enum-set-member? is #f for universe but not set members" | |
75 | (let* ((universe (make-enumeration '(a b c d))) | |
76 | (set ((enum-set-constructor universe) '(a b c)))) | |
77 | (not (enum-set-member? 'd set))))) | |
78 | ||
79 | (with-test-prefix "enum-set-subset?" | |
80 | (pass-if "enum-set-subset? is #t when set1 subset of set2" | |
81 | (let* ((universe (make-enumeration '(a b c d e))) | |
82 | (set1 ((enum-set-constructor universe) '(a b c))) | |
83 | (set2 ((enum-set-constructor universe) '(a b c d)))) | |
84 | (enum-set-subset? set1 set2))) | |
85 | ||
86 | (pass-if "enum-set-subset? is #t when universe and set are subsets" | |
87 | (let* ((universe1 (make-enumeration '(a b c d))) | |
88 | (universe2 (make-enumeration '(a b c d e))) | |
89 | (set1 ((enum-set-constructor universe1) '(a b c))) | |
90 | (set2 ((enum-set-constructor universe2) '(a b c d)))) | |
91 | (enum-set-subset? set1 set2))) | |
92 | ||
93 | (pass-if "enum-set-subset? is #f when set not subset" | |
94 | (let* ((universe (make-enumeration '(a b c d e))) | |
95 | (set1 ((enum-set-constructor universe) '(a b c d))) | |
96 | (set2 ((enum-set-constructor universe) '(a b c)))) | |
97 | (not (enum-set-subset? set1 set2)))) | |
98 | ||
99 | (pass-if "enum-set-subset? is #f when universe not subset" | |
100 | (let* ((universe1 (make-enumeration '(a b c d e))) | |
101 | (universe2 (make-enumeration '(a b c d))) | |
102 | (set1 ((enum-set-constructor universe1) '(a b c))) | |
103 | (set2 ((enum-set-constructor universe2) '(a b c d)))) | |
104 | (not (enum-set-subset? set1 set2))))) | |
105 | ||
106 | (with-test-prefix "enum-set=?" | |
107 | (pass-if "enum-set=? is #t when sets are equal" | |
108 | (let* ((universe1 (make-enumeration '(a b c))) | |
109 | (universe2 (make-enumeration '(a b c))) | |
110 | (set1 ((enum-set-constructor universe1) '(a b c))) | |
111 | (set2 ((enum-set-constructor universe2) '(a b c)))) | |
112 | (enum-set=? set1 set2))) | |
113 | ||
114 | (pass-if "enum-set=? is #f when sets are not equal" | |
115 | (let* ((universe (make-enumeration '(a b c d))) | |
116 | (set1 ((enum-set-constructor universe) '(a b))) | |
117 | (set2 ((enum-set-constructor universe) '(c d)))) | |
118 | (not (enum-set=? set1 set2)))) | |
119 | ||
120 | (pass-if "enum-set=? is #f when universes are not equal" | |
121 | (let* ((universe1 (make-enumeration '(a b c d))) | |
122 | (universe2 (make-enumeration '(a b c d e))) | |
123 | (set1 ((enum-set-constructor universe1) '(a b c d))) | |
124 | (set2 ((enum-set-constructor universe2) '(a b c d)))) | |
125 | (not (enum-set=? set1 set2))))) | |
126 | ||
127 | (with-test-prefix "enum-set-union" | |
128 | (pass-if "&assertion raised on different universes" | |
129 | (guard (condition ((assertion-violation? condition) #t)) | |
130 | (let* ((universe1 (make-enumeration '(a b c))) | |
131 | (universe2 (make-enumeration '(d e f))) | |
132 | (set1 ((enum-set-constructor universe1) '(a b c))) | |
133 | (set2 ((enum-set-constructor universe2) '(d e f)))) | |
134 | (enum-set-union set1 set2) | |
135 | #f))) | |
136 | ||
137 | (pass-if "enum-set-union creates union on overlapping sets" | |
138 | (let* ((universe (make-enumeration '(a b c d e))) | |
139 | (set1 ((enum-set-constructor universe) '(a b c))) | |
140 | (set2 ((enum-set-constructor universe) '(c d e))) | |
141 | (union (enum-set-union set1 set2))) | |
142 | (equal? (enum-set->list union) '(a b c d e)))) | |
143 | ||
144 | (pass-if "enum-set-union creates union on disjoint sets" | |
145 | (let* ((universe (make-enumeration '(a b c d e f))) | |
146 | (set1 ((enum-set-constructor universe) '(a b c))) | |
147 | (set2 ((enum-set-constructor universe) '(d e f))) | |
148 | (union (enum-set-union set1 set2))) | |
015a4aae JG |
149 | (equal? (enum-set->list union) '(a b c d e f)))) |
150 | ||
151 | (pass-if "enum-set-union operates on syntactically-generated sets" | |
152 | (let* ((set1 (make-foo-set foo)) | |
153 | (set2 (make-foo-set bar)) | |
154 | (union (enum-set-union set1 set2))) | |
155 | (equal? (enum-set->list union) '(foo bar))))) | |
ace75ab7 JG |
156 | |
157 | (with-test-prefix "enum-set-intersection" | |
158 | (pass-if "&assertion raised on different universes" | |
159 | (guard (condition ((assertion-violation? condition) #t)) | |
160 | (let* ((universe1 (make-enumeration '(a b c))) | |
161 | (universe2 (make-enumeration '(d e f))) | |
162 | (set1 ((enum-set-constructor universe1) '(a b c))) | |
163 | (set2 ((enum-set-constructor universe2) '(d e f)))) | |
164 | (enum-set-intersection set1 set2) | |
165 | #f))) | |
166 | ||
167 | (pass-if "enum-set-intersection on overlapping sets" | |
168 | (let* ((universe (make-enumeration '(a b c d e))) | |
169 | (set1 ((enum-set-constructor universe) '(a b c))) | |
170 | (set2 ((enum-set-constructor universe) '(c d e))) | |
171 | (intersection (enum-set-intersection set1 set2))) | |
172 | (equal? (enum-set->list intersection) '(c)))) | |
173 | ||
174 | (pass-if "enum-set-intersection on disjoint sets" | |
175 | (let* ((universe (make-enumeration '(a b c d e f))) | |
176 | (set1 ((enum-set-constructor universe) '(a b c))) | |
177 | (set2 ((enum-set-constructor universe) '(d e f))) | |
178 | (intersection (enum-set-intersection set1 set2))) | |
015a4aae JG |
179 | (null? (enum-set->list intersection)))) |
180 | ||
181 | (pass-if "enum-set-intersection on syntactically-generated sets" | |
182 | (let* ((set1 (make-foo-set foo bar)) | |
183 | (set2 (make-foo-set bar baz)) | |
184 | (intersection (enum-set-intersection set1 set2))) | |
185 | (equal? (enum-set->list intersection) '(bar))))) | |
ace75ab7 JG |
186 | |
187 | (with-test-prefix "enum-set-difference" | |
188 | (pass-if "&assertion raised on different universes" | |
189 | (guard (condition ((assertion-violation? condition) #t)) | |
190 | (let* ((universe1 (make-enumeration '(a b c))) | |
191 | (universe2 (make-enumeration '(d e f))) | |
192 | (set1 ((enum-set-constructor universe1) '(a b c))) | |
193 | (set2 ((enum-set-constructor universe2) '(d e f)))) | |
194 | (enum-set-difference set1 set2) | |
195 | #f))) | |
196 | ||
197 | (pass-if "enum-set-difference with subset" | |
198 | (let* ((universe (make-enumeration '(a b c))) | |
199 | (set1 ((enum-set-constructor universe) '(a b c))) | |
200 | (set2 ((enum-set-constructor universe) '(a))) | |
201 | (difference (enum-set-difference set1 set2))) | |
202 | (equal? (enum-set->list difference) '(b c)))) | |
203 | ||
204 | (pass-if "enum-set-difference with superset is empty" | |
205 | (let* ((universe (make-enumeration '(a b c d))) | |
206 | (set1 ((enum-set-constructor universe) '(a b c))) | |
207 | (set2 ((enum-set-constructor universe) '(a b c d))) | |
208 | (difference (enum-set-difference set1 set2))) | |
015a4aae JG |
209 | (null? (enum-set->list difference)))) |
210 | ||
211 | (pass-if "enum-set-difference on syntactically-generated sets" | |
212 | (let* ((set1 (make-foo-set foo bar baz)) | |
213 | (set2 (make-foo-set foo baz)) | |
214 | (difference (enum-set-difference set1 set2))) | |
215 | (equal? (enum-set->list difference) '(bar))))) | |
ace75ab7 JG |
216 | |
217 | (with-test-prefix "enum-set-complement" | |
218 | (pass-if "complement of empty set is universe" | |
219 | (let* ((universe (make-enumeration '(a b c))) | |
220 | (set ((enum-set-constructor universe) '())) | |
221 | (complement (enum-set-complement set))) | |
222 | (equal? (enum-set->list complement) (enum-set->list universe)))) | |
223 | ||
224 | (pass-if "simple complement" | |
225 | (let* ((universe (make-enumeration '(a b c d))) | |
226 | (set ((enum-set-constructor universe) '(a c))) | |
227 | (complement (enum-set-complement set))) | |
228 | (equal? (enum-set->list complement) '(b d))))) | |
229 | ||
230 | (with-test-prefix "enum-set-projection" | |
231 | (pass-if "projection onto subset universe" | |
232 | (let* ((universe1 (make-enumeration '(a b c d))) | |
233 | (universe2 (make-enumeration '(a b c))) | |
234 | (set1 ((enum-set-constructor universe1) '(a d))) | |
235 | (set2 ((enum-set-constructor universe2) '(b c))) | |
236 | (projection (enum-set-projection set1 set2))) | |
237 | (equal? (enum-set->list projection) '(a)))) | |
238 | ||
239 | (pass-if "projection onto superset universe" | |
240 | (let* ((universe1 (make-enumeration '(a b c))) | |
241 | (universe2 (make-enumeration '(a b c d))) | |
242 | (set1 ((enum-set-constructor universe1) '(a c))) | |
243 | (set2 ((enum-set-constructor universe2) '(b d))) | |
244 | (projection (enum-set-projection set1 set2))) | |
245 | (equal? (enum-set->list projection) '(a c)))) | |
246 | ||
247 | (pass-if "projection onto disjoint universe" | |
248 | (let* ((universe1 (make-enumeration '(a b c))) | |
249 | (universe2 (make-enumeration '(d e f))) | |
250 | (set1 ((enum-set-constructor universe1) '(a c))) | |
251 | (set2 ((enum-set-constructor universe2) '(d f))) | |
252 | (projection (enum-set-projection set1 set2))) | |
253 | (equal? (enum-set->list projection) '())))) | |
254 | ||
255 | (with-test-prefix "define-enumeration" | |
256 | (pass-if "define-enumeration creates bindings" | |
257 | (and (defined? 'foo-enumeration) (defined? 'make-foo-set))) | |
258 | ||
259 | (pass-if "type-name syntax raises &syntax on non-member" | |
260 | (guard (condition ((syntax-violation? condition) #t)) | |
261 | (begin (eval '(foo-enumeration a) (current-module)) #f))) | |
262 | ||
263 | (pass-if "type-name evaluates to quote on member" | |
264 | (guard (condition ((syntax-violation? condition) #f)) | |
265 | (eq? (eval '(foo-enumeration foo) (current-module)) 'foo))) | |
266 | ||
267 | (pass-if "constructor-syntax raises &syntax on non-members" | |
268 | (guard (condition ((syntax-violation? condition) #t)) | |
269 | (begin (eval '(make-foo-set foo bar not-baz) (current-module)) #f))) | |
270 | ||
271 | (pass-if "constructor-syntax evaluates to new set" | |
272 | (guard (condition ((syntax-violation? condition) #f)) | |
273 | (equal? (enum-set->list (eval '(make-foo-set foo bar) | |
274 | (current-module))) | |
275 | '(foo bar))))) |