Improving multi-methods
parent
07e5441b14
commit
cf4c13f55b
extra/multi-methods
|
@ -1,6 +1,7 @@
|
|||
IN: temporary
|
||||
USING: multi-methods tools.test kernel math arrays sequences
|
||||
prettyprint strings classes hashtables assocs namespaces ;
|
||||
prettyprint strings classes hashtables assocs namespaces
|
||||
debugger continuations ;
|
||||
|
||||
[ { 1 2 3 4 5 6 } ] [
|
||||
{ 6 4 5 1 3 2 } [ <=> ] topological-sort
|
||||
|
@ -52,6 +53,8 @@ METHOD: beats? { thing thing } f ;
|
|||
: play ( obj1 obj2 -- ? ) beats? 2nip ;
|
||||
|
||||
[ { } 3 play ] unit-test-fails
|
||||
[ t ] [ error get no-method? ] unit-test
|
||||
[ ] [ error get error. ] unit-test
|
||||
[ t ] [ T{ paper } T{ scissors } play ] unit-test
|
||||
[ f ] [ T{ scissors } T{ paper } play ] unit-test
|
||||
|
||||
|
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences vectors classes combinators
|
||||
arrays words assocs parser namespaces definitions
|
||||
prettyprint prettyprint.backend quotations ;
|
||||
prettyprint prettyprint.backend quotations arrays.lib
|
||||
debugger io ;
|
||||
IN: multi-methods
|
||||
|
||||
TUPLE: method loc def ;
|
||||
|
@ -38,47 +39,80 @@ TUPLE: method loc def ;
|
|||
[ 1- picker [ >r ] swap [ r> swap ] 3append ]
|
||||
} case ;
|
||||
|
||||
: (multi-predicate) ( class picker -- quot )
|
||||
swap "predicate" word-prop append ;
|
||||
|
||||
: multi-predicate ( classes -- quot )
|
||||
dup length <reversed> [
|
||||
>r "predicate" word-prop r>
|
||||
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 ;
|
||||
dup length <reversed>
|
||||
[ picker 2array ] 2map
|
||||
[ drop object eq? not ] assoc-subset
|
||||
dup empty? [ drop [ t ] ] [
|
||||
[ (multi-predicate) ] { } assoc>map
|
||||
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
|
||||
] if ;
|
||||
|
||||
: methods ( word -- alist )
|
||||
"multi-methods" word-prop >alist ;
|
||||
|
||||
: method-defs ( methods -- methods' )
|
||||
[ method-def ] assoc-map ;
|
||||
|
||||
TUPLE: no-method arguments generic ;
|
||||
|
||||
: no-method ( argument-count generic -- * )
|
||||
>r narray r> \ no-method construct-boa throw ; inline
|
||||
|
||||
: argument-count ( methods -- n )
|
||||
dup assoc-empty? [ drop 0 ] [
|
||||
keys [ length ] map supremum
|
||||
] if ;
|
||||
|
||||
: multi-dispatch-quot ( methods generic -- quot )
|
||||
>r
|
||||
[ [ >r multi-predicate r> ] assoc-map ] keep argument-count
|
||||
r> [ no-method ] 2curry
|
||||
swap reverse alist>quot ;
|
||||
|
||||
: congruify-methods ( alist -- alist' )
|
||||
dup empty? [
|
||||
dup [ first length ] map supremum [
|
||||
swap >r object pad-left [ \ f or ] map r>
|
||||
] curry assoc-map
|
||||
] unless ;
|
||||
dup argument-count [
|
||||
swap >r object pad-left [ \ f or ] map r>
|
||||
] curry assoc-map ;
|
||||
|
||||
: sorted-methods ( alist -- alist' )
|
||||
[ [ first ] 2apply classes< ] topological-sort ;
|
||||
|
||||
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
|
||||
|
||||
M: no-method error.
|
||||
"Type check error" print
|
||||
nl
|
||||
"Generic word " write dup no-method-generic pprint
|
||||
" does not have a method applicable to inputs:" print
|
||||
dup no-method-arguments short.
|
||||
nl
|
||||
"Inputs have signature:" print
|
||||
dup no-method-arguments [ class ] map niceify-method .
|
||||
nl
|
||||
"Defined methods in topological order: " print
|
||||
no-method-generic
|
||||
methods congruify-methods sorted-methods keys
|
||||
[ niceify-method ] map stack. ;
|
||||
|
||||
GENERIC: perform-combination ( word combination -- quot )
|
||||
|
||||
TUPLE: standard-combination ;
|
||||
|
||||
: standard-combination ( methods -- quot )
|
||||
congruify-methods sorted-methods multi-dispatch-quot ;
|
||||
: standard-combination ( methods generic -- quot )
|
||||
>r congruify-methods sorted-methods r> multi-dispatch-quot ;
|
||||
|
||||
M: standard-combination perform-combination
|
||||
drop methods method-defs standard-combination ;
|
||||
drop [ methods method-defs ] keep 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
|
||||
hook-combination-var [ get ] curry swap methods
|
||||
[ method-defs [ [ drop ] swap append ] assoc-map ] keep
|
||||
standard-combination append ;
|
||||
|
||||
: make-generic ( word -- )
|
||||
|
@ -158,7 +192,9 @@ 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 definer.
|
||||
dup seeing-word
|
||||
dup pprint-word
|
||||
dup "multi-combination" word-prop
|
||||
hook-combination-var pprint-word stack-effect. ;
|
||||
|
||||
|
@ -178,7 +214,7 @@ syntax:M: method-spec definition
|
|||
unclip method method-def ;
|
||||
|
||||
syntax:M: method-spec synopsis*
|
||||
dup definer drop pprint-word
|
||||
dup definer.
|
||||
unclip pprint* pprint* ;
|
||||
|
||||
syntax:M: method-spec forget
|
||||
|
|
Loading…
Reference in New Issue