basis/delegate/delegate-tests.factor

   1 USING: delegate kernel arrays tools.test words math definitions
   2 compiler.units parser generic prettyprint io.streams.string
   3 accessors eval multiline ;
   4 IN: delegate.tests
   5
   6 TUPLE: hello this that ;
   7 C: <hello> hello
   8
   9 TUPLE: goodbye these those ;
  10 C: <goodbye> goodbye
  11
  12 GENERIC: foo ( x -- y )
  13 GENERIC: bar ( a -- b )
  14 GENERIC# whoa 1 ( s t -- w )
  15 PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
  16
  17 : hello-test ( hello/goodbye -- array )
  18     [ hello? ] [ this>> ] [ that>> ] tri 3array ;
  19
  20 CONSULT: baz goodbye these>> ;
  21 M: hello foo this>> ;
  22 M: hello bar hello-test ;
  23 M: hello whoa [ this>> ] dip + ;
  24
  25 GENERIC: bing ( c -- d )
  26 PROTOCOL: bee bing ;
  27 CONSULT: hello goodbye those>> ;
  28 M: hello bing hello-test ;
  29
  30 [ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
  31 [ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
  32 [ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
  33 [ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
  34 [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
  35 [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
  36
  37 [ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test
  38 [ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test
  39 [ H{ } ] [ bee protocol-consult ] unit-test
  40
  41 [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
  42
  43 GENERIC: one
  44 M: integer one ;
  45 GENERIC: two
  46 M: integer two ;
  47 GENERIC: three
  48 M: integer three ;
  49 GENERIC: four
  50 M: integer four ;
  51
  52 PROTOCOL: alpha one two ;
  53 PROTOCOL: beta three ;
  54
  55 TUPLE: hey value ;
  56 C: <hey> hey
  57 CONSULT: alpha hey value>> 1+ ;
  58 CONSULT: beta hey value>> 1- ;
  59
  60 [ 2 ] [ 1 <hey> one ] unit-test
  61 [ 2 ] [ 1 <hey> two ] unit-test
  62 [ 0 ] [ 1 <hey> three ] unit-test
  63 [ { hey } ] [ alpha protocol-users ] unit-test
  64 [ { hey } ] [ beta protocol-users ] unit-test
  65 [ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test
  66 [ f ] [ hey \ two method ] unit-test
  67 [ f ] [ hey \ four method ] unit-test
  68 [ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test
  69 [ { hey } ] [ alpha protocol-users ] unit-test
  70 [ { hey } ] [ beta protocol-users ] unit-test
  71 [ 2 ] [ 1 <hey> one ] unit-test
  72 [ 0 ] [ 1 <hey> two ] unit-test
  73 [ 0 ] [ 1 <hey> three ] unit-test
  74 [ 0 ] [ 1 <hey> four ] unit-test
  75 [ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test
  76 [ 2 ] [ 1 <hey> one ] unit-test
  77 [ -1 ] [ 1 <hey> two ] unit-test
  78 [ -1 ] [ 1 <hey> three ] unit-test
  79 [ -1 ] [ 1 <hey> four ] unit-test
  80 [ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
  81 [ f ] [ hey \ one method ] unit-test
  82
  83 TUPLE: slot-protocol-test-1 a b ;
  84 TUPLE: slot-protocol-test-2 < slot-protocol-test-1 { c integer } ;
  85
  86 TUPLE: slot-protocol-test-3 d ;
  87
  88 CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ;
  89
  90 [ "a" "b" 5 ] [
  91     T{ slot-protocol-test-3 f T{ slot-protocol-test-2 f "a" "b" 5 } }
  92     [ a>> ] [ b>> ] [ c>> ] tri
  93 ] unit-test
  94
  95 GENERIC: do-me ( x -- )
  96
  97 M: f do-me drop ;
  98
  99 [ ] [ f do-me ] unit-test
 100
 101 TUPLE: a-tuple ;
 102
 103 PROTOCOL: silly-protocol do-me ;
 104
 105 ! Replacing a method definition with a consultation would cause problems
 106 [ [ ] ] [
 107     <" IN: delegate.tests
 108     USE: kernel
 109
 110     M: a-tuple do-me drop ; "> <string-reader> "delegate-test" parse-stream
 111 ] unit-test
 112
 113 [ ] [ T{ a-tuple } do-me ] unit-test
 114
 115 [ [ ] ] [
 116     <" IN: delegate.tests
 117     USE: kernel
 118     USE: delegate
 119     CONSULT: silly-protocol a-tuple drop f ; "> <string-reader> "delegate-test" parse-stream
 120 ] unit-test
 121
 122 [ ] [ T{ a-tuple } do-me ] unit-test
 123
 124 ! A slot protocol issue
 125 DEFER: slot-protocol-test-3
 126 SLOT: y
 127
 128 [ f ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
 129
 130 [ [ ] ] [
 131     <" IN: delegate.tests
 132 USING: accessors delegate ;
 133 TUPLE: slot-protocol-test-3 x ;
 134 CONSULT: y>> slot-protocol-test-3 x>> ;">
 135     <string-reader> "delegate-test-1" parse-stream
 136 ] unit-test
 137
 138 [ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
 139
 140 [ [ ] ] [
 141     <" IN: delegate.tests
 142 TUPLE: slot-protocol-test-3 x y ;">
 143     <string-reader> "delegate-test-1" parse-stream
 144 ] unit-test
 145
 146 [ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test