Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / basis / delegate / delegate-tests.factor

diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor
index 4b024077354d29a24eae100d68ee9050e8eb6502..d9581152e1014c3f2998b396667af2f5141daca4 100644 (file)
--- a/basis/delegate/delegate-tests.factor
+++ b/basis/delegate/delegate-tests.factor
@@ -1,6 +1,7 @@
 USING: delegate kernel arrays tools.test words math definitions
 compiler.units parser generic prettyprint io.streams.string
-accessors eval multiline ;
+accessors eval multiline generic.single delegate.protocols
+delegate.private assocs see ;
 IN: delegate.tests
 
 TUPLE: hello this that ;
@@ -34,19 +35,19 @@ M: hello bing hello-test ;
 [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
 [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
 
-[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test
-[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test
+[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval( -- ) ] times ] unit-test
+[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
 [ H{ } ] [ bee protocol-consult ] unit-test
 
 [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
 
-GENERIC: one
+GENERIC: one ( a -- b )
 M: integer one ;
-GENERIC: two
+GENERIC: two ( a -- b )
 M: integer two ;
-GENERIC: three
+GENERIC: three ( a -- b )
 M: integer three ;
-GENERIC: four
+GENERIC: four ( a -- b )
 M: integer four ;
 
 PROTOCOL: alpha one two ;
@@ -54,30 +55,30 @@ PROTOCOL: beta three ;
 
 TUPLE: hey value ;
 C: <hey> hey
-CONSULT: alpha hey value>> 1+ ;
-CONSULT: beta hey value>> 1- ;
+CONSULT: alpha hey value>> 1 + ;
+CONSULT: beta hey value>> 1 - ;
 
 [ 2 ] [ 1 <hey> one ] unit-test
 [ 2 ] [ 1 <hey> two ] unit-test
 [ 0 ] [ 1 <hey> three ] unit-test
 [ { hey } ] [ alpha protocol-users ] unit-test
 [ { hey } ] [ beta protocol-users ] unit-test
-[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test
+[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test
 [ f ] [ hey \ two method ] unit-test
 [ f ] [ hey \ four method ] unit-test
-[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test
+[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test
 [ { hey } ] [ alpha protocol-users ] unit-test
 [ { hey } ] [ beta protocol-users ] unit-test
 [ 2 ] [ 1 <hey> one ] unit-test
 [ 0 ] [ 1 <hey> two ] unit-test
 [ 0 ] [ 1 <hey> three ] unit-test
 [ 0 ] [ 1 <hey> four ] unit-test
-[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test
+[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval( -- ) ] unit-test
 [ 2 ] [ 1 <hey> one ] unit-test
 [ -1 ] [ 1 <hey> two ] unit-test
 [ -1 ] [ 1 <hey> three ] unit-test
 [ -1 ] [ 1 <hey> four ] unit-test
-[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
+[ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test
 [ f ] [ hey \ one method ] unit-test
 
 TUPLE: slot-protocol-test-1 a b ;
@@ -112,6 +113,7 @@ PROTOCOL: silly-protocol do-me ;
 
 [ ] [ T{ a-tuple } do-me ] unit-test
 
+! Change method definition to consultation
 [ [ ] ] [
     <" IN: delegate.tests
     USE: kernel
@@ -119,13 +121,22 @@ PROTOCOL: silly-protocol do-me ;
     CONSULT: silly-protocol a-tuple drop f ; "> <string-reader> "delegate-test" parse-stream
 ] unit-test
 
+! Method should be there
 [ ] [ T{ a-tuple } do-me ] unit-test
 
+! Now try removing the consulation
+[ [ ] ] [
+    <" IN: delegate.tests "> <string-reader> "delegate-test" parse-stream
+] unit-test
+
+! Method should be gone
+[ T{ a-tuple } do-me ] [ no-method? ] must-fail-with
+
 ! A slot protocol issue
 DEFER: slot-protocol-test-3
 SLOT: y
 
-[ f ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+[ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
 
 [ [ ] ] [
     <" IN: delegate.tests
@@ -135,7 +146,7 @@ CONSULT: y>> slot-protocol-test-3 x>> ;">
     <string-reader> "delegate-test-1" parse-stream
 ] unit-test
 
-[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
 
 [ [ ] ] [
     <" IN: delegate.tests
@@ -143,4 +154,46 @@ TUPLE: slot-protocol-test-3 x y ;">
     <string-reader> "delegate-test-1" parse-stream
 ] unit-test
 
-[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
\ No newline at end of file
+! We now have a real accessor for the y slot; we don't want it to
+! get lost
+[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
+
+! We want to be able to override methods after consultation
+[ [ ] ] [
+    <" IN: delegate.tests
+    USING: delegate kernel sequences delegate.protocols accessors ;
+    TUPLE: override-method-test seq ;
+    CONSULT: sequence-protocol override-method-test seq>> ;
+    M: override-method-test like drop ; ">
+    <string-reader> "delegate-test-2" parse-stream
+] unit-test
+
+DEFER: seq-delegate
+    
+! See if removing a consultation updates protocol-consult word prop
+[ [ ] ] [
+    <" IN: delegate.tests
+    USING: accessors delegate delegate.protocols ;
+    TUPLE: seq-delegate seq ;
+    CONSULT: sequence-protocol seq-delegate seq>> ;">
+    <string-reader> "remove-consult-test" parse-stream
+] unit-test
+
+[ t ] [
+    seq-delegate
+    sequence-protocol \ protocol-consult word-prop
+    key?
+] unit-test
+
+[ [ ] ] [
+    <" IN: delegate.tests
+    USING: delegate delegate.protocols ;
+    TUPLE: seq-delegate seq ;">
+    <string-reader> "remove-consult-test" parse-stream
+] unit-test
+
+[ f ] [
+    seq-delegate
+    sequence-protocol \ protocol-consult word-prop
+    key?
+] unit-test