order-insensitive pair methods
parent
2ee95694e5
commit
06012cf291
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
|
@ -0,0 +1,43 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors pair-methods classes kernel sequences tools.test ;
|
||||
IN: pair-methods.tests
|
||||
|
||||
TUPLE: thang ;
|
||||
|
||||
TUPLE: foom < thang ;
|
||||
TUPLE: barm < foom ;
|
||||
|
||||
TUPLE: zim < thang ;
|
||||
TUPLE: zang < zim ;
|
||||
|
||||
: class-names ( a b prefix -- string )
|
||||
[ [ class name>> ] bi@ "-" glue ] dip prepend ;
|
||||
|
||||
PAIR-GENERIC: blibble ( a b -- c )
|
||||
|
||||
PAIR-M: thang thang blibble
|
||||
"vanilla " class-names ;
|
||||
|
||||
PAIR-M: foom thang blibble
|
||||
"chocolate " class-names ;
|
||||
|
||||
PAIR-M: barm thang blibble
|
||||
"strawberry " class-names ;
|
||||
|
||||
PAIR-M: barm zim blibble
|
||||
"coconut " class-names ;
|
||||
|
||||
[ "vanilla zang-zim" ] [ zim new zang new blibble ] unit-test
|
||||
|
||||
! args automatically swap to match most specific method
|
||||
[ "chocolate foom-zim" ] [ foom new zim new blibble ] unit-test
|
||||
[ "chocolate foom-zim" ] [ zim new foom new blibble ] unit-test
|
||||
|
||||
[ "strawberry barm-barm" ] [ barm new barm new blibble ] unit-test
|
||||
[ "strawberry barm-foom" ] [ barm new foom new blibble ] unit-test
|
||||
[ "strawberry barm-foom" ] [ foom new barm new blibble ] unit-test
|
||||
|
||||
[ "coconut barm-zang" ] [ zang new barm new blibble ] unit-test
|
||||
[ "coconut barm-zim" ] [ barm new zim new blibble ] unit-test
|
||||
|
||||
[ 1 2 blibble ] [ no-pair-method? ] must-fail-with
|
|
@ -0,0 +1,57 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: arrays assocs classes classes.tuple.private combinators
|
||||
effects.parser generic.parser kernel math math.order parser
|
||||
quotations sequences sorting words ;
|
||||
IN: pair-methods
|
||||
|
||||
ERROR: no-pair-method a b generic ;
|
||||
|
||||
: ?swap ( a b ? -- a/b b/a )
|
||||
[ swap ] when ;
|
||||
|
||||
: method-sort-key ( pair -- key )
|
||||
first2 [ tuple-layout third ] bi@ + ;
|
||||
|
||||
: pair-match-condition ( pair -- quot )
|
||||
first2 [ [ instance? ] swap prefix ] bi@ [ ] 2sequence
|
||||
[ 2dup ] [ bi* and ] surround ;
|
||||
|
||||
: pair-method-cond ( pair quot -- array )
|
||||
[ pair-match-condition ] [ ] bi* 2array ;
|
||||
|
||||
: sorted-pair-methods ( word -- alist )
|
||||
"pair-generic-methods" word-prop >alist
|
||||
[ [ first method-sort-key ] bi@ >=< ] sort ;
|
||||
|
||||
: pair-generic-definition ( word -- def )
|
||||
[ sorted-pair-methods [ first2 pair-method-cond ] map ]
|
||||
[ [ no-pair-method ] curry suffix ] bi 1quotation
|
||||
[ 2dup [ class ] bi@ <=> +gt+ eq? ?swap ] [ cond ] surround ;
|
||||
|
||||
: make-pair-generic ( word -- )
|
||||
dup pair-generic-definition define ;
|
||||
|
||||
: define-pair-generic ( word effect -- )
|
||||
[ swap set-stack-effect ]
|
||||
[ drop H{ } clone "pair-generic-methods" set-word-prop ]
|
||||
[ drop make-pair-generic ] 2tri ;
|
||||
|
||||
: (PAIR-GENERIC:) ( -- )
|
||||
CREATE-GENERIC complete-effect define-pair-generic ;
|
||||
|
||||
SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ;
|
||||
|
||||
: define-pair-method ( a b pair-generic definition -- )
|
||||
[ 2array ] 2dip swap
|
||||
[ "pair-generic-methods" word-prop [ swap ] dip set-at ]
|
||||
[ make-pair-generic ] bi ;
|
||||
|
||||
: ?prefix-swap ( quot ? -- quot' )
|
||||
[ \ swap prefix ] when ;
|
||||
|
||||
: (PAIR-M:) ( -- )
|
||||
scan-word scan-word 2dup <=> +gt+ eq? [
|
||||
?swap scan-word parse-definition
|
||||
] keep ?prefix-swap define-pair-method ;
|
||||
|
||||
SYNTAX: PAIR-M: (PAIR-M:) ;
|
|
@ -0,0 +1 @@
|
|||
Order-insensitive double dispatch generics
|
Loading…
Reference in New Issue