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 ;
7 TUPLE: hello this that ;
10 TUPLE: goodbye these those ;
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 } ;
18 : hello-test ( hello/goodbye -- array )
19 [ hello? ] [ this>> ] [ that>> ] tri 3array ;
21 CONSULT: baz goodbye these>> ;
23 M: hello bar hello-test ;
24 M: hello whoa [ this>> ] dip + ;
26 GENERIC: bing ( c -- d )
28 CONSULT: hello goodbye those>> ;
29 M: hello bing hello-test ;
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
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
42 { "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" } [ [ baz see ] with-string-writer ] unit-test
44 GENERIC: one ( a -- b )
46 GENERIC: two ( a -- b )
48 GENERIC: three ( a -- b )
50 GENERIC: four ( a -- b )
53 PROTOCOL: alpha one two ;
54 PROTOCOL: beta three ;
58 CONSULT: alpha hey value>> 1 + ;
59 CONSULT: beta hey value>> 1 - ;
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
84 TUPLE: slot-protocol-test-1 a b ;
85 TUPLE: slot-protocol-test-2 < slot-protocol-test-1 { c integer } ;
87 TUPLE: slot-protocol-test-3 d ;
89 CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ;
92 T{ slot-protocol-test-3 f T{ slot-protocol-test-2 f "a" "b" 5 } }
93 [ a>> ] [ b>> ] [ c>> ] tri
96 TUPLE: slot-protocol-test-4 { x read-only } ;
98 TUPLE: slot-protocol-test-5 { a-read-only-slot read-only } ;
100 CONSULT: slot-protocol-test-5 slot-protocol-test-4 x>> ;
103 "hey" slot-protocol-test-5 boa slot-protocol-test-4 boa
107 GENERIC: do-me ( x -- )
111 { } [ f do-me ] unit-test
115 PROTOCOL: silly-protocol do-me ;
117 ! Replacing a method definition with a consultation would cause problems
122 M: a-tuple do-me drop ;" <string-reader> "delegate-test" parse-stream
125 { } [ T{ a-tuple } do-me ] unit-test
127 ! Change method definition to consultation
132 CONSULT: silly-protocol a-tuple drop f ; " <string-reader> "delegate-test" parse-stream
135 ! Method should be there
136 { } [ T{ a-tuple } do-me ] unit-test
138 ! Now try removing the consultation
140 "IN: delegate.tests" <string-reader> "delegate-test" parse-stream
143 ! Method should be gone
144 [ T{ a-tuple } do-me ] [ no-method? ] must-fail-with
146 ! A slot protocol issue
147 DEFER: slot-protocol-test-3
150 { f } [ \ slot-protocol-test-3 \ y>> ?lookup-method >boolean ] unit-test
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
160 { t } [ \ slot-protocol-test-3 \ y>> ?lookup-method >boolean ] unit-test
164 TUPLE: slot-protocol-test-3 x y ;"
165 <string-reader> "delegate-test-1" parse-stream
168 ! We now have a real accessor for the y slot; we don't want it to
170 { t } [ \ slot-protocol-test-3 \ y>> ?lookup-method >boolean ] unit-test
172 ! We want to be able to override methods after consultation
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
184 ! See if removing a consultation updates protocol-consult word prop
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
195 sequence-protocol "protocol-consult" word-prop
201 USING: delegate delegate.protocols ;
202 TUPLE: seq-delegate seq ;"
203 <string-reader> "remove-consult-test" parse-stream
208 sequence-protocol "protocol-consult" word-prop
212 GENERIC: broadcastable ( x -- )
213 GENERIC: nonbroadcastable ( x -- y )
215 TUPLE: broadcaster targets ;
217 BROADCAST: broadcastable broadcaster targets>> ;
219 M: integer broadcastable 1 + , ;
221 [ "USING: accessors delegate ; IN: delegate.tests BROADCAST: nonbroadcastable broadcaster targets>> ;" eval( -- ) ]
222 [ error>> broadcast-words-must-have-no-outputs? ] must-fail-with
225 [ { 1 2 3 } broadcaster boa [ broadcastable ] { } make ] unit-test