USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
-accessors eval multiline ;
+accessors eval multiline generic.standard delegate.protocols
+delegate.private assocs ;
IN: delegate.tests
TUPLE: hello this that ;
[ 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
+[ 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
[ ] [ T{ a-tuple } do-me ] unit-test
+! Change method definition to consultation
[ [ ] ] [
<" IN: delegate.tests
USE: kernel
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
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
\ No newline at end of file
! Portions copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.tuple definitions generic
-generic.standard hashtables kernel lexer make math parser
-generic.parser sequences sets slots words words.symbol fry ;
+generic.standard hashtables kernel lexer math parser
+generic.parser sequences sets slots words words.symbol fry
+locals combinators.short-circuit compiler.units ;
IN: delegate
+<PRIVATE
+
: protocol-words ( protocol -- words )
\ protocol-words word-prop ;
! Consultation
-: consult-method ( word class quot -- )
- [ drop swap first create-method-in ]
- [ nip [ swap [ second [ [ dip ] curry ] times % ] [ first , ] bi ] [ ] make ] 3bi
+TUPLE: consultation group class quot loc ;
+
+: <consultation> ( group class quot -- consultation )
+ f consultation boa ;
+
+: create-consult-method ( word consultation -- method )
+ [ class>> swap first create-method dup fake-definition ] keep
+ [ drop ] [ "consultation" set-word-prop ] 2bi ;
+
+PREDICATE: consult-method < method-body "consultation" word-prop ;
+
+M: consult-method reset-word
+ [ call-next-method ] [ f "consultation" set-word-prop ] bi ;
+
+: consult-method-quot ( quot word -- object )
+ [ second [ [ dip ] curry ] times ] [ first ] bi
+ '[ _ call _ execute ] ;
+
+: consult-method ( word consultation -- )
+ [ create-consult-method ]
+ [ quot>> swap consult-method-quot ] 2bi
define ;
: change-word-prop ( word prop quot -- )
[ swap props>> ] dip change-at ; inline
-: register-protocol ( group class quot -- )
- [ \ protocol-consult ] 2dip
- '[ [ _ _ swap ] dip ?set-at ] change-word-prop ;
+: each-generic ( consultation quot -- )
+ [ [ group>> group-words ] keep ] dip curry each ; inline
+
+: register-consult ( consultation -- )
+ [ group>> \ protocol-consult ] [ ] [ class>> ] tri
+ '[ [ _ _ ] dip ?set-at ] change-word-prop ;
+
+: consult-methods ( consultation -- )
+ [ consult-method ] each-generic ;
+
+: unregister-consult ( consultation -- )
+ [ class>> ] [ group>> ] bi
+ \ protocol-consult word-prop delete-at ;
+
+:: unconsult-method ( word consultation -- )
+ consultation class>> word first method
+ dup { [ ] [ "consultation" word-prop consultation eq? ] } 1&&
+ [ forget ] [ drop ] if ;
-: define-consult ( group class quot -- )
- [ register-protocol ]
- [ [ group-words ] 2dip '[ _ _ consult-method ] each ]
- 3bi ;
+: unconsult-methods ( consultation -- )
+ [ unconsult-method ] each-generic ;
+
+PRIVATE>
+
+: define-consult ( consultation -- )
+ [ register-consult ] [ consult-methods ] bi ;
: CONSULT:
- scan-word scan-word parse-definition define-consult ; parsing
+ scan-word scan-word parse-definition <consultation>
+ [ save-location ] [ define-consult ] bi ; parsing
+
+M: consultation where loc>> ;
+
+M: consultation set-where (>>loc) ;
+
+M: consultation forget*
+ [ unconsult-methods ] [ unregister-consult ] bi ;
! Protocols
+<PRIVATE
: cross-2each ( seq1 seq2 quot -- )
[ with each ] 2curry each ; inline
swap protocol-words diff ;
: add-new-definitions ( protocol wordlist -- )
- [ drop protocol-consult >alist ] [ added-words ] 2bi
- [ swap first2 consult-method ] cross-2each ;
+ [ drop protocol-consult values ] [ added-words ] 2bi
+ [ swap consult-method ] cross-2each ;
: initialize-protocol-props ( protocol wordlist -- )
[
: fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ;
+: show-words ( wordlist' -- wordlist )
+ [ dup second zero? [ first ] when ] map ;
+
+PRIVATE>
+
: define-protocol ( protocol wordlist -- )
[ drop define-symbol ] [
fill-in-depth
M: protocol forget*
[ f forget-old-definitions ] [ call-next-method ] bi ;
-: show-words ( wordlist' -- wordlist )
- [ dup second zero? [ first ] when ] map ;
M: protocol definition protocol-words show-words ;
[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ]
[ error>> no-word-error? ] must-fail-with
+! Two similar bugs
+
+! Replace : def with something in << >>
[ [ ] ] [
"IN: parser.tests : was-once-a-word-bug ( -- ) ;"
<string-reader> "was-once-a-word-test" parse-stream
] unit-test
[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test
+
+! Replace : def with DEFER:
+[ [ ] ] [
+ "IN: parser.tests : is-not-deferred ( -- ) ;"
+ <string-reader> "is-not-deferred" parse-stream
+] unit-test
+
+[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test
+[ f ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests DEFER: is-not-deferred"
+ <string-reader> "is-not-deferred" parse-stream
+] unit-test
+
+[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test
+[ t ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test