/core/combinators/combinators-tests.factor

  1USING: alien strings kernel math tools.test io prettyprint
  2namespaces combinators words classes sequences accessors
  3math.functions arrays combinators.private stack-checker ;
  4IN: combinators.tests
  5
  6[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
  7[ 1 2 [ + ] call( -- z ) ] must-fail
  8[ 1 2 [ + ] call( x y -- z a ) ] must-fail
  9[ 1 2 3 { 1 2 3 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
 10[ [ + ] call( x y -- z ) ] must-infer
 11
 12[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
 13[ 1 2 \ + execute( -- z ) ] must-fail
 14[ 1 2 \ + execute( x y -- z a ) ] must-fail
 15[ \ + execute( x y -- z ) ] must-infer
 16
 17: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
 18
 19[ t ] [ \ compile-execute(-test-1 optimized? ] unit-test
 20[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
 21
 22: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
 23
 24[ t ] [ \ compile-execute(-test-2 optimized? ] unit-test
 25[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
 26[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
 27[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
 28[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
 29
 30: compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ;
 31
 32[ t ] [ \ compile-call(-test-1 optimized? ] unit-test
 33[ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test
 34[ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test
 35[ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test
 36[ 4 ] [ 1 3 [ { + } [ ] like call ] compile-call(-test-1 ] unit-test
 37
 38[ [ ] call( -- * ) ] must-fail
 39
 40: compile-call(-test-2 ( -- ) [ ] call( -- * ) ;
 41
 42[ compile-call(-test-2 ] [ wrong-values? ] must-fail-with
 43
 44: compile-call(-test-3 ( quot -- ) call( -- * ) ;
 45
 46[ [ ] compile-call(-test-3 ] [ wrong-values? ] must-fail-with
 47
 48: compile-execute(-test-3 ( a -- ) \ . execute( value -- * ) ;
 49
 50[ 10 compile-execute(-test-3 ] [ wrong-values? ] must-fail-with
 51
 52: compile-execute(-test-4 ( a word -- ) execute( value -- * ) ;
 53
 54[ 10 \ . compile-execute(-test-4 ] [ wrong-values? ] must-fail-with
 55
 56! Cond
 57: cond-test-1 ( obj -- str )
 58    {
 59        { [ dup 2 mod 0 = ] [ drop "even" ] }
 60        { [ dup 2 mod 1 = ] [ drop "odd" ] }
 61    } cond ;
 62
 63\ cond-test-1 def>> must-infer
 64
 65[ "even" ] [ 2 cond-test-1 ] unit-test
 66[ "even" ] [ 2 \ cond-test-1 def>> call ] unit-test
 67[ "odd" ] [ 3 cond-test-1 ] unit-test
 68[ "odd" ] [ 3 \ cond-test-1 def>> call ] unit-test
 69
 70: cond-test-2 ( obj -- str )
 71    {
 72        { [ dup t = ] [ drop "true" ] }
 73        { [ dup f = ] [ drop "false" ] }
 74        [ drop "something else" ]
 75    } cond ;
 76
 77\ cond-test-2 def>> must-infer
 78
 79[ "true" ] [ t cond-test-2 ] unit-test
 80[ "true" ] [ t \ cond-test-2 def>> call ] unit-test
 81[ "false" ] [ f cond-test-2 ] unit-test
 82[ "false" ] [ f \ cond-test-2 def>> call ] unit-test
 83[ "something else" ] [ "ohio" cond-test-2 ] unit-test
 84[ "something else" ] [ "ohio" \ cond-test-2 def>> call ] unit-test
 85
 86: cond-test-3 ( obj -- str )
 87    {
 88        [ drop "something else" ]
 89        { [ dup t = ] [ drop "true" ] }
 90        { [ dup f = ] [ drop "false" ] }
 91    } cond ;
 92
 93\ cond-test-3 def>> must-infer
 94
 95[ "something else" ] [ t cond-test-3 ] unit-test
 96[ "something else" ] [ t \ cond-test-3 def>> call ] unit-test
 97[ "something else" ] [ f cond-test-3 ] unit-test
 98[ "something else" ] [ f \ cond-test-3 def>> call ] unit-test
 99[ "something else" ] [ "ohio" cond-test-3 ] unit-test
100[ "something else" ] [ "ohio" \ cond-test-3 def>> call ] unit-test
101
102: cond-test-4 ( -- )
103    {
104    } cond ;
105
106\ cond-test-4 def>> must-infer
107
108[ cond-test-4 ] [ no-cond? ] must-fail-with
109[ \ cond-test-4 def>> call ] [ no-cond? ] must-fail-with
110
111: cond-test-5 ( a -- b )
112    {
113        { [ dup 2 mod 1 = ] [ drop "odd" ] }
114        [ drop "early" ]
115        { [ dup 2 mod 0 = ] [ drop "even" ] }
116    } cond ;
117
118[ "early" ] [ 2 cond-test-5 ] unit-test
119[ "early" ] [ 2 \ cond-test-5 def>> call ] unit-test
120
121: cond-test-6 ( a -- b )
122    {
123       [ drop "really early" ]
124       { [ dup 2 mod 1 = ] [ drop "odd" ] }
125       { [ dup 2 mod 0 = ] [ drop "even" ] }
126    } cond ;
127
128[ "really early" ] [ 2 cond-test-6 ] unit-test
129[ "really early" ] [ 2 \ cond-test-6 def>> call ] unit-test
130
131! Case
132: case-test-1 ( obj -- obj' )
133    {
134        { 1 [ "one" ] }
135        { 2 [ "two" ] }
136        { 3 [ "three" ] }
137        { 4 [ "four" ] }
138    } case ;
139
140\ case-test-1 def>> must-infer
141
142[ "two" ] [ 2 case-test-1 ] unit-test
143[ "two" ] [ 2 \ case-test-1 def>> call ] unit-test
144
145[ "x" case-test-1 ] must-fail
146[ "x" \ case-test-1 def>> call ] must-fail
147
148: case-test-2 ( obj -- obj' )
149    {
150        { 1 [ "one" ] }
151        { 2 [ "two" ] }
152        { 3 [ "three" ] }
153        { 4 [ "four" ] }
154        [ sq ]
155    } case ;
156
157\ case-test-2 def>> must-infer
158
159[ 25 ] [ 5 case-test-2 ] unit-test
160[ 25 ] [ 5 \ case-test-2 def>> call ] unit-test
161
162: case-test-3 ( obj -- obj' )
163    {
164        { 1 [ "one" ] }
165        { 2 [ "two" ] }
166        { 3 [ "three" ] }
167        { 4 [ "four" ] }
168        { H{ } [ "a hashtable" ] }
169        { { 1 2 3 } [ "an array" ] }
170        [ sq ]
171    } case ;
172
173\ case-test-3 def>> must-infer
174
175[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
176[ "an array" ] [ { 1 2 3 } \ case-test-3 def>> call ] unit-test
177
178CONSTANT: case-const-1 1
179CONSTANT: case-const-2 2
180
181! Compiled
182: case-test-4 ( obj -- str )
183    {
184        { case-const-1 [ "uno" ] }
185        { case-const-2 [ "dos" ] }
186        { 3 [ "tres" ] }
187        { 4 [ "cuatro" ] }
188        { 5 [ "cinco" ] }
189        [ drop "demasiado" ]
190    } case ;
191
192\ case-test-4 def>> must-infer
193
194[ "uno" ] [ 1 case-test-4 ] unit-test
195[ "dos" ] [ 2 case-test-4 ] unit-test
196[ "tres" ] [ 3 case-test-4 ] unit-test
197[ "demasiado" ] [ 100 case-test-4 ] unit-test
198
199[ "uno" ] [ 1 \ case-test-4 def>> call ] unit-test
200[ "dos" ] [ 2 \ case-test-4 def>> call ] unit-test
201[ "tres" ] [ 3 \ case-test-4 def>> call ] unit-test
202[ "demasiado" ] [ 100 \ case-test-4 def>> call ] unit-test
203
204: case-test-5 ( obj -- )
205    {
206        { case-const-1 [ "uno" print ] }
207        { case-const-2 [ "dos" print ] }
208        { 3 [ "tres" print ] }
209        { 4 [ "cuatro" print ] }
210        { 5 [ "cinco" print ] }
211        [ drop "demasiado" print ]
212    } case ;
213
214\ case-test-5 def>> must-infer
215
216[ ] [ 1 case-test-5 ] unit-test
217[ ] [ 1 \ case-test-5 def>> call ] unit-test
218
219: do-not-call ( -- * ) "do not call" throw ;
220
221: test-case-6 ( obj -- value )
222    {
223        { \ do-not-call [ "do-not-call" ] }
224        { 3 [ "three" ] }
225    } case ;
226
227\ test-case-6 def>> must-infer
228
229[ "three" ] [ 3 test-case-6 ] unit-test
230[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
231
232[ t ] [ { 1 3 2 } contiguous-range? ] unit-test
233[ f ] [ { 1 2 2 4 } contiguous-range? ] unit-test
234[ f ] [ { + 3 2 } contiguous-range? ] unit-test
235[ f ] [ { 1 0 7 } contiguous-range? ] unit-test
236[ f ] [ { 1 1 3 7 } contiguous-range? ] unit-test
237[ t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
238
239: test-case-7 ( obj -- str )
240    {
241        { \ + [ "plus" ] }
242        { \ - [ "minus" ] }
243        { \ * [ "times" ] }
244        { \ / [ "divide" ] }
245        { \ ^ [ "power" ] }
246        { \ [ [ "obama" ] }
247    } case ;
248
249\ test-case-7 def>> must-infer
250
251[ "plus" ] [ \ + test-case-7 ] unit-test
252[ "plus" ] [ \ + \ test-case-7 def>> call ] unit-test
253
254DEFER: corner-case-1
255
256<< \ corner-case-1 2 [ + ] curry 1array [ case ] curry ( a -- b ) define-declared >>
257
258[ t ] [ \ corner-case-1 optimized? ] unit-test
259
260[ 4 ] [ 2 corner-case-1 ] unit-test
261[ 4 ] [ 2 \ corner-case-1 def>> call ] unit-test
262
263: test-case-8 ( n -- string )
264    {
265        { 1 [ "foo" ] }
266    } case ;
267
268[ 3 test-case-8 ] [ object>> 3 = ] must-fail-with
269[ 3 \ test-case-8 def>> call ] [ object>> 3 = ] must-fail-with
270
271: test-case-9 ( a -- b )
272    {
273        { \ + [ "plus" ] }
274        { \ + [ "plus 2" ] }
275        { \ - [ "minus" ] }
276        { \ - [ "minus 2" ] }
277    } case ;
278
279[ "plus" ] [ \ + test-case-9 ] unit-test
280[ "plus" ] [ \ + \ test-case-9 def>> call ] unit-test
281
282[ "minus" ] [ \ - test-case-9 ] unit-test
283[ "minus" ] [ \ - \ test-case-9 def>> call ] unit-test
284
285: test-case-10 ( a -- b )
286    {
287        { 1 [ "uno" ] }
288        { 2 [ "dos" ] }
289        { 2 [ "DOS" ] }
290        { 3 [ "tres" ] }
291        { 4 [ "cuatro" ] }
292        { 5 [ "cinco" ] }
293    } case ;
294
295[ "dos" ] [ 2 test-case-10 ] unit-test
296[ "dos" ] [ 2 \ test-case-10 def>> call ] unit-test
297
298: test-case-11 ( a -- b )
299    {
300        { 11 [ "uno" ] }
301        { 22 [ "dos" ] }
302        { 22 [ "DOS" ] }
303        { 33 [ "tres" ] }
304        { 44 [ "cuatro" ] }
305        { 55 [ "cinco" ] }
306    } case ;
307
308[ "dos" ] [ 22 test-case-11 ] unit-test
309[ "dos" ] [ 22 \ test-case-11 def>> call ] unit-test
310
311: test-case-12 ( a -- b )
312    {
313        { 11 [ "uno" ] }
314        { 22 [ "dos" ] }
315        [ drop "nachos" ]
316        { 33 [ "tres" ] }
317        { 44 [ "cuatro" ] }
318        { 55 [ "cinco" ] }
319    } case ;
320
321[ "nachos" ] [ 33 test-case-12 ] unit-test
322[ "nachos" ] [ 33 \ test-case-12 def>> call ] unit-test
323
324[ ( x x -- x x ) ] [
325    [ { [ ] [ ] } spread ] infer
326] unit-test