| blob | a3610ff7c56d2e31c628fde3de2bc3d05ece2492 |
1 USING: alien arrays definitions generic assocs hashtables io\r
2 kernel math namespaces parser prettyprint sequences strings\r
3 tools.test vectors words quotations classes classes.algebra\r
4 classes.private classes.union classes.mixin classes.predicate\r
5 vectors definitions source-files compiler.units growable\r
6 random stack-checker effects kernel.private sbufs math.order\r
7 classes.tuple accessors ;\r
8 IN: classes.algebra.tests\r
9 \r
10 \ class< must-infer\r
11 \ class-and must-infer\r
12 \ class-or must-infer\r
13 \ flatten-class must-infer\r
14 \ flatten-builtin-class must-infer\r
15 \r
16 : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
17 \r
18 : class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;\r
19 \r
20 [ t ] [ object object object class-and* ] unit-test\r
21 [ t ] [ fixnum object fixnum class-and* ] unit-test\r
22 [ t ] [ object fixnum fixnum class-and* ] unit-test\r
23 [ t ] [ fixnum fixnum fixnum class-and* ] unit-test\r
24 [ t ] [ fixnum integer fixnum class-and* ] unit-test\r
25 [ t ] [ integer fixnum fixnum class-and* ] unit-test\r
26 \r
27 [ t ] [ vector fixnum null class-and* ] unit-test\r
28 [ t ] [ number object number class-and* ] unit-test\r
29 [ t ] [ object number number class-and* ] unit-test\r
30 [ t ] [ slice reversed null class-and* ] unit-test\r
31 [ t ] [ \ f class-not \ f null class-and* ] unit-test\r
32 [ t ] [ \ f class-not \ f object class-or* ] unit-test\r
33 \r
34 TUPLE: first-one ;\r
35 TUPLE: second-one ;\r
36 UNION: both first-one union-class ;\r
37 \r
38 [ t ] [ both tuple classes-intersect? ] unit-test\r
39 [ t ] [ vector virtual-sequence null class-and* ] unit-test\r
40 [ f ] [ vector virtual-sequence classes-intersect? ] unit-test\r
41 \r
42 [ t ] [ number vector class-or sequence classes-intersect? ] unit-test\r
43 \r
44 [ f ] [ number vector class-and sequence classes-intersect? ] unit-test\r
45 \r
46 [ t ] [ \ fixnum \ integer class<= ] unit-test\r
47 [ t ] [ \ fixnum \ fixnum class<= ] unit-test\r
48 [ f ] [ \ integer \ fixnum class<= ] unit-test\r
49 [ t ] [ \ integer \ object class<= ] unit-test\r
50 [ f ] [ \ integer \ null class<= ] unit-test\r
51 [ t ] [ \ null \ object class<= ] unit-test\r
52 \r
53 [ t ] [ \ generic \ word class<= ] unit-test\r
54 [ f ] [ \ word \ generic class<= ] unit-test\r
55 \r
56 [ f ] [ \ reversed \ slice class<= ] unit-test\r
57 [ f ] [ \ slice \ reversed class<= ] unit-test\r
58 \r
59 PREDICATE: no-docs < word "documentation" word-prop not ;\r
60 \r
61 UNION: no-docs-union no-docs integer ;\r
62 \r
63 [ t ] [ no-docs no-docs-union class<= ] unit-test\r
64 [ f ] [ no-docs-union no-docs class<= ] unit-test\r
65 \r
66 TUPLE: a ;\r
67 TUPLE: b ;\r
68 UNION: c a b ;\r
69 \r
70 [ t ] [ \ c \ tuple class<= ] unit-test\r
71 [ f ] [ \ tuple \ c class<= ] unit-test\r
72 \r
73 [ t ] [ \ tuple-class \ class class<= ] unit-test\r
74 [ f ] [ \ class \ tuple-class class<= ] unit-test\r
75 \r
76 TUPLE: tuple-example ;\r
77 \r
78 [ t ] [ \ null \ tuple-example class<= ] unit-test\r
79 [ f ] [ \ object \ tuple-example class<= ] unit-test\r
80 [ f ] [ \ object \ tuple-example class<= ] unit-test\r
81 [ t ] [ \ tuple-example \ tuple class<= ] unit-test\r
82 [ f ] [ \ tuple \ tuple-example class<= ] unit-test\r
83 \r
84 TUPLE: a1 ;\r
85 TUPLE: b1 ;\r
86 TUPLE: c1 ;\r
87 \r
88 UNION: x1 a1 b1 ;\r
89 UNION: y1 a1 c1 ;\r
90 UNION: z1 b1 c1 ;\r
91 \r
92 [ f ] [ z1 x1 y1 class-and class<= ] unit-test\r
93 \r
94 [ t ] [ x1 y1 class-and a1 class<= ] unit-test\r
95 \r
96 [ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test\r
97 \r
98 [ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test\r
99 \r
100 [ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test\r
101 \r
102 [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
103 \r
104 [ f ] [ growable \ hi-tag classes-intersect? ] unit-test\r
105 \r
106 [ t ] [\r
107 growable tuple sequence class-and class<=\r
108 ] unit-test\r
109 \r
110 [ t ] [\r
111 growable assoc class-and tuple class<=\r
112 ] unit-test\r
113 \r
114 [ t ] [ object \ f \ f class-not class-or class<= ] unit-test\r
115 \r
116 [ t ] [ fixnum class-not integer class-and bignum class= ] unit-test\r
117 \r
118 [ f ] [ integer integer class-not classes-intersect? ] unit-test\r
119 \r
120 [ t ] [ array number class-not class<= ] unit-test\r
121 \r
122 [ f ] [ bignum number class-not class<= ] unit-test\r
123 \r
124 [ vector ] [ vector class-not class-not ] unit-test\r
125 \r
126 [ t ] [ fixnum fixnum bignum class-or class<= ] unit-test\r
127 \r
128 [ f ] [ fixnum class-not integer class-and array class<= ] unit-test\r
129 \r
130 [ f ] [ fixnum class-not integer class<= ] unit-test\r
131 \r
132 [ f ] [ number class-not array class<= ] unit-test\r
133 \r
134 [ f ] [ fixnum class-not array class<= ] unit-test\r
135 \r
136 [ t ] [ number class-not integer class-not class<= ] unit-test\r
137 \r
138 [ t ] [ vector array class-not class-and vector class= ] unit-test\r
139 \r
140 [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test\r
141 \r
142 [ f ] [ fixnum class-not integer class<= ] unit-test\r
143 \r
144 [ t ] [ null class-not object class= ] unit-test\r
145 \r
146 [ t ] [ object class-not null class= ] unit-test\r
147 \r
148 [ f ] [ object class-not object class= ] unit-test\r
149 \r
150 [ f ] [ null class-not null class= ] unit-test\r
151 \r
152 [ t ] [\r
153 fixnum class-not\r
154 fixnum fixnum class-not class-or\r
155 class<=\r
156 ] unit-test\r
157 \r
158 ! Test method inlining\r
159 [ f ] [ fixnum { } min-class ] unit-test\r
160 \r
161 [ string ] [\r
162 \ string\r
163 [ integer string array reversed sbuf\r
164 slice vector quotation ]\r
165 sort-classes min-class\r
166 ] unit-test\r
167 \r
168 [ fixnum ] [\r
169 \ fixnum\r
170 [ fixnum integer object ]\r
171 sort-classes min-class\r
172 ] unit-test\r
173 \r
174 [ integer ] [\r
175 \ fixnum\r
176 [ integer float object ]\r
177 sort-classes min-class\r
178 ] unit-test\r
179 \r
180 [ object ] [\r
181 \ word\r
182 [ integer float object ]\r
183 sort-classes min-class\r
184 ] unit-test\r
185 \r
186 [ reversed ] [\r
187 \ reversed\r
188 [ integer reversed slice ]\r
189 sort-classes min-class\r
190 ] unit-test\r
191 \r
192 [ f ] [ null { number fixnum null } min-class ] unit-test\r
193 \r
194 ! Test for hangs?\r
195 : random-class ( -- class ) classes random ;\r
196 \r
197 : random-op ( -- word )\r
198 {\r
199 class-and\r
200 class-or\r
201 class-not\r
202 } random ;\r
203 \r
204 10 [\r
205 [ ] [\r
206 20 [ random-op ] [ ] replicate-as\r
207 [ infer in>> [ random-class ] times ] keep\r
208 call\r
209 drop\r
210 ] unit-test\r
211 ] times\r
212 \r
213 : random-boolean ( -- ? )\r
214 { t f } random ;\r
215 \r
216 : boolean>class ( ? -- class )\r
217 object null ? ;\r
218 \r
219 : random-boolean-op ( -- word )\r
220 {\r
221 and\r
222 or\r
223 not\r
224 xor\r
225 } random ;\r
226 \r
227 : class-xor ( cls1 cls2 -- cls3 )\r
228 [ class-or ] 2keep class-and class-not class-and ;\r
229 \r
230 : boolean-op>class-op ( word -- word' )\r
231 {\r
232 { and class-and }\r
233 { or class-or }\r
234 { not class-not }\r
235 { xor class-xor }\r
236 } at ;\r
237 \r
238 20 [\r
239 [ t ] [\r
240 20 [ random-boolean-op ] [ ] replicate-as dup .\r
241 [ infer in>> [ random-boolean ] replicate dup . ] keep\r
242 \r
243 [ [ [ ] each ] dip call ] 2keep\r
244 \r
245 [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=\r
246 \r
247 =\r
248 ] unit-test\r
249 ] times\r
250 \r
251 SINGLETON: xxx\r
252 UNION: yyy xxx ;\r
253 \r
254 [ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test\r
255 [ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test\r
256 \r
257 [ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test\r
258 [ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test\r
259 \r
260 TUPLE: xa ;\r
261 TUPLE: xb ;\r
262 TUPLE: xc < xa ;\r
263 TUPLE: xd < xb ;\r
264 TUPLE: xe ;\r
265 TUPLE: xf < xb ;\r
266 TUPLE: xg < xb ;\r
267 TUPLE: xh < xb ;\r
268 \r
269 [ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test\r
270 \r
271 INTERSECTION: generic-class generic class ;\r
272 \r
273 [ t ] [ generic-class generic class<= ] unit-test\r
274 [ t ] [ generic-class \ class class<= ] unit-test\r
275 \r
276 ! Later\r
277 [\r
278 [ t ] [ \ class generic class-and generic-class class<= ] unit-test\r
279 [ t ] [ \ class generic class-and generic-class swap class<= ] unit-test\r
280 ] drop\r
281 \r
282 [ t ] [ \ word generic-class classes-intersect? ] unit-test\r
283 [ f ] [ number generic-class classes-intersect? ] unit-test\r
284 \r
285 [ H{ { word word } } ] [ \r
286 generic-class flatten-class\r
287 ] unit-test\r
288 \r
289 [ \ + flatten-class ] must-fail\r
290 \r
291 INTERSECTION: empty-intersection ;\r
292 \r
293 [ t ] [ object empty-intersection class<= ] unit-test\r
294 [ t ] [ empty-intersection object class<= ] unit-test\r
295 [ t ] [ \ f class-not empty-intersection class<= ] unit-test\r
296 [ f ] [ empty-intersection \ f class-not class<= ] unit-test\r
297 [ t ] [ \ number empty-intersection class<= ] unit-test\r
298 [ t ] [ empty-intersection class-not null class<= ] unit-test\r
299 [ t ] [ null empty-intersection class-not class<= ] unit-test\r
300 \r
301 [ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test\r
302 [ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test\r
303 \r
304 [ t ] [ object \ f class-not \ f class-or class<= ] unit-test\r
305 \r
306 [ ] [ object flatten-builtin-class drop ] unit-test\r
307 \r
308 SINGLETON: sa\r
309 SINGLETON: sb\r
310 SINGLETON: sc\r
311 \r
312 [ sa ] [ sa { sa sb sc } min-class ] unit-test\r
313 \r
314 [ +lt+ ] [ integer sequence class<=> ] unit-test\r
315 [ +lt+ ] [ sequence object class<=> ] unit-test\r
316 [ +gt+ ] [ object sequence class<=> ] unit-test\r
317 [ +eq+ ] [ integer integer class<=> ] unit-test\r