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