Delegate changes for crossreferencing; removing mimic (not enough unit tests)

db4
Daniel Ehrenberg 2008-04-17 22:39:25 -05:00
parent 368599baf8
commit 4823509dfd
3 changed files with 67 additions and 88 deletions

View File

@ -24,30 +24,17 @@ HELP: CONSULT:
{ define-consult POSTPONE: CONSULT: } related-words
HELP: define-mimic
{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the word is called." }
{ $notes "Usually, " { $link POSTPONE: MIMIC: } " should be used instead. This is only for runtime use." } ;
HELP: MIMIC:
{ $syntax "MIMIC: group mimicker mimicked" }
{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the syntax is used. Mimicking overwrites existing methods." } ;
HELP: group-words
{ $values { "group" "a group" } { "words" "an array of words" } }
{ $description "Given a protocol, generic word or tuple class, this returns the corresponding generic words that this group contains." } ;
{ $description "Given a protocol or tuple class, this returns the corresponding generic words that this group contains." } ;
ARTICLE: { "delegate" "intro" } "Delegation module"
"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". To define a group as a set of words, use"
"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". One type of group is a tuple, which consists of the slot words. To define a group as a set of words, use"
{ $subsection POSTPONE: PROTOCOL: }
{ $subsection define-protocol }
"One method of object extension which this vocabulary defines is consultation. This is slightly different from the current Factor concept of delegation, in that instead of delegating for all generic words not implemented, only generic words included in a specific group are consulted. Additionally, instead of using a single hard-coded delegate slot, you can specify any quotation to execute in order to retrieve who to consult. The literal syntax and defining word are"
{ $subsection POSTPONE: CONSULT: }
{ $subsection define-consult }
"Another object extension mechanism is mimicry. This is the copying of methods in a group from one class to another. For certain applications, this is more appropriate than delegation, as it avoids the slicing problem. It is inappropriate for tuple slots, however. The literal syntax and defining word are"
{ $subsection POSTPONE: MIMIC: }
{ $subsection define-mimic } ;
{ $subsection define-consult } ;
IN: delegate
ABOUT: { "delegate" "intro" }

View File

@ -2,11 +2,6 @@ USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string ;
IN: delegate.tests
DEFER: example
[ 1 ] [ \ example 1 "prop" set-word-prop \ example "prop" word-prop ] unit-test
[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
[ 2 ] [ \ example "prop" word-prop ] unit-test
TUPLE: hello this that ;
C: <hello> hello
@ -30,18 +25,17 @@ GENERIC: bing ( c -- d )
PROTOCOL: bee bing ;
CONSULT: hello goodbye goodbye-those ;
M: hello bing hello-test ;
MIMIC: bee goodbye hello
[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
[ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
[ V{ goodbye } ] [ baz protocol-users ] unit-test
[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ]
[ [ baz see ] with-string-writer ] unit-test

View File

@ -1,9 +1,44 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs sequences arrays
vectors definitions prettyprint combinators.lib math ;
vectors definitions prettyprint combinators.lib math hashtables ;
IN: delegate
: protocol-words ( protocol -- words )
\ protocol-words word-prop ;
: protocol-consult ( protocol -- consulters )
\ protocol-consult word-prop ;
GENERIC: group-words ( group -- words )
M: tuple-class group-words
"slot-names" word-prop [
[ reader-word ] [ writer-word ] bi
2array [ 0 2array ] map
] map concat ;
! Consultation
: consult-method ( word class quot -- )
[ drop swap first create-method ]
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
: change-word-prop ( word prop quot -- )
rot word-props swap change-at ; inline
: register-protocol ( group class quot -- )
rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
: define-consult ( group class quot -- )
[ register-protocol ] [
rot group-words -rot
[ consult-method ] 2curry each
] 3bi ;
: CONSULT:
scan-word scan-word parse-definition define-consult ; parsing
! Protocols
: cross-2each ( seq1 seq2 quot -- )
@ -12,36 +47,46 @@ IN: delegate
: forget-all-methods ( classes words -- )
[ 2array forget ] cross-2each ;
: protocol-words ( protocol -- words )
"protocol-words" word-prop ;
: protocol-users ( protocol -- users )
"protocol-users" word-prop ;
protocol-consult keys ;
: users-and-words ( protocol -- users words )
[ protocol-users ] [ protocol-words ] bi ;
: lost-words ( protocol wordlist -- lost-words )
>r protocol-words r> seq-diff ;
: forget-old-definitions ( protocol new-wordlist -- )
>r users-and-words r>
seq-diff forget-all-methods ;
values [ drop protocol-users ] [ lost-words ] 2bi
forget-all-methods ;
: define-protocol ( protocol wordlist -- )
! 2dup forget-old-definitions
{ } like "protocol-words" set-word-prop ;
: added-words ( protocol wordlist -- added-words )
swap protocol-words seq-diff ;
: add-new-definitions ( protocol wordlist -- )
dupd added-words >r protocol-consult >alist r>
[ first2 consult-method ] cross-2each ;
: initialize-protocol-props ( protocol wordlist -- )
[ drop H{ } clone \ protocol-consult set-word-prop ]
[ { } like \ protocol-words set-word-prop ] 2bi ;
: fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ;
: define-protocol ( protocol wordlist -- )
fill-in-depth
[ forget-old-definitions ]
[ add-new-definitions ]
[ initialize-protocol-props ] 2tri ;
: PROTOCOL:
CREATE-WORD
dup define-symbol
dup f "inline" set-word-prop
parse-definition fill-in-depth define-protocol ; parsing
[ define-symbol ]
[ f "inline" set-word-prop ]
[ parse-definition define-protocol ] tri ; parsing
PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
M: protocol forget*
[ users-and-words forget-all-methods ] [ call-next-method ] bi ;
[ f forget-old-definitions ] [ call-next-method ] bi ;
: show-words ( wordlist' -- wordlist )
[ dup second zero? [ first ] when ] map ;
@ -52,51 +97,4 @@ M: protocol definer drop \ PROTOCOL: \ ; ;
M: protocol synopsis* word-synopsis ; ! Necessary?
GENERIC: group-words ( group -- words )
M: protocol group-words
"protocol-words" word-prop ;
M: tuple-class group-words
"slot-names" word-prop [
[ reader-word ] [ writer-word ] bi
2array [ 0 2array ] map
] map concat ;
! Consultation
: define-consult-method ( word class quot -- )
[ drop swap first create-method ]
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
: change-word-prop ( word prop quot -- )
>r swap word-props r> change-at ; inline
: add ( item vector/f -- vector )
2dup member? [ nip ] [ ?push ] if ;
: use-protocol ( class group -- )
"protocol-users" [ add ] change-word-prop ;
: define-consult ( group class quot -- )
swapd >r 2dup use-protocol group-words swap r>
[ define-consult-method ] 2curry each ;
: CONSULT:
scan-word scan-word parse-definition define-consult ; parsing
! Mimic still needs to be updated
: mimic-method ( mimicker mimicked generic -- )
tuck method
[ [ create-method-in ] [ word-def ] bi* define ]
[ 2drop ] if* ;
: define-mimic ( group mimicker mimicked -- )
[ drop swap use-protocol ] [
rot group-words -rot
[ rot first mimic-method ] 2curry each
] 3bi ;
: MIMIC:
scan-word scan-word scan-word define-mimic ; parsing
M: protocol group-words protocol-words ;