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 ;
   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 ! Compiled
  39 : cond-test-1 ( obj -- str )
  40     {
  41         { [ dup 2 mod 0 = ] [ drop "even" ] }
  42         { [ dup 2 mod 1 = ] [ drop "odd" ] }
  43     } cond ;
  44
  45 \ cond-test-1 def>> must-infer
  46
  47 [ "even" ] [ 2 cond-test-1 ] unit-test
  48 [ "odd" ] [ 3 cond-test-1 ] unit-test
  49
  50 : cond-test-2 ( obj -- str )
  51     {
  52         { [ dup t = ] [ drop "true" ] }
  53         { [ dup f = ] [ drop "false" ] }
  54         [ drop "something else" ]
  55     } cond ;
  56
  57 \ cond-test-2 def>> must-infer
  58
  59 [ "true" ] [ t cond-test-2 ] unit-test
  60 [ "false" ] [ f cond-test-2 ] unit-test
  61 [ "something else" ] [ "ohio" cond-test-2 ] unit-test
  62
  63 : cond-test-3 ( obj -- str )
  64     {
  65         [ drop "something else" ]
  66         { [ dup t = ] [ drop "true" ] }
  67         { [ dup f = ] [ drop "false" ] }
  68     } cond ;
  69
  70 \ cond-test-3 def>> must-infer
  71
  72 [ "something else" ] [ t cond-test-3 ] unit-test
  73 [ "something else" ] [ f cond-test-3 ] unit-test
  74 [ "something else" ] [ "ohio" cond-test-3 ] unit-test
  75
  76 : cond-test-4 ( -- )
  77     {
  78     } cond ;
  79
  80 \ cond-test-4 def>> must-infer
  81
  82 [ cond-test-4 ] [ class \ no-cond = ] must-fail-with
  83
  84 ! Interpreted
  85 [ "even" ] [
  86     2 {
  87         { [ dup 2 mod 0 = ] [ drop "even" ] }
  88         { [ dup 2 mod 1 = ] [ drop "odd" ] }
  89     } cond
  90 ] unit-test
  91
  92 [ "odd" ] [
  93     3 {
  94         { [ dup 2 mod 0 = ] [ drop "even" ] }
  95         { [ dup 2 mod 1 = ] [ drop "odd" ] }
  96     } cond
  97 ] unit-test
  98
  99 [ "neither" ] [
 100     3 {
 101         { [ dup string? ] [ drop "string" ] }
 102         { [ dup float? ] [ drop "float" ] }
 103         { [ dup alien? ] [ drop "alien" ] }
 104         [ drop "neither" ]
 105     } cond
 106 ] unit-test
 107
 108 [ "neither" ] [
 109     3 {
 110         { [ dup string? ] [ drop "string" ] }
 111         { [ dup float? ] [ drop "float" ] }
 112         { [ dup alien? ] [ drop "alien" ] }
 113         [ drop "neither" ]
 114     } cond
 115 ] unit-test
 116
 117 [ "neither" ] [
 118     3 {
 119         { [ dup string? ] [ drop "string" ] }
 120         { [ dup float? ] [ drop "float" ] }
 121         { [ dup alien? ] [ drop "alien" ] }
 122         [ drop "neither" ]
 123     } cond
 124 ] unit-test
 125
 126 [ "early" ] [
 127     2 {
 128         { [ dup 2 mod 1 = ] [ drop "odd" ] }
 129         [ drop "early" ]
 130         { [ dup 2 mod 0 = ] [ drop "even" ] }
 131     } cond
 132 ] unit-test
 133
 134 [ "really early" ] [
 135     2 {
 136        [ drop "really early" ]
 137         { [ dup 2 mod 1 = ] [ drop "odd" ] }
 138         { [ dup 2 mod 0 = ] [ drop "even" ] }
 139     } cond
 140 ] unit-test
 141
 142 [ { } cond ] [ class \ no-cond = ] must-fail-with
 143
 144 [ "early" ] [
 145     2 {
 146         { [ dup 2 mod 1 = ] [ drop "odd" ] }
 147         [ drop "early" ]
 148         { [ dup 2 mod 0 = ] [ drop "even" ] }
 149     } cond
 150 ] unit-test
 151
 152 [ "really early" ] [
 153     2 {
 154         [ drop "really early" ]
 155         { [ dup 2 mod 1 = ] [ drop "odd" ] }
 156         { [ dup 2 mod 0 = ] [ drop "even" ] }
 157     } cond
 158 ] unit-test
 159
 160 [ { } cond ] [ class \ no-cond = ] must-fail-with
 161
 162 ! Compiled
 163 : case-test-1 ( obj -- obj' )
 164     {
 165         { 1 [ "one" ] }
 166         { 2 [ "two" ] }
 167         { 3 [ "three" ] }
 168         { 4 [ "four" ] }
 169     } case ;
 170
 171 \ case-test-1 def>> must-infer
 172
 173 [ "two" ] [ 2 case-test-1 ] unit-test
 174
 175 ! Interpreted
 176 [ "two" ] [ 2 \ case-test-1 def>> call ] unit-test
 177
 178 [ "x" case-test-1 ] must-fail
 179
 180 : case-test-2 ( obj -- obj' )
 181     {
 182         { 1 [ "one" ] }
 183         { 2 [ "two" ] }
 184         { 3 [ "three" ] }
 185         { 4 [ "four" ] }
 186         [ sq ]
 187     } case ;
 188
 189 \ case-test-2 def>> must-infer
 190
 191 [ 25 ] [ 5 case-test-2 ] unit-test
 192
 193 ! Interpreted
 194 [ 25 ] [ 5 \ case-test-2 def>> call ] unit-test
 195
 196 : case-test-3 ( obj -- obj' )
 197     {
 198         { 1 [ "one" ] }
 199         { 2 [ "two" ] }
 200         { 3 [ "three" ] }
 201         { 4 [ "four" ] }
 202         { H{ } [ "a hashtable" ] }
 203         { { 1 2 3 } [ "an array" ] }
 204         [ sq ]
 205     } case ;
 206
 207 \ case-test-3 def>> must-infer
 208
 209 [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
 210
 211 CONSTANT: case-const-1 1
 212 CONSTANT: case-const-2 2
 213
 214 ! Compiled
 215 : case-test-4 ( obj -- str )
 216     {
 217         { case-const-1 [ "uno" ] }
 218         { case-const-2 [ "dos" ] }
 219         { 3 [ "tres" ] }
 220         { 4 [ "cuatro" ] }
 221         { 5 [ "cinco" ] }
 222         [ drop "demasiado" ]
 223     } case ;
 224
 225 \ case-test-4 def>> must-infer
 226
 227 [ "uno" ] [ 1 case-test-4 ] unit-test
 228 [ "dos" ] [ 2 case-test-4 ] unit-test
 229 [ "tres" ] [ 3 case-test-4 ] unit-test
 230 [ "demasiado" ] [ 100 case-test-4 ] unit-test
 231
 232 : case-test-5 ( obj -- )
 233     {
 234         { case-const-1 [ "uno" print ] }
 235         { case-const-2 [ "dos" print ] }
 236         { 3 [ "tres" print ] }
 237         { 4 [ "cuatro" print ] }
 238         { 5 [ "cinco" print ] }
 239         [ drop "demasiado" print ]
 240     } case ;
 241
 242 \ case-test-5 def>> must-infer
 243
 244 [ ] [ 1 case-test-5 ] unit-test
 245
 246 ! Interpreted
 247 [ "uno" ] [
 248     1 {
 249         { case-const-1 [ "uno" ] }
 250         { case-const-2 [ "dos" ] }
 251         { 3 [ "tres" ] }
 252         { 4 [ "cuatro" ] }
 253         { 5 [ "cinco" ] }
 254         [ drop "demasiado" ]
 255     } case
 256 ] unit-test
 257
 258 [ "dos" ] [
 259     2 {
 260         { case-const-1 [ "uno" ] }
 261         { case-const-2 [ "dos" ] }
 262         { 3 [ "tres" ] }
 263         { 4 [ "cuatro" ] }
 264         { 5 [ "cinco" ] }
 265         [ drop "demasiado" ]
 266     } case
 267 ] unit-test
 268
 269 [ "tres" ] [
 270     3 {
 271         { case-const-1 [ "uno" ] }
 272         { case-const-2 [ "dos" ] }
 273         { 3 [ "tres" ] }
 274         { 4 [ "cuatro" ] }
 275         { 5 [ "cinco" ] }
 276         [ drop "demasiado" ]
 277     } case
 278 ] unit-test
 279
 280 [ "demasiado" ] [
 281     100 {
 282         { case-const-1 [ "uno" ] }
 283         { case-const-2 [ "dos" ] }
 284         { 3 [ "tres" ] }
 285         { 4 [ "cuatro" ] }
 286         { 5 [ "cinco" ] }
 287         [ drop "demasiado" ]
 288     } case
 289 ] unit-test
 290
 291 : do-not-call ( -- * ) "do not call" throw ;
 292
 293 : test-case-6 ( obj -- value )
 294     {
 295         { \ do-not-call [ "do-not-call" ] }
 296         { 3 [ "three" ] }
 297     } case ;
 298
 299 \ test-case-6 def>> must-infer
 300
 301 [ "three" ] [ 3 test-case-6 ] unit-test
 302 [ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
 303
 304 [ "three" ] [
 305     3 {
 306         { \ do-not-call [ "do-not-call" ] }
 307         { 3 [ "three" ] }
 308     } case
 309 ] unit-test
 310
 311 [ "do-not-call" ] [
 312     [ do-not-call ] first {
 313         { \ do-not-call [ "do-not-call" ] }
 314         { 3 [ "three" ] }
 315     } case
 316 ] unit-test
 317
 318 [ "do-not-call" ] [
 319     \ do-not-call {
 320         { \ do-not-call [ "do-not-call" ] }
 321         { 3 [ "three" ] }
 322     } case
 323 ] unit-test
 324
 325 ! Interpreted
 326 [ "a hashtable" ] [ H{ } \ case-test-3 def>> call ] unit-test
 327
 328 [ t ] [ { 1 3 2 } contiguous-range? ] unit-test
 329 [ f ] [ { 1 2 2 4 } contiguous-range? ] unit-test
 330 [ f ] [ { + 3 2 } contiguous-range? ] unit-test
 331 [ f ] [ { 1 0 7 } contiguous-range? ] unit-test
 332 [ f ] [ { 1 1 3 7 } contiguous-range? ] unit-test
 333 [ t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
 334
 335 : test-case-7 ( obj -- str )
 336     {
 337         { \ + [ "plus" ] }
 338         { \ - [ "minus" ] }
 339         { \ * [ "times" ] }
 340         { \ / [ "divide" ] }
 341         { \ ^ [ "power" ] }
 342         { \ [ [ "obama" ] }
 343         { \ ] [ "KFC" ] }
 344     } case ;
 345
 346 \ test-case-7 def>> must-infer
 347
 348 [ "plus" ] [ \ + test-case-7 ] unit-test
 349
 350 ! Some corner cases (no pun intended)
 351 DEFER: corner-case-1
 352
 353 << \ corner-case-1 2 [ + ] curry 1array [ case ] curry (( a -- b )) define-declared >>
 354
 355 [ t ] [ \ corner-case-1 optimized? ] unit-test
 356 [ 4 ] [ 2 corner-case-1 ] unit-test
 357
 358 [ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
 359
 360 : test-case-8 ( n -- string )
 361     {
 362         { 1 [ "foo" ] }
 363     } case ;
 364
 365 [ 3 test-case-8 ]
 366 [ object>> 3 = ] must-fail-with
 367
 368 [
 369     3 {
 370         { 1 [ "foo" ] }
 371     } case
 372 ] [ object>> 3 = ] must-fail-with