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 make ;
   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 ?lookup-method ] unit-test
  68 { f } [ hey \ four ?lookup-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 ?lookup-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 TUPLE: slot-protocol-test-4 { x read-only } ;
  97
  98 TUPLE: slot-protocol-test-5 { a-read-only-slot read-only } ;
  99
 100 CONSULT: slot-protocol-test-5 slot-protocol-test-4 x>> ;
 101
 102 { "hey" } [
 103     "hey" slot-protocol-test-5 boa slot-protocol-test-4 boa
 104     a-read-only-slot>>
 105 ] unit-test
 106
 107 GENERIC: do-me ( x -- )
 108
 109 M: f do-me drop ;
 110
 111 { } [ f do-me ] unit-test
 112
 113 TUPLE: a-tuple ;
 114
 115 PROTOCOL: silly-protocol do-me ;
 116
 117 ! Replacing a method definition with a consultation would cause problems
 118 { [ ] } [
 119     "IN: delegate.tests
 120     USE: kernel
 121
 122     M: a-tuple do-me drop ;" <string-reader> "delegate-test" parse-stream
 123 ] unit-test
 124
 125 { } [ T{ a-tuple } do-me ] unit-test
 126
 127 ! Change method definition to consultation
 128 { [ ] } [
 129     "IN: delegate.tests
 130     USE: kernel
 131     USE: delegate
 132     CONSULT: silly-protocol a-tuple drop f ; " <string-reader> "delegate-test" parse-stream
 133 ] unit-test
 134
 135 ! Method should be there
 136 { } [ T{ a-tuple } do-me ] unit-test
 137
 138 ! Now try removing the consultation
 139 { [ ] } [
 140     "IN: delegate.tests" <string-reader> "delegate-test" parse-stream
 141 ] unit-test
 142
 143 ! Method should be gone
 144 [ T{ a-tuple } do-me ] [ no-method? ] must-fail-with
 145
 146 ! A slot protocol issue
 147 DEFER: slot-protocol-test-3
 148 SLOT: y
 149
 150 { f } [ \ slot-protocol-test-3 \ y>> ?lookup-method >boolean ] unit-test
 151
 152 { [ ] } [
 153     "IN: delegate.tests
 154 USING: accessors delegate ;
 155 TUPLE: slot-protocol-test-3 x ;
 156 CONSULT: y>> slot-protocol-test-3 x>> ;"
 157     <string-reader> "delegate-test-1" parse-stream
 158 ] unit-test
 159
 160 { t } [ \ slot-protocol-test-3 \ y>> ?lookup-method >boolean ] unit-test
 161
 162 { [ ] } [
 163     "IN: delegate.tests
 164 TUPLE: slot-protocol-test-3 x y ;"
 165     <string-reader> "delegate-test-1" parse-stream
 166 ] unit-test
 167
 168 ! We now have a real accessor for the y slot; we don't want it to
 169 ! get lost
 170 { t } [ \ slot-protocol-test-3 \ y>> ?lookup-method >boolean ] unit-test
 171
 172 ! We want to be able to override methods after consultation
 173 { [ ] } [
 174     "IN: delegate.tests
 175     USING: delegate kernel sequences delegate.protocols accessors ;
 176     TUPLE: override-method-test seq ;
 177     CONSULT: sequence-protocol override-method-test seq>> ;
 178     M: override-method-test like drop ; "
 179     <string-reader> "delegate-test-2" parse-stream
 180 ] unit-test
 181
 182 DEFER: seq-delegate
 183
 184 ! See if removing a consultation updates protocol-consult word prop
 185 { [ ] } [
 186     "IN: delegate.tests
 187     USING: accessors delegate delegate.protocols ;
 188     TUPLE: seq-delegate seq ;
 189     CONSULT: sequence-protocol seq-delegate seq>> ;"
 190     <string-reader> "remove-consult-test" parse-stream
 191 ] unit-test
 192
 193 { t } [
 194     seq-delegate
 195     sequence-protocol "protocol-consult" word-prop
 196     key?
 197 ] unit-test
 198
 199 { [ ] } [
 200     "IN: delegate.tests
 201     USING: delegate delegate.protocols ;
 202     TUPLE: seq-delegate seq ;"
 203     <string-reader> "remove-consult-test" parse-stream
 204 ] unit-test
 205
 206 { f } [
 207     seq-delegate
 208     sequence-protocol "protocol-consult" word-prop
 209     key?
 210 ] unit-test
 211
 212 GENERIC: broadcastable ( x -- )
 213 GENERIC: nonbroadcastable ( x -- y )
 214
 215 TUPLE: broadcaster targets ;
 216
 217 BROADCAST: broadcastable broadcaster targets>> ;
 218
 219 M: integer broadcastable 1 + , ;
 220
 221 [ "USING: accessors delegate ; IN: delegate.tests BROADCAST: nonbroadcastable broadcaster targets>> ;" eval( -- ) ]
 222 [ error>> broadcast-words-must-have-no-outputs? ] must-fail-with
 223
 224 { { 2 3 4 } }
 225 [ { 1 2 3 } broadcaster boa [ broadcastable ] { } make ] unit-test