Improve multi-methods: multi-var hooks

db4
Slava Pestov 2008-04-08 18:51:56 -05:00
parent 3dbda44d23
commit 2cebf7e9e5
7 changed files with 357 additions and 239 deletions

View File

@ -1,98 +0,0 @@
IN: multi-methods.tests
USING: multi-methods tools.test kernel math arrays sequences
prettyprint strings classes hashtables assocs namespaces
debugger continuations ;
[ { 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 ] must-fail
[ 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
[ 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
MIXIN: busted
TUPLE: busted-1 ;
TUPLE: busted-2 ; INSTANCE: busted-2 busted
TUPLE: busted-3 ;
GENERIC: busted-sort
METHOD: busted-sort { busted-1 busted-2 } ;
METHOD: busted-sort { busted-2 busted-3 } ;
METHOD: busted-sort { busted busted } ;

View File

@ -3,13 +3,74 @@
USING: kernel math sequences vectors classes classes.algebra USING: kernel math sequences vectors classes classes.algebra
combinators arrays words assocs parser namespaces definitions combinators arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib prettyprint prettyprint.backend quotations arrays.lib
debugger io compiler.units kernel.private effects ; debugger io compiler.units kernel.private effects accessors
hashtables sorting shuffle ;
IN: multi-methods IN: multi-methods
GENERIC: generic-prologue ( combination -- quot ) ! PART I: Converting hook specializers
: canonicalize-specializer-0 ( specializer -- specializer' )
[ \ f or ] map ;
GENERIC: method-prologue ( combination -- quot ) SYMBOL: args
SYMBOL: hooks
SYMBOL: total
: canonicalize-specializer-1 ( specializer -- specializer' )
[
[ class? ] subset
[ length <reversed> [ 1+ neg ] map ] keep zip
[ length args [ max ] change ] keep
]
[
[ pair? ] subset
[ keys [ hooks get push-new ] each ] keep
] bi append ;
: canonicalize-specializer-2 ( specializer -- specializer' )
[
>r
{
{ [ dup integer? ] [ ] }
{ [ dup word? ] [ hooks get index ] }
} cond args get + r>
] assoc-map ;
: canonicalize-specializer-3 ( specializer -- specializer' )
>r total get object <array> dup <enum> r> update ;
: canonicalize-specializers ( methods -- methods' hooks )
[
[ >r canonicalize-specializer-0 r> ] assoc-map
0 args set
V{ } clone hooks set
[ >r canonicalize-specializer-1 r> ] assoc-map
hooks [ natural-sort ] change
[ >r canonicalize-specializer-2 r> ] assoc-map
args get hooks get length + total set
[ >r canonicalize-specializer-3 r> ] assoc-map
hooks get
] with-scope ;
: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
: prepare-method ( method n -- quot )
[ 1quotation ] [ drop-n-quot ] bi* prepend ;
: prepare-methods ( methods -- methods' prologue )
canonicalize-specializers
[ length [ prepare-method ] curry assoc-map ] keep
[ [ get ] curry ] map concat [ ] like ;
! Part II: Topologically sorting specializers
: maximal-element ( seq quot -- n elt ) : maximal-element ( seq quot -- n elt )
dupd [ dupd [
swapd [ call 0 < ] 2curry subset empty? swapd [ call 0 < ] 2curry subset empty?
@ -32,6 +93,10 @@ GENERIC: method-prologue ( combination -- quot )
} cond 2nip } cond 2nip
] 2map [ zero? not ] find nip 0 or ; ] 2map [ zero? not ] find nip 0 or ;
: sort-methods ( alist -- alist' )
[ [ first ] bi@ classes< ] topological-sort ;
! PART III: Creating dispatch quotation
: picker ( n -- quot ) : picker ( n -- quot )
{ {
{ 0 [ [ dup ] ] } { 0 [ [ dup ] ] }
@ -52,209 +117,171 @@ GENERIC: method-prologue ( combination -- quot )
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ; ] if ;
: multi-dispatch-quot ( methods generic -- quot )
"default-multi-method" word-prop 1quotation swap
[ >r multi-predicate r> ] assoc-map reverse alist>quot ;
! Generic words
PREDICATE: generic < word
"multi-methods" word-prop >boolean ;
: methods ( word -- alist ) : methods ( word -- alist )
"multi-methods" word-prop >alist ; "multi-methods" word-prop >alist ;
: make-method-def ( quot classes generic -- quot ) : make-generic ( generic -- quot )
[ [
swap [ declare ] curry % [ methods prepare-methods % sort-methods ] keep
"multi-combination" word-prop method-prologue % multi-dispatch-quot %
%
] [ ] make ; ] [ ] make ;
TUPLE: method word def classes generic loc ; : update-generic ( word -- )
dup make-generic define ;
! Methods
PREDICATE: method-body < word PREDICATE: method-body < word
"multi-method" word-prop >boolean ; "multi-method-generic" word-prop >boolean ;
M: method-body stack-effect M: method-body stack-effect
"multi-method" word-prop method-generic stack-effect ; "multi-method-generic" word-prop stack-effect ;
M: method-body crossref? M: method-body crossref?
drop t ; drop t ;
: method-word-name ( classes generic -- string ) : method-word-name ( specializer generic -- string )
[ word-name % "-" % unparse % ] "" make ;
: method-word-props ( specializer generic -- assoc )
[ [
word-name % "multi-method-generic" set
"-(" % [ "," % ] [ word-name % ] interleave ")" % "multi-method-specializer" set
] "" make ; ] H{ } make-assoc ;
: <method-word> ( quot classes generic -- word ) : <method> ( specializer generic -- word )
#! We xref here because the "multi-method" word-prop isn't [ method-word-props ] 2keep
#! set yet so crossref? yields f.
[ make-method-def ] 2keep
method-word-name f <word> method-word-name f <word>
dup rot define [ set-word-props ] keep ;
dup xref ;
: <method> ( quot classes generic -- method ) : with-methods ( word quot -- )
[ <method-word> ] 3keep f \ method construct-boa over >r >r "multi-methods" word-prop
dup method-word over "multi-method" set-word-prop ; r> call r> update-generic ; inline
: reveal-method ( method classes generic -- )
[ set-at ] with-methods ;
: method ( classes word -- method )
"multi-methods" word-prop at ;
: create-method ( classes generic -- method )
2dup method dup [
2nip
] [
drop [ <method> dup ] 2keep reveal-method
] if ;
TUPLE: no-method arguments generic ; TUPLE: no-method arguments generic ;
: no-method ( argument-count generic -- * ) : no-method ( argument-count generic -- * )
>r narray r> \ no-method construct-boa throw ; inline >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> method-word 1quotation
] assoc-map
] keep argument-count
r> [ no-method ] 2curry
swap reverse alist>quot ;
: congruify-methods ( alist -- alist' )
dup argument-count [
swap >r object pad-left [ \ f or ] map r>
] curry assoc-map ;
: sorted-methods ( alist -- alist' )
[ [ first ] bi@ classes< ] topological-sort ;
: niceify-method [ dup \ f eq? [ drop f ] when ] map ; : niceify-method [ dup \ f eq? [ drop f ] when ] map ;
M: no-method error. M: no-method error.
"Type check error" print "Type check error" print
nl nl
"Generic word " write dup no-method-generic pprint "Generic word " write dup generic>> pprint
" does not have a method applicable to inputs:" print " does not have a method applicable to inputs:" print
dup no-method-arguments short. dup arguments>> short.
nl nl
"Inputs have signature:" print "Inputs have signature:" print
dup no-method-arguments [ class ] map niceify-method . dup arguments>> [ class ] map niceify-method .
nl nl
"Defined methods in topological order: " print "Available methods: " print
no-method-generic generic>> methods keys
methods congruify-methods sorted-methods keys
[ niceify-method ] map stack. ; [ niceify-method ] map stack. ;
TUPLE: standard-combination ; : make-default-method ( generic -- quot )
[ 0 swap no-method ] curry ;
M: standard-combination method-prologue drop [ ] ; : <default-method> ( generic -- method )
[ { } swap <method> ] keep
[ drop ] [ make-default-method define ] 2bi ;
M: standard-combination generic-prologue drop [ ] ; : define-default-method ( generic -- )
dup <default-method> "default-multi-method" set-word-prop ;
: make-generic ( generic -- quot ) : forget-method ( specializer generic -- )
dup "multi-combination" word-prop generic-prologue swap
[ methods congruify-methods sorted-methods ] keep
multi-dispatch-quot append ;
TUPLE: hook-combination var ;
M: hook-combination method-prologue
drop [ drop ] ;
M: hook-combination generic-prologue
hook-combination-var [ get ] curry ;
: update-generic ( word -- )
dup make-generic define ;
: define-generic ( word combination -- )
over "multi-combination" word-prop over = [
2drop
] [
dupd "multi-combination" set-word-prop
dup H{ } clone "multi-methods" set-word-prop
update-generic
] if ;
: define-standard-generic ( word -- )
T{ standard-combination } define-generic ;
: GENERIC:
CREATE define-standard-generic ; parsing
: 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> update-generic ; inline
: define-method ( quot classes generic -- )
>r [ bootstrap-word ] map r>
[ <method> ] 2keep
[ set-at ] with-methods ;
: forget-method ( classes generic -- )
[ delete-at ] with-methods ; [ delete-at ] with-methods ;
: method>spec ( method -- spec ) : method>spec ( method -- spec )
dup method-classes swap method-generic prefix ; [ "multi-method-specializer" word-prop ]
[ "multi-method-generic" word-prop ] bi prefix ;
: define-generic ( word -- )
dup "multi-methods" word-prop [
drop
] [
[ H{ } clone "multi-methods" set-word-prop ]
[ define-default-method ]
[ update-generic ]
tri
] if ;
! Syntax
: GENERIC:
CREATE define-generic ; parsing
: parse-method ( -- quot classes generic ) : parse-method ( -- quot classes generic )
parse-definition dup 2 tail over second rot first ; parse-definition [ 2 tail ] [ second ] [ first ] tri ;
: METHOD: : create-method-in ( specializer generic -- method )
location create-method dup save-location f set-word ;
>r parse-method [ define-method ] 2keep prefix r>
remember-definition ; parsing : CREATE-METHOD
scan-word scan-object swap create-method-in ;
: (METHOD:) CREATE-METHOD parse-definition ;
: METHOD: (METHOD:) define ; parsing
! For compatibility ! For compatibility
: M: : M:
scan-word 1array scan-word parse-definition scan-word 1array scan-word create-method-in
-rot define-method ; parsing parse-definition
define ; parsing
! Definition protocol. We qualify core generics here ! Definition protocol. We qualify core generics here
USE: qualified USE: qualified
QUALIFIED: syntax QUALIFIED: syntax
PREDICATE: generic < word syntax:M: generic definer drop \ GENERIC: f ;
"multi-combination" word-prop >boolean ;
PREDICATE: standard-generic < word syntax:M: generic definition drop f ;
"multi-combination" word-prop standard-combination? ;
PREDICATE: hook-generic < word
"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 definer.
dup seeing-word
dup pprint-word
dup "multi-combination" word-prop
hook-combination-var pprint-word stack-effect. ;
PREDICATE: method-spec < array PREDICATE: method-spec < array
unclip generic? >r [ class? ] all? r> and ; unclip generic? >r [ class? ] all? r> and ;
syntax:M: method-spec where syntax:M: method-spec where
dup unclip method [ method-loc ] [ second where ] ?if ; dup unclip method [ ] [ first ] ?if where ;
syntax:M: method-spec set-where syntax:M: method-spec set-where
unclip method set-method-loc ; unclip method set-where ;
syntax:M: method-spec definer syntax:M: method-spec definer
drop \ METHOD: \ ; ; unclip method definer ;
syntax:M: method-spec definition syntax:M: method-spec definition
unclip method dup [ method-def ] when ; unclip method definition ;
syntax:M: method-spec synopsis* syntax:M: method-spec synopsis*
dup definer. unclip method synopsis* ;
unclip pprint* pprint* ;
syntax:M: method-spec forget* syntax:M: method-spec forget*
unclip forget-method ; unclip method forget* ;
syntax:M: method-body definer
drop \ METHOD: \ ; ;
syntax:M: method-body synopsis*
dup definer.
[ "multi-method-generic" word-prop pprint-word ]
[ "multi-method-specializer" word-prop pprint* ] bi ;

View File

@ -0,0 +1,66 @@
IN: multi-methods.tests
USING: multi-methods tools.test math sequences namespaces system
kernel strings ;
[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
: setup-canon-test
0 args set
V{ } clone hooks set ;
: canon-test-1
{ integer { cpu x86 } sequence } canonicalize-specializer-1 ;
[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
[
setup-canon-test
canon-test-1
] with-scope
] unit-test
[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
[
setup-canon-test
canon-test-1
canonicalize-specializer-2
] with-scope
] unit-test
[ { integer sequence x86 } ] [
[
setup-canon-test
canon-test-1
canonicalize-specializer-2
args get hooks get length + total set
canonicalize-specializer-3
] with-scope
] unit-test
: example-1
{
{ { { cpu x86 } { os linux } } "a" }
{ { { cpu ppc } } "b" }
{ { string { os windows } } "c" }
} ;
[
{
{ { object x86 linux } "a" }
{ { object ppc object } "b" }
{ { string object windows } "c" }
}
V{ cpu os }
] [
example-1 canonicalize-specializers
] unit-test
[
{
{ { object x86 linux } [ drop drop "a" ] }
{ { object ppc object } [ drop drop "b" ] }
{ { string object windows } [ drop drop "c" ] }
}
[ \ cpu get \ os get ]
] [
example-1 prepare-methods
] unit-test

View File

@ -0,0 +1,37 @@
IN: multi-methods.tests
USING: multi-methods tools.test math sequences namespaces system
kernel strings words compiler.units quotations ;
\ GENERIC: must-infer
\ create-method-in must-infer
\ define-default-method must-infer
DEFER: fake
\ fake H{ } clone "multi-methods" set-word-prop
[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
[ { } \ fake method-word-props ] unit-test
[ t ] [ { } \ fake <method> method-body? ] unit-test
[
[ ] [ \ fake define-default-method ] unit-test
[ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test
[ t ] [ { } \ fake multi-dispatch-quot quotation? ] unit-test
[ t ] [ \ fake make-generic quotation? ] unit-test
[ ] [ \ fake update-generic ] unit-test
DEFER: testing
[ ] [ \ testing define-generic ] unit-test
[ t ] [ \ testing generic? ] unit-test
[ t ] [ \ testing "default-multi-method" word-prop method-body? ] unit-test
] with-compilation-unit

View File

@ -0,0 +1,10 @@
IN: multi-methods.tests
USING: math strings sequences tools.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

View File

@ -0,0 +1,58 @@
IN: multi-methods.tests
USING: multi-methods tools.test math sequences namespaces system
kernel strings definitions prettyprint debugger arrays
hashtables continuations classes assocs ;
GENERIC: first-test
[ t ] [ \ first-test generic? ] unit-test
MIXIN: thing
SINGLETON: paper INSTANCE: paper thing
SINGLETON: scissors INSTANCE: scissors thing
SINGLETON: 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 ] must-fail
[ t ] [ error get no-method? ] unit-test
[ ] [ error get error. ] unit-test
[ t ] [ paper scissors play ] unit-test
[ f ] [ scissors paper play ] unit-test
[ t ] [ { beats? paper scissors } method-spec? ] unit-test
[ ] [ { beats? paper scissors } see ] unit-test
SYMBOL: some-var
GENERIC: hook-test
METHOD: hook-test { array { some-var array } } reverse ;
METHOD: hook-test { { some-var array } } class ;
METHOD: hook-test { hashtable { some-var 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
MIXIN: busted
TUPLE: busted-1 ;
TUPLE: busted-2 ; INSTANCE: busted-2 busted
TUPLE: busted-3 ;
GENERIC: busted-sort
METHOD: busted-sort { busted-1 busted-2 } ;
METHOD: busted-sort { busted-2 busted-3 } ;
METHOD: busted-sort { busted busted } ;

View File

@ -0,0 +1,18 @@
IN: multi-methods.tests
USING: kernel multi-methods tools.test math arrays sequences ;
[ { 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