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 generic.single delegate.protocols
   4 delegate.private assocs see ;
   5 IN: delegate.tests
   6
   7 TUPLE: hello this that ;
   8 C: <hello> hello
   9
  10 TUPLE: goodbye these those ;
  11 C: <goodbye> goodbye
  12
  13 GENERIC: foo ( x -- y )
  14 GENERIC: bar ( a -- b )
  15 GENERIC# whoa 1 ( s t -- w )
  16 PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
  17
  18 : hello-test ( hello/goodbye -- array )
  19     [ hello? ] [ this>> ] [ that>> ] tri 3array ;
  20
  21 CONSULT: baz goodbye these>> ;
  22 M: hello foo this>> ;
  23 M: hello bar hello-test ;
  24 M: hello whoa [ this>> ] dip + ;
  25
  26 GENERIC: bing ( c -- d )
  27 PROTOCOL: bee bing ;
  28 CONSULT: hello goodbye those>> ;
  29 M: hello bing hello-test ;
  30
  31 [ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
  32 [ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
  33 [ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
  34 [ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
  35 [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
  36 [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
  37
  38 [ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval( -- ) ] times ] unit-test
  39 [ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
  40 [ H{ } ] [ bee protocol-consult ] unit-test
  41
  42 [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
  43
  44 GENERIC: one ( a -- b )
  45 M: integer one ;
  46 GENERIC: two ( a -- b )
  47 M: integer two ;
  48 GENERIC: three ( a -- b )
  49 M: integer three ;
  50 GENERIC: four ( a -- b )
  51 M: integer four ;
  52
  53 PROTOCOL: alpha one two ;
  54 PROTOCOL: beta three ;
  55
  56 TUPLE: hey value ;
  57 C: <hey> hey
  58 CONSULT: alpha hey value>> 1 + ;
  59 CONSULT: beta hey value>> 1 - ;
  60
  61 [ 2 ] [ 1 <hey> one ] unit-test
  62 [ 2 ] [ 1 <hey> two ] unit-test
  63 [ 0 ] [ 1 <hey> three ] unit-test
  64 [ { hey } ] [ alpha protocol-users ] unit-test
  65 [ { hey } ] [ beta protocol-users ] unit-test
  66 [ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test
  67 [ f ] [ hey \ two method ] unit-test
  68 [ f ] [ hey \ four method ] unit-test
  69 [ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test
  70 [ { hey } ] [ alpha protocol-users ] unit-test
  71 [ { hey } ] [ beta protocol-users ] unit-test
  72 [ 2 ] [ 1 <hey> one ] unit-test
  73 [ 0 ] [ 1 <hey> two ] unit-test
  74 [ 0 ] [ 1 <hey> three ] unit-test
  75 [ 0 ] [ 1 <hey> four ] unit-test
  76 [ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval( -- ) ] unit-test
  77 [ 2 ] [ 1 <hey> one ] unit-test
  78 [ -1 ] [ 1 <hey> two ] unit-test
  79 [ -1 ] [ 1 <hey> three ] unit-test
  80 [ -1 ] [ 1 <hey> four ] unit-test
  81 [ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test
  82 [ f ] [ hey \ one method ] unit-test
  83
  84 TUPLE: slot-protocol-test-1 a b ;
  85 TUPLE: slot-protocol-test-2 < slot-protocol-test-1 { c integer } ;
  86
  87 TUPLE: slot-protocol-test-3 d ;
  88
  89 CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ;
  90
  91 [ "a" "b" 5 ] [
  92     T{ slot-protocol-test-3 f T{ slot-protocol-test-2 f "a" "b" 5 } }
  93     [ a>> ] [ b>> ] [ c>> ] tri
  94 ] unit-test
  95
  96 GENERIC: do-me ( x -- )
  97
  98 M: f do-me drop ;
  99
 100 [ ] [ f do-me ] unit-test
 101
 102 TUPLE: a-tuple ;
 103
 104 PROTOCOL: silly-protocol do-me ;
 105
 106 ! Replacing a method definition with a consultation would cause problems
 107 [ [ ] ] [
 108     <" IN: delegate.tests
 109     USE: kernel
 110
 111     M: a-tuple do-me drop ; "> <string-reader> "delegate-test" parse-stream
 112 ] unit-test
 113
 114 [ ] [ T{ a-tuple } do-me ] unit-test
 115
 116 ! Change method definition to consultation
 117 [ [ ] ] [
 118     <" IN: delegate.tests
 119     USE: kernel
 120     USE: delegate
 121     CONSULT: silly-protocol a-tuple drop f ; "> <string-reader> "delegate-test" parse-stream
 122 ] unit-test
 123
 124 ! Method should be there
 125 [ ] [ T{ a-tuple } do-me ] unit-test
 126
 127 ! Now try removing the consulation
 128 [ [ ] ] [
 129     <" IN: delegate.tests "> <string-reader> "delegate-test" parse-stream
 130 ] unit-test
 131
 132 ! Method should be gone
 133 [ T{ a-tuple } do-me ] [ no-method? ] must-fail-with
 134
 135 ! A slot protocol issue
 136 DEFER: slot-protocol-test-3
 137 SLOT: y
 138
 139 [ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
 140
 141 [ [ ] ] [
 142     <" IN: delegate.tests
 143 USING: accessors delegate ;
 144 TUPLE: slot-protocol-test-3 x ;
 145 CONSULT: y>> slot-protocol-test-3 x>> ;">
 146     <string-reader> "delegate-test-1" parse-stream
 147 ] unit-test
 148
 149 [ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
 150
 151 [ [ ] ] [
 152     <" IN: delegate.tests
 153 TUPLE: slot-protocol-test-3 x y ;">
 154     <string-reader> "delegate-test-1" parse-stream
 155 ] unit-test
 156
 157 ! We now have a real accessor for the y slot; we don't want it to
 158 ! get lost
 159 [ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
 160
 161 ! We want to be able to override methods after consultation
 162 [ [ ] ] [
 163     <" IN: delegate.tests
 164     USING: delegate kernel sequences delegate.protocols accessors ;
 165     TUPLE: override-method-test seq ;
 166     CONSULT: sequence-protocol override-method-test seq>> ;
 167     M: override-method-test like drop ; ">
 168     <string-reader> "delegate-test-2" parse-stream
 169 ] unit-test
 170
 171 DEFER: seq-delegate
 172
 173 ! See if removing a consultation updates protocol-consult word prop
 174 [ [ ] ] [
 175     <" IN: delegate.tests
 176     USING: accessors delegate delegate.protocols ;
 177     TUPLE: seq-delegate seq ;
 178     CONSULT: sequence-protocol seq-delegate seq>> ;">
 179     <string-reader> "remove-consult-test" parse-stream
 180 ] unit-test
 181
 182 [ t ] [
 183     seq-delegate
 184     sequence-protocol \ protocol-consult word-prop
 185     key?
 186 ] unit-test
 187
 188 [ [ ] ] [
 189     <" IN: delegate.tests
 190     USING: delegate delegate.protocols ;
 191     TUPLE: seq-delegate seq ;">
 192     <string-reader> "remove-consult-test" parse-stream
 193 ] unit-test
 194
 195 [ f ] [
 196     seq-delegate
 197     sequence-protocol \ protocol-consult word-prop
 198     key?
 199 ] unit-test