Improved multi-methods

extra/multi-methods/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/multi-methods/multi-methods-tests.factor

@@ -0,0 +1,83 @@
+IN: temporary
+USING: multi-methods tools.test kernel math arrays sequences
+prettyprint strings classes hashtables assocs namespaces ;
+
+[ { 1 2 3 4 5 6 } ] [
+    { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ -1 ] [
+    { fixnum array } { number sequence } classes<
+] unit-test
+
+[ 0 ] [
+    { number sequence } { number sequence } classes<
+] unit-test
+
+[ 1 ] [
+    { object object } { number sequence } classes<
+] unit-test
+
+[
+    {
+        { { object integer } [ 1 ] }
+        { { object object } [ 2 ] }
+        { { POSTPONE: f POSTPONE: f } [ 3 ] }
+    }
+] [
+    {
+        { { integer } [ 1 ] }
+        { { } [ 2 ] }
+        { { f f } [ 3 ] }
+    } congruify-methods
+] unit-test
+
+GENERIC: first-test
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+TUPLE: paper ;    INSTANCE: paper thing
+TUPLE: scissors ; INSTANCE: scissors thing
+TUPLE: rock ;     INSTANCE: rock thing
+
+GENERIC: beats?
+
+METHOD: beats? { paper scissors } t ;
+METHOD: beats? { scissors rock } t ;
+METHOD: beats? { rock paper } t ;
+METHOD: beats? { thing thing } f ;
+
+: play ( obj1 obj2 -- ? ) beats? 2nip ;
+
+[ { } 3 play ] unit-test-fails
+[ t ] [ T{ paper } T{ scissors } play ] unit-test
+[ f ] [ T{ scissors } T{ paper } play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+GENERIC: legacy-test
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
+
+SYMBOL: some-var
+
+HOOK: hook-test some-var
+
+[ t ] [ \ hook-test hook-generic? ] unit-test
+
+METHOD: hook-test { array array } reverse ;
+METHOD: hook-test { array } class ;
+METHOD: hook-test { hashtable number } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test

extra/multi-methods/multi-methods.factor

@@ -1,7 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences vectors classes combinators
-generic.standard arrays words combinators.lib assocs parser ;
+arrays words assocs parser namespaces definitions
+prettyprint prettyprint.backend quotations ;
 IN: multi-methods
 
+TUPLE: method loc def ;
+
+: <method> { set-method-def } \ method construct ;
+
 : maximal-element ( seq quot -- n elt )
     dupd [
         swapd [ call 0 < ] 2curry subset empty?
@@ -23,31 +30,156 @@ IN: multi-methods
         } cond 2nip
     ] 2map [ zero? not ] find nip 0 or ;
 
+: picker ( n -- quot )
+    {
+        { 0 [ [ dup ] ] }
+        { 1 [ [ over ] ] }
+        { 2 [ [ pick ] ] }
+        [ 1- picker [ >r ] swap [ r> swap ] 3append ]
+    } case ;
+
 : multi-predicate ( classes -- quot )
     dup length <reversed> [
         >r "predicate" word-prop r>
-        (picker) swap append
-    ] 2map [ && ] curry ;
+        picker swap [ not ] 3append [ f ] 2array
+    ] 2map [ t ] swap alist>quot ;
+
+: method-defs ( methods -- methods' )
+    [ method-def ] assoc-map ;
 
 : multi-dispatch-quot ( methods -- quot )
     [ >r multi-predicate r> ] assoc-map
     [ "No method" throw ] swap reverse alist>quot ;
 
-: sorted-methods ( word -- methods )
-    "multi-methods" word-prop >alist
+: methods ( word -- alist )
+    "multi-methods" word-prop >alist ;
+
+: congruify-methods ( alist -- alist' )
+    dup empty? [
+        dup [ first length ] map supremum [
+            swap >r object pad-left [ \ f or ] map r>
+        ] curry assoc-map
+    ] unless ;
+
+: sorted-methods ( alist -- alist' )
     [ [ first ] 2apply classes< ] topological-sort ;
 
+GENERIC: perform-combination ( word combination -- quot )
+
+TUPLE: standard-combination ;
+
+: standard-combination ( methods -- quot )
+    congruify-methods sorted-methods multi-dispatch-quot ;
+
+M: standard-combination perform-combination
+    drop methods method-defs standard-combination ;
+
+TUPLE: hook-combination var ;
+
+M: hook-combination perform-combination
+    hook-combination-var [ get ] curry
+    swap methods method-defs [ [ drop ] swap append ] assoc-map
+    standard-combination append ;
+
 : make-generic ( word -- )
-    dup sorted-methods multi-dispatch-quot define ;
+    dup dup "multi-combination" word-prop perform-combination
+    define ;
+
+: init-methods ( word -- )
+    dup "multi-methods" word-prop
+    H{ } assoc-like
+    "multi-methods" set-word-prop ;
+
+: define-generic ( word combination -- )
+    dupd "multi-combination" set-word-prop
+    dup init-methods
+    make-generic ;
+
+: define-standard-generic ( word -- )
+    T{ standard-combination } define-generic ;
 
 : GENERIC:
-    CREATE
-    dup H{ } clone "multi-methods" set-word-prop
-    make-generic ; parsing
+    CREATE define-standard-generic ; parsing
 
-: add-method ( quot classes word -- )
-    [ "multi-methods" word-prop set-at ] keep make-generic ;
+: define-hook-generic ( word var -- )
+    hook-combination construct-boa define-generic ;
+
+: HOOK:
+    CREATE scan-word define-hook-generic ; parsing
+
+: method ( classes word -- method )
+    "multi-methods" word-prop at ;
+
+: with-methods ( word quot -- )
+    over >r >r "multi-methods" word-prop
+    r> call r> make-generic ; inline
+
+: add-method ( method classes word -- )
+    [ set-at ] with-methods ;
+
+: forget-method ( classes word -- )
+    [ delete-at ] with-methods ;
+
+: parse-method ( -- method classes word method-spec )
+    parse-definition 2 cut
+    over >r
+    >r first2 swap r> <method> -rot
+    r> first2 swap add* >array ;
 
 : METHOD:
-    parse-definition unclip swap unclip swap spin
-    add-method ; parsing
+    location
+    >r parse-method >r add-method r> r>
+    remember-definition ; parsing
+
+! For compatibility
+: M:
+    scan-word 1array scan-word parse-definition <method>
+    -rot add-method ; parsing
+
+! Definition protocol. We qualify core generics here
+USE: qualified
+QUALIFIED: syntax
+
+PREDICATE: word generic
+    "multi-combination" word-prop >boolean ;
+
+PREDICATE: word standard-generic
+    "multi-combination" word-prop standard-combination? ;
+
+PREDICATE: word hook-generic
+    "multi-combination" word-prop hook-combination? ;
+
+syntax:M: standard-generic definer drop \ GENERIC: f ;
+
+syntax:M: standard-generic definition drop f ;
+
+syntax:M: hook-generic definer drop \ HOOK: f ;
+
+syntax:M: hook-generic definition drop f ;
+
+syntax:M: hook-generic synopsis*
+    dup seeing-word \ HOOK: pprint-word dup pprint-word
+    dup "multi-combination" word-prop
+    hook-combination-var pprint-word stack-effect. ;
+
+PREDICATE: array method-spec
+    unclip generic? >r [ class? ] all? r> and ;
+
+syntax:M: method-spec where
+    dup unclip method method-loc [ ] [ second where ] ?if ;
+
+syntax:M: method-spec set-where
+    unclip method set-method-loc ;
+
+syntax:M: method-spec definer
+    drop \ METHOD: \ ; ;
+
+syntax:M: method-spec definition
+    unclip method method-def ;
+
+syntax:M: method-spec synopsis*
+    dup definer drop pprint-word
+    unclip pprint* pprint* ;
+
+syntax:M: method-spec forget
+    unclip [ delete-at ] with-methods ;

extra/multi-methods/summary.txt

@@ -0,0 +1 @@
+Experimental multiple dispatch implementation