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