core/combinators/combinators-tests.factor

   1 USING: alien strings kernel math tools.test io prettyprint
   2 namespaces combinators words classes sequences ;
   3 IN: combinators.tests
   4
   5 ! Compiled
   6 : cond-test-1 ( obj -- str )
   7     {
   8         { [ dup 2 mod 0 = ] [ drop "even" ] }
   9         { [ dup 2 mod 1 = ] [ drop "odd" ] }
  10     } cond ;
  11
  12 \ cond-test-1 must-infer
  13
  14 [ "even" ] [ 2 cond-test-1 ] unit-test
  15 [ "odd" ] [ 3 cond-test-1 ] unit-test
  16
  17 : cond-test-2 ( obj -- str )
  18     {
  19         { [ dup t = ] [ drop "true" ] }
  20         { [ dup f = ] [ drop "false" ] }
  21         [ drop "something else" ]
  22     } cond ;
  23
  24 \ cond-test-2 must-infer
  25
  26 [ "true" ] [ t cond-test-2 ] unit-test
  27 [ "false" ] [ f cond-test-2 ] unit-test
  28 [ "something else" ] [ "ohio" cond-test-2 ] unit-test
  29
  30 : cond-test-3 ( obj -- str )
  31     {
  32         [ drop "something else" ]
  33         { [ dup t = ] [ drop "true" ] }
  34         { [ dup f = ] [ drop "false" ] }
  35     } cond ;
  36
  37 \ cond-test-3 must-infer
  38
  39 [ "something else" ] [ t cond-test-3 ] unit-test
  40 [ "something else" ] [ f cond-test-3 ] unit-test
  41 [ "something else" ] [ "ohio" cond-test-3 ] unit-test
  42
  43 : cond-test-4 ( -- )
  44     {
  45     } cond ;
  46
  47 \ cond-test-4 must-infer
  48
  49 [ cond-test-4 ] [ class \ no-cond = ] must-fail-with
  50
  51 ! Interpreted
  52 [ "even" ] [
  53     2 {
  54         { [ dup 2 mod 0 = ] [ drop "even" ] }
  55         { [ dup 2 mod 1 = ] [ drop "odd" ] }
  56     } cond
  57 ] unit-test
  58
  59 [ "odd" ] [
  60     3 {
  61         { [ dup 2 mod 0 = ] [ drop "even" ] }
  62         { [ dup 2 mod 1 = ] [ drop "odd" ] }
  63     } cond
  64 ] unit-test
  65
  66 [ "neither" ] [
  67     3 {
  68         { [ dup string? ] [ drop "string" ] }
  69         { [ dup float? ] [ drop "float" ] }
  70         { [ dup alien? ] [ drop "alien" ] }
  71         [ drop "neither" ]
  72     } cond
  73 ] unit-test
  74
  75 [ "neither" ] [
  76     3 {
  77         { [ dup string? ] [ drop "string" ] }
  78         { [ dup float? ] [ drop "float" ] }
  79         { [ dup alien? ] [ drop "alien" ] }
  80         [ drop "neither" ]
  81     } cond
  82 ] unit-test
  83
  84 [ "neither" ] [
  85     3 {
  86         { [ dup string? ] [ drop "string" ] }
  87         { [ dup float? ] [ drop "float" ] }
  88         { [ dup alien? ] [ drop "alien" ] }
  89         [ drop "neither" ]
  90     } cond
  91 ] unit-test
  92
  93 [ "early" ] [
  94     2 {
  95         { [ dup 2 mod 1 = ] [ drop "odd" ] }
  96         [ drop "early" ]
  97         { [ dup 2 mod 0 = ] [ drop "even" ] }
  98     } cond
  99 ] unit-test
 100
 101 [ "really early" ] [
 102     2 {
 103        [ drop "really early" ]
 104         { [ dup 2 mod 1 = ] [ drop "odd" ] }
 105         { [ dup 2 mod 0 = ] [ drop "even" ] }
 106     } cond
 107 ] unit-test
 108
 109 [ { } cond ] [ class \ no-cond = ] must-fail-with
 110
 111 [ "early" ] [
 112     2 {
 113         { [ dup 2 mod 1 = ] [ drop "odd" ] }
 114         [ drop "early" ]
 115         { [ dup 2 mod 0 = ] [ drop "even" ] }
 116     } cond
 117 ] unit-test
 118
 119 [ "really early" ] [
 120     2 {
 121         [ drop "really early" ]
 122         { [ dup 2 mod 1 = ] [ drop "odd" ] }
 123         { [ dup 2 mod 0 = ] [ drop "even" ] }
 124     } cond
 125 ] unit-test
 126
 127 [ { } cond ] [ class \ no-cond = ] must-fail-with
 128
 129 ! Compiled
 130 : case-test-1 ( obj -- obj' )
 131     {
 132         { 1 [ "one" ] }
 133         { 2 [ "two" ] }
 134         { 3 [ "three" ] }
 135         { 4 [ "four" ] }
 136     } case ;
 137
 138 \ case-test-1 must-infer
 139
 140 [ "two" ] [ 2 case-test-1 ] unit-test
 141
 142 ! Interpreted
 143 [ "two" ] [ 2 \ case-test-1 def>> call ] unit-test
 144
 145 [ "x" case-test-1 ] must-fail
 146
 147 : case-test-2 ( obj -- obj' )
 148     {
 149         { 1 [ "one" ] }
 150         { 2 [ "two" ] }
 151         { 3 [ "three" ] }
 152         { 4 [ "four" ] }
 153         [ sq ]
 154     } case ;
 155
 156 \ case-test-2 must-infer
 157
 158 [ 25 ] [ 5 case-test-2 ] unit-test
 159
 160 ! Interpreted
 161 [ 25 ] [ 5 \ case-test-2 def>> call ] unit-test
 162
 163 : case-test-3 ( obj -- obj' )
 164     {
 165         { 1 [ "one" ] }
 166         { 2 [ "two" ] }
 167         { 3 [ "three" ] }
 168         { 4 [ "four" ] }
 169         { H{ } [ "a hashtable" ] }
 170         { { 1 2 3 } [ "an array" ] }
 171         [ sq ]
 172     } case ;
 173
 174 \ case-test-3 must-infer
 175
 176 [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
 177
 178 : case-const-1 1 ;
 179 : case-const-2 2 ; inline
 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 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 : case-test-5 ( obj -- )
 200     {
 201         { case-const-1 [ "uno" print ] }
 202         { case-const-2 [ "dos" print ] }
 203         { 3 [ "tres" print ] }
 204         { 4 [ "cuatro" print ] }
 205         { 5 [ "cinco" print ] }
 206         [ drop "demasiado" print ]
 207     } case ;
 208
 209 \ case-test-5 must-infer
 210
 211 [ ] [ 1 case-test-5 ] unit-test
 212
 213 ! Interpreted
 214 [ "uno" ] [
 215     1 {
 216         { case-const-1 [ "uno" ] }
 217         { case-const-2 [ "dos" ] }
 218         { 3 [ "tres" ] }
 219         { 4 [ "cuatro" ] }
 220         { 5 [ "cinco" ] }
 221         [ drop "demasiado" ]
 222     } case
 223 ] unit-test
 224
 225 [ "dos" ] [
 226     2 {
 227         { case-const-1 [ "uno" ] }
 228         { case-const-2 [ "dos" ] }
 229         { 3 [ "tres" ] }
 230         { 4 [ "cuatro" ] }
 231         { 5 [ "cinco" ] }
 232         [ drop "demasiado" ]
 233     } case
 234 ] unit-test
 235
 236 [ "tres" ] [
 237     3 {
 238         { case-const-1 [ "uno" ] }
 239         { case-const-2 [ "dos" ] }
 240         { 3 [ "tres" ] }
 241         { 4 [ "cuatro" ] }
 242         { 5 [ "cinco" ] }
 243         [ drop "demasiado" ]
 244     } case
 245 ] unit-test
 246
 247 [ "demasiado" ] [
 248     100 {
 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 : do-not-call "do not call" throw ;
 259
 260 : test-case-6
 261     {
 262         { \ do-not-call [ "do-not-call" ] }
 263         { 3 [ "three" ] }
 264     } case ;
 265
 266 [ "three" ] [ 3 test-case-6 ] unit-test
 267 [ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
 268
 269 [ "three" ] [
 270     3 {
 271         { \ do-not-call [ "do-not-call" ] }
 272         { 3 [ "three" ] }
 273     } case
 274 ] unit-test
 275
 276 [ "do-not-call" ] [
 277     [ do-not-call ] first {
 278         { \ do-not-call [ "do-not-call" ] }
 279         { 3 [ "three" ] }
 280     } case
 281 ] unit-test
 282
 283 [ "do-not-call" ] [
 284     \ do-not-call {
 285         { \ do-not-call [ "do-not-call" ] }
 286         { 3 [ "three" ] }
 287     } case
 288 ] unit-test
 289
 290 ! Interpreted
 291 [ "a hashtable" ] [ H{ } \ case-test-3 def>> call ] unit-test
 292
 293 [ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
 294 [ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
 295 [ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test
 296 [ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test
 297 [ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test
 298 [ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test