core/combinators/combinators-tests.factor

   1 USING: accessors arrays combinators combinators.private io
   2 kernel math math.functions prettyprint sequences stack-checker
   3 tools.test words ;
   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 [ get-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 word-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 word-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 word-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
 240 : test-case-7 ( obj -- str )
 241     {
 242         { \ + [ "plus" ] }
 243         { \ - [ "minus" ] }
 244         { \ * [ "times" ] }
 245         { \ / [ "divide" ] }
 246         { \ ^ [ "power" ] }
 247         { \ [ [ "obama" ] }
 248     } case ;
 249
 250 \ test-case-7 def>> must-infer
 251
 252 { "plus" } [ \ + test-case-7 ] unit-test
 253 { "plus" } [ \ + \ test-case-7 def>> call ] unit-test
 254
 255 DEFER: corner-case-1
 256
 257 << \ corner-case-1 2 [ + ] curry 1array [ case ] curry ( a -- b ) define-declared >>
 258
 259 { t } [ \ corner-case-1 word-optimized? ] unit-test
 260
 261 { 4 } [ 2 corner-case-1 ] unit-test
 262 { 4 } [ 2 \ corner-case-1 def>> call ] unit-test
 263
 264 : test-case-8 ( n -- string )
 265     {
 266         { 1 [ "foo" ] }
 267     } case ;
 268
 269 [ 3 test-case-8 ] [ object>> 3 = ] must-fail-with
 270 [ 3 \ test-case-8 def>> call ] [ object>> 3 = ] must-fail-with
 271
 272 : test-case-9 ( a -- b )
 273     {
 274         { \ + [ "plus" ] }
 275         { \ + [ "plus 2" ] }
 276         { \ - [ "minus" ] }
 277         { \ - [ "minus 2" ] }
 278     } case ;
 279
 280 { "plus" } [ \ + test-case-9 ] unit-test
 281 { "plus" } [ \ + \ test-case-9 def>> call ] unit-test
 282
 283 { "minus" } [ \ - test-case-9 ] unit-test
 284 { "minus" } [ \ - \ test-case-9 def>> call ] unit-test
 285
 286 : test-case-10 ( a -- b )
 287     {
 288         { 1 [ "uno" ] }
 289         { 2 [ "dos" ] }
 290         { 2 [ "DOS" ] }
 291         { 3 [ "tres" ] }
 292         { 4 [ "cuatro" ] }
 293         { 5 [ "cinco" ] }
 294     } case ;
 295
 296 { "dos" } [ 2 test-case-10 ] unit-test
 297 { "dos" } [ 2 \ test-case-10 def>> call ] unit-test
 298
 299 : test-case-11 ( a -- b )
 300     {
 301         { 11 [ "uno" ] }
 302         { 22 [ "dos" ] }
 303         { 22 [ "DOS" ] }
 304         { 33 [ "tres" ] }
 305         { 44 [ "cuatro" ] }
 306         { 55 [ "cinco" ] }
 307     } case ;
 308
 309 { "dos" } [ 22 test-case-11 ] unit-test
 310 { "dos" } [ 22 \ test-case-11 def>> call ] unit-test
 311
 312 : test-case-12 ( a -- b )
 313     {
 314         { 11 [ "uno" ] }
 315         { 22 [ "dos" ] }
 316         [ drop "nachos" ]
 317         { 33 [ "tres" ] }
 318         { 44 [ "cuatro" ] }
 319         { 55 [ "cinco" ] }
 320     } case ;
 321
 322 { "nachos" } [ 33 test-case-12 ] unit-test
 323 { "nachos" } [ 33 \ test-case-12 def>> call ] unit-test
 324
 325 { ( x x -- x x ) } [
 326     [ { [ ] [ ] } spread ] infer
 327 ] unit-test
 328
 329 : test-case-13 ( a -- b )
 330     {
 331         { 5 [ 5 ] }
 332         { 6 [ 6 ] }
 333         { 7 [ 7 ] }
 334         { 8 [ 8 ] }
 335         { 9 [ 9 ] }
 336     } case ;
 337
 338 [ 5.0 test-case-13 ] [ no-case? ] must-fail-with
 339
 340 {
 341     [
 342         dup 1 =
 343         [ drop "one" ] [
 344             dup 2 =
 345             [ drop "two" ]
 346             [ dup 3 = [ drop "three" ] [ drop f ] if ] if
 347         ] if
 348     ]
 349 } [
 350     [ drop f ] {
 351         { 1 [ "one" ] }
 352         { 2 [ "two" ] }
 353         { 3 [ "three" ] }
 354     } linear-case-quot
 355 ] unit-test