order-insensitive pair methods

extra/pair-methods/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/pair-methods/pair-methods-tests.factor

@@ -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

extra/pair-methods/pair-methods.factor

@@ -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:) ;

extra/pair-methods/summary.txt

@@ -0,0 +1 @@
+Order-insensitive double dispatch generics