core/combinators/combinators-tests.factor

   1 USING: alien strings kernel math tools.test io prettyprint
   2 namespaces combinators words classes sequences accessors
   3 math.functions arrays combinators.private stack-checker ;
   4 IN: 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
 178 CONSTANT: case-const-1 1
 179 CONSTANT: 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
 254 DEFER: 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