Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
111fc5e50c
|
|
@ -6,8 +6,7 @@ IN: db.postgresql.ffi
|
||||||
|
|
||||||
<< "postgresql" {
|
<< "postgresql" {
|
||||||
{ [ os winnt? ] [ "libpq.dll" ] }
|
{ [ os winnt? ] [ "libpq.dll" ] }
|
||||||
{ [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] }
|
{ [ os macosx? ] [ "libpq.dylib" ] }
|
||||||
! { [ os macosx? ] [ "libpq.dylib" ] }
|
|
||||||
{ [ os unix? ] [ "libpq.so" ] }
|
{ [ os unix? ] [ "libpq.so" ] }
|
||||||
} cond "cdecl" add-library >>
|
} cond "cdecl" add-library >>
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,87 +1,130 @@
|
||||||
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
|
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays calendar io io.sockets kernel match namespaces
|
USING: arrays calendar combinators channels concurrency.messaging fry io
|
||||||
sequences splitting strings continuations threads ascii
|
io.encodings.8-bit io.sockets kernel math namespaces sequences
|
||||||
io.encodings.utf8 ;
|
sequences.lib singleton splitting strings threads
|
||||||
|
continuations classes.tuple ascii accessors ;
|
||||||
IN: irc
|
IN: irc
|
||||||
|
|
||||||
! "setup" objects
|
! utils
|
||||||
TUPLE: profile server port nickname password default-channels ;
|
: split-at-first ( seq separators -- before after )
|
||||||
C: <profile> profile
|
dupd '[ , member? ] find
|
||||||
|
[ cut 1 tail ]
|
||||||
|
[ swap ]
|
||||||
|
if ;
|
||||||
|
|
||||||
TUPLE: channel-profile name password auto-rejoin ;
|
: spawn-server-linked ( quot name -- thread )
|
||||||
C: <channel-profile> channel-profile
|
>r '[ , [ ] [ ] while ] r>
|
||||||
|
spawn-linked ;
|
||||||
|
! ---
|
||||||
|
|
||||||
|
! Default irc port
|
||||||
|
: irc-port 6667 ;
|
||||||
|
|
||||||
|
! Message used when the client isn't running anymore
|
||||||
|
SINGLETON: irc-end
|
||||||
|
|
||||||
|
! "setup" objects
|
||||||
|
TUPLE: irc-profile server port nickname password default-channels ;
|
||||||
|
C: <irc-profile> irc-profile
|
||||||
|
|
||||||
|
TUPLE: irc-channel-profile name password auto-rejoin ;
|
||||||
|
C: <irc-channel-profile> irc-channel-profile
|
||||||
|
|
||||||
! "live" objects
|
! "live" objects
|
||||||
TUPLE: irc-client profile nick stream stream-process controller-process ;
|
|
||||||
C: <irc-client> irc-client
|
|
||||||
|
|
||||||
TUPLE: nick name channels log ;
|
TUPLE: nick name channels log ;
|
||||||
C: <nick> nick
|
C: <nick> nick
|
||||||
|
|
||||||
TUPLE: channel name topic members log attributes ;
|
TUPLE: irc-client profile nick stream stream-channel controller-channel
|
||||||
C: <channel> channel
|
listeners is-running ;
|
||||||
|
: <irc-client> ( profile -- irc-client )
|
||||||
|
f V{ } clone V{ } clone <nick>
|
||||||
|
f <channel> <channel> V{ } clone f irc-client construct-boa ;
|
||||||
|
|
||||||
|
USE: prettyprint
|
||||||
|
TUPLE: irc-listener channel ;
|
||||||
|
! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? )
|
||||||
|
! tener la opción de dejar de correr un client??
|
||||||
|
: <irc-listener> ( quot -- irc-listener )
|
||||||
|
<channel> irc-listener construct-boa swap
|
||||||
|
[
|
||||||
|
[ channel>> '[ , from ] ]
|
||||||
|
[ '[ , curry f spawn drop ] ]
|
||||||
|
bi* compose "irc-listener" spawn-server-linked drop
|
||||||
|
] [ drop ] 2bi ;
|
||||||
|
|
||||||
|
! TUPLE: irc-channel name topic members log attributes ;
|
||||||
|
! C: <irc-channel> irc-channel
|
||||||
|
|
||||||
! the delegate of all irc messages
|
! the delegate of all irc messages
|
||||||
TUPLE: irc-message timestamp ;
|
TUPLE: irc-message line prefix command parameters trailing timestamp ;
|
||||||
C: <irc-message> irc-message
|
C: <irc-message> irc-message
|
||||||
|
|
||||||
! "irc message" objects
|
! "irc message" objects
|
||||||
TUPLE: logged-in name text ;
|
TUPLE: logged-in < irc-message name ;
|
||||||
C: <logged-in> logged-in
|
C: <logged-in> logged-in
|
||||||
|
|
||||||
TUPLE: ping name ;
|
TUPLE: ping < irc-message ;
|
||||||
C: <ping> ping
|
C: <ping> ping
|
||||||
|
|
||||||
TUPLE: join name channel ;
|
TUPLE: join_ < irc-message ;
|
||||||
C: <join> join
|
C: <join> join_
|
||||||
|
|
||||||
TUPLE: part name channel text ;
|
TUPLE: part < irc-message name channel ;
|
||||||
C: <part> part
|
C: <part> part
|
||||||
|
|
||||||
TUPLE: quit text ;
|
TUPLE: quit ;
|
||||||
C: <quit> quit
|
C: <quit> quit
|
||||||
|
|
||||||
TUPLE: privmsg name text ;
|
TUPLE: privmsg < irc-message name ;
|
||||||
C: <privmsg> privmsg
|
C: <privmsg> privmsg
|
||||||
|
|
||||||
TUPLE: kick channel er ee text ;
|
TUPLE: kick < irc-message channel who ;
|
||||||
C: <kick> kick
|
C: <kick> kick
|
||||||
|
|
||||||
TUPLE: roomlist channel names ;
|
TUPLE: roomlist < irc-message channel names ;
|
||||||
C: <roomlist> roomlist
|
C: <roomlist> roomlist
|
||||||
|
|
||||||
TUPLE: nick-in-use name ;
|
TUPLE: nick-in-use < irc-message name ;
|
||||||
C: <nick-in-use> nick-in-use
|
C: <nick-in-use> nick-in-use
|
||||||
|
|
||||||
TUPLE: notice type text ;
|
TUPLE: notice < irc-message type ;
|
||||||
C: <notice> notice
|
C: <notice> notice
|
||||||
|
|
||||||
TUPLE: mode name channel mode text ;
|
TUPLE: mode < irc-message name channel mode ;
|
||||||
C: <mode> mode
|
C: <mode> mode
|
||||||
! TUPLE: members
|
|
||||||
|
|
||||||
TUPLE: unhandled text ;
|
TUPLE: unhandled < irc-message ;
|
||||||
C: <unhandled> unhandled
|
C: <unhandled> unhandled
|
||||||
|
|
||||||
! "control message" objects
|
|
||||||
TUPLE: command sender ;
|
|
||||||
TUPLE: service predicate quot enabled? ;
|
|
||||||
TUPLE: chat-command from to text ;
|
|
||||||
TUPLE: join-command channel password ;
|
|
||||||
TUPLE: part-command channel text ;
|
|
||||||
|
|
||||||
SYMBOL: irc-client
|
SYMBOL: irc-client
|
||||||
: irc-stream> ( -- stream ) irc-client get irc-client-stream ;
|
: irc-client> ( -- irc-client ) irc-client get ;
|
||||||
: trim-: ( seq -- seq ) [ CHAR: : = ] left-trim ;
|
: irc-stream> ( -- stream ) irc-client> stream>> ;
|
||||||
|
|
||||||
|
: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
|
||||||
|
|
||||||
: parse-name ( string -- string )
|
: parse-name ( string -- string )
|
||||||
trim-: "!" split first ;
|
remove-heading-: "!" split-at-first drop ;
|
||||||
: irc-split ( string -- seq )
|
|
||||||
1 swap [ [ CHAR: : = ] find* ] keep
|
: sender>> ( obj -- string )
|
||||||
swap [ swap cut trim-: ] [ nip f ] if >r [ blank? ] trim trim-:
|
prefix>> parse-name ;
|
||||||
" " split r> [ 1array append ] when* ;
|
|
||||||
|
: split-prefix ( string -- string/f string )
|
||||||
|
dup ":" head?
|
||||||
|
[ remove-heading-: " " split1 ]
|
||||||
|
[ f swap ]
|
||||||
|
if ;
|
||||||
|
|
||||||
|
: split-trailing ( string -- string string/f )
|
||||||
|
":" split1 ;
|
||||||
|
|
||||||
|
: string>irc-message ( string -- object )
|
||||||
|
dup split-prefix split-trailing
|
||||||
|
[ [ blank? ] trim " " split unclip swap ] dip
|
||||||
|
now <irc-message> ;
|
||||||
|
|
||||||
: me? ( name -- ? )
|
: me? ( name -- ? )
|
||||||
irc-client get irc-client-nick nick-name = ;
|
irc-client> nick>> name>> = ;
|
||||||
|
|
||||||
: irc-write ( s -- )
|
: irc-write ( s -- )
|
||||||
irc-stream> stream-write ;
|
irc-stream> stream-write ;
|
||||||
|
|
@ -89,123 +132,155 @@ SYMBOL: irc-client
|
||||||
: irc-print ( s -- )
|
: irc-print ( s -- )
|
||||||
irc-stream> [ stream-print ] keep stream-flush ;
|
irc-stream> [ stream-print ] keep stream-flush ;
|
||||||
|
|
||||||
: nick ( nick -- )
|
! Irc commands
|
||||||
|
|
||||||
|
: NICK ( nick -- )
|
||||||
"NICK " irc-write irc-print ;
|
"NICK " irc-write irc-print ;
|
||||||
|
|
||||||
: login ( nick -- )
|
: LOGIN ( nick -- )
|
||||||
dup nick
|
dup NICK
|
||||||
"USER " irc-write irc-write
|
"USER " irc-write irc-write
|
||||||
" hostname servername :irc.factor" irc-print ;
|
" hostname servername :irc.factor" irc-print ;
|
||||||
|
|
||||||
: connect* ( server port -- )
|
: CONNECT ( server port -- stream )
|
||||||
<inet> utf8 <client> irc-client get set-irc-client-stream ;
|
<inet> latin1 <client> ;
|
||||||
|
|
||||||
: connect ( server -- ) 6667 connect* ;
|
: JOIN ( channel password -- )
|
||||||
|
|
||||||
: join ( channel password -- )
|
|
||||||
"JOIN " irc-write
|
"JOIN " irc-write
|
||||||
[ >r " :" r> 3append ] when* irc-print ;
|
[ " :" swap 3append ] when* irc-print ;
|
||||||
|
|
||||||
: part ( channel text -- )
|
: PART ( channel text -- )
|
||||||
>r "PART " irc-write irc-write r>
|
[ "PART " irc-write irc-write ] dip
|
||||||
" :" irc-write irc-print ;
|
" :" irc-write irc-print ;
|
||||||
|
|
||||||
: say ( line nick -- )
|
: KICK ( channel who -- )
|
||||||
"PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
|
[ "KICK " irc-write irc-write ] dip
|
||||||
|
" " irc-write irc-print ;
|
||||||
|
|
||||||
: quit ( text -- )
|
: PRIVMSG ( nick line -- )
|
||||||
|
[ "PRIVMSG " irc-write irc-write ] dip
|
||||||
|
" :" irc-write irc-print ;
|
||||||
|
|
||||||
|
: SAY ( nick line -- )
|
||||||
|
PRIVMSG ;
|
||||||
|
|
||||||
|
: ACTION ( nick line -- )
|
||||||
|
[ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ;
|
||||||
|
|
||||||
|
: QUIT ( text -- )
|
||||||
"QUIT :" irc-write irc-print ;
|
"QUIT :" irc-write irc-print ;
|
||||||
|
|
||||||
|
: join-channel ( channel-profile -- )
|
||||||
|
[ name>> ] keep password>> JOIN ;
|
||||||
|
|
||||||
|
: irc-connect ( irc-client -- )
|
||||||
|
[ profile>> [ server>> ] keep port>> CONNECT ] keep
|
||||||
|
swap >>stream t >>is-running drop ;
|
||||||
|
|
||||||
GENERIC: handle-irc ( obj -- )
|
GENERIC: handle-irc ( obj -- )
|
||||||
|
|
||||||
M: object handle-irc ( obj -- )
|
M: object handle-irc ( obj -- )
|
||||||
"Unhandled irc object" print drop ;
|
drop ;
|
||||||
|
|
||||||
M: logged-in handle-irc ( obj -- )
|
M: logged-in handle-irc ( obj -- )
|
||||||
logged-in-name irc-client get [ irc-client-nick set-nick-name ] keep
|
name>>
|
||||||
|
irc-client> [ nick>> swap >>name drop ] keep
|
||||||
irc-client-profile profile-default-channels
|
profile>> default-channels>> [ join-channel ] each ;
|
||||||
[
|
|
||||||
[ channel-profile-name ] keep
|
|
||||||
channel-profile-password join
|
|
||||||
] each ;
|
|
||||||
|
|
||||||
M: ping handle-irc ( obj -- )
|
M: ping handle-irc ( obj -- )
|
||||||
"PONG " irc-write
|
"PONG " irc-write
|
||||||
ping-name irc-print ;
|
trailing>> irc-print ;
|
||||||
|
|
||||||
M: nick-in-use handle-irc ( obj -- )
|
M: nick-in-use handle-irc ( obj -- )
|
||||||
nick-in-use-name "_" append nick ;
|
name>> "_" append NICK ;
|
||||||
|
|
||||||
: delegate-timestamp ( obj -- obj )
|
: parse-irc-line ( string -- message )
|
||||||
now <irc-message> over set-delegate ;
|
string>irc-message
|
||||||
|
dup command>> {
|
||||||
|
{ "PING" [ \ ping ] }
|
||||||
|
{ "NOTICE" [ \ notice ] }
|
||||||
|
{ "001" [ \ logged-in ] }
|
||||||
|
{ "433" [ \ nick-in-use ] }
|
||||||
|
{ "JOIN" [ \ join_ ] }
|
||||||
|
{ "PART" [ \ part ] }
|
||||||
|
{ "PRIVMSG" [ \ privmsg ] }
|
||||||
|
{ "QUIT" [ \ quit ] }
|
||||||
|
{ "MODE" [ \ mode ] }
|
||||||
|
{ "KICK" [ \ kick ] }
|
||||||
|
[ drop \ unhandled ]
|
||||||
|
} case
|
||||||
|
[ [ tuple-slots ] [ parameters>> ] bi append ] dip add* >tuple ;
|
||||||
|
|
||||||
MATCH-VARS: ?name ?name2 ?channel ?text ?mode ;
|
! Reader
|
||||||
SYMBOL: line
|
: handle-reader-message ( irc-client irc-message -- )
|
||||||
: match-irc ( string -- )
|
dup handle-irc swap stream-channel>> to ;
|
||||||
dup line set
|
|
||||||
dup print flush
|
|
||||||
irc-split
|
|
||||||
{
|
|
||||||
{ { "PING" ?name }
|
|
||||||
[ ?name <ping> ] }
|
|
||||||
{ { ?name "001" ?name2 ?text }
|
|
||||||
[ ?name2 ?text <logged-in> ] }
|
|
||||||
{ { ?name "433" _ ?name2 "Nickname is already in use." }
|
|
||||||
[ ?name2 <nick-in-use> ] }
|
|
||||||
|
|
||||||
{ { ?name "JOIN" ?channel }
|
: reader-loop ( irc-client -- )
|
||||||
[ ?name ?channel <join> ] }
|
dup stream>> stream-readln [
|
||||||
{ { ?name "PART" ?channel ?text }
|
dup print parse-irc-line handle-reader-message
|
||||||
[ ?name ?channel ?text <part> ] }
|
] [
|
||||||
{ { ?name "PRIVMSG" ?channel ?text }
|
f >>is-running
|
||||||
[ ?name ?channel ?text <privmsg> ] }
|
dup stream>> dispose
|
||||||
{ { ?name "QUIT" ?text }
|
irc-end over controller-channel>> to
|
||||||
[ ?name ?text <quit> ] }
|
stream-channel>> irc-end swap to
|
||||||
|
] if* ;
|
||||||
|
|
||||||
{ { "NOTICE" ?name ?text }
|
! Controller commands
|
||||||
[ ?name ?text <notice> ] }
|
GENERIC: handle-command ( obj -- )
|
||||||
{ { ?name "MODE" ?channel ?mode ?text }
|
|
||||||
[ ?name ?channel ?mode ?text <mode> ] }
|
|
||||||
{ { ?name "KICK" ?channel ?name2 ?text }
|
|
||||||
[ ?channel ?name ?name2 ?text <kick> ] }
|
|
||||||
|
|
||||||
! { { ?name "353" ?name2 _ ?channel ?text }
|
M: object handle-command ( obj -- )
|
||||||
! [ ?text ?channel ?name2 make-member-list ] }
|
. ;
|
||||||
{ _ [ line get <unhandled> ] }
|
|
||||||
} match-cond
|
|
||||||
delegate-timestamp handle-irc flush ;
|
|
||||||
|
|
||||||
: irc-loop ( -- )
|
TUPLE: send-message to text ;
|
||||||
irc-stream> stream-readln
|
C: <send-message> send-message
|
||||||
[ match-irc irc-loop ] when* ;
|
M: send-message handle-command ( obj -- )
|
||||||
|
dup to>> swap text>> SAY ;
|
||||||
|
|
||||||
|
TUPLE: send-action to text ;
|
||||||
|
C: <send-action> send-action
|
||||||
|
M: send-action handle-command ( obj -- )
|
||||||
|
dup to>> swap text>> ACTION ;
|
||||||
|
|
||||||
|
TUPLE: send-quit text ;
|
||||||
|
C: <send-quit> send-quit
|
||||||
|
M: send-quit handle-command ( obj -- )
|
||||||
|
text>> QUIT ;
|
||||||
|
|
||||||
|
: irc-listen ( irc-client quot -- )
|
||||||
|
[ listeners>> ] [ <irc-listener> ] bi* swap push ;
|
||||||
|
|
||||||
|
! Controller loop
|
||||||
|
: controller-loop ( irc-client -- )
|
||||||
|
controller-channel>> from handle-command ;
|
||||||
|
|
||||||
|
! Multiplexer
|
||||||
|
: multiplex-message ( irc-client message -- )
|
||||||
|
swap listeners>> [ channel>> ] map
|
||||||
|
[ '[ , , to ] "message" spawn drop ] each-with ;
|
||||||
|
|
||||||
|
: multiplexer-loop ( irc-client -- )
|
||||||
|
dup stream-channel>> from multiplex-message ;
|
||||||
|
|
||||||
|
! process looping and starting
|
||||||
|
: (spawn-irc-loop) ( irc-client quot name -- )
|
||||||
|
[ over >r curry r> '[ @ , is-running>> ] ] dip
|
||||||
|
spawn-server-linked drop ;
|
||||||
|
|
||||||
|
: spawn-irc-loop ( irc-client quot name -- )
|
||||||
|
'[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ]
|
||||||
|
f spawn drop ;
|
||||||
|
|
||||||
|
: spawn-irc ( irc-client -- )
|
||||||
|
[ [ reader-loop ] "reader-loop" spawn-irc-loop ]
|
||||||
|
[ [ controller-loop ] "controller-loop" spawn-irc-loop ]
|
||||||
|
[ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ]
|
||||||
|
tri ;
|
||||||
|
|
||||||
: do-irc ( irc-client -- )
|
: do-irc ( irc-client -- )
|
||||||
dup irc-client set
|
irc-client [
|
||||||
dup irc-client-profile profile-server
|
irc-client>
|
||||||
over irc-client-profile profile-port connect*
|
[ irc-connect ]
|
||||||
dup irc-client-profile profile-nickname login
|
[ profile>> nickname>> LOGIN ]
|
||||||
[ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ;
|
[ spawn-irc ]
|
||||||
|
tri
|
||||||
: with-infinite-loop ( quot timeout -- quot timeout )
|
] with-variable ;
|
||||||
"looping" print flush
|
|
||||||
over [ drop ] recover dup sleep with-infinite-loop ;
|
|
||||||
|
|
||||||
: start-irc ( irc-client -- )
|
|
||||||
! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ;
|
|
||||||
[ do-irc ] curry 3000 with-infinite-loop ;
|
|
||||||
|
|
||||||
|
|
||||||
! For testing
|
|
||||||
: make-factorbot
|
|
||||||
"irc.freenode.org" 6667 "factorbot" f
|
|
||||||
[
|
|
||||||
"#concatenative-flood" f f <channel-profile> ,
|
|
||||||
] { } make <profile>
|
|
||||||
f V{ } clone V{ } clone <nick>
|
|
||||||
f f f <irc-client> ;
|
|
||||||
|
|
||||||
: test-factorbot
|
|
||||||
make-factorbot start-irc ;
|
|
||||||
|
|
||||||
|
|
@ -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 } ;
|
|
||||||
|
|
@ -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,164 @@ GENERIC: method-prologue ( combination -- quot )
|
||||||
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
|
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
: argument-count ( methods -- n )
|
||||||
|
keys 0 [ length max ] reduce ;
|
||||||
|
|
||||||
|
ERROR: no-method arguments generic ;
|
||||||
|
|
||||||
|
: make-default-method ( methods generic -- quot )
|
||||||
|
>r argument-count r> [ >r narray r> no-method ] 2curry ;
|
||||||
|
|
||||||
|
: multi-dispatch-quot ( methods generic -- quot )
|
||||||
|
[ make-default-method ]
|
||||||
|
[ drop [ >r multi-predicate r> ] assoc-map reverse ]
|
||||||
|
2bi 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
|
||||||
|
|
||||||
TUPLE: no-method arguments generic ;
|
: reveal-method ( method classes generic -- )
|
||||||
|
[ set-at ] with-methods ;
|
||||||
|
|
||||||
: no-method ( argument-count generic -- * )
|
: method ( classes word -- method )
|
||||||
>r narray r> \ no-method construct-boa throw ; inline
|
"multi-methods" word-prop at ;
|
||||||
|
|
||||||
: argument-count ( methods -- n )
|
: create-method ( classes generic -- method )
|
||||||
dup assoc-empty? [ drop 0 ] [
|
2dup method dup [
|
||||||
keys [ length ] map supremum
|
2nip
|
||||||
|
] [
|
||||||
|
drop [ <method> dup ] 2keep reveal-method
|
||||||
] if ;
|
] 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 canonicalize-specializers drop sort-methods
|
||||||
methods congruify-methods sorted-methods keys
|
keys [ niceify-method ] map stack. ;
|
||||||
[ niceify-method ] map stack. ;
|
|
||||||
|
|
||||||
TUPLE: standard-combination ;
|
: forget-method ( specializer generic -- )
|
||||||
|
|
||||||
M: standard-combination method-prologue drop [ ] ;
|
|
||||||
|
|
||||||
M: standard-combination generic-prologue drop [ ] ;
|
|
||||||
|
|
||||||
: make-generic ( generic -- quot )
|
|
||||||
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 ]
|
||||||
|
[ update-generic ]
|
||||||
|
bi
|
||||||
|
] 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 ;
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
@ -0,0 +1,32 @@
|
||||||
|
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
|
||||||
|
|
||||||
|
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 methods prepare-methods >r sort-methods r> ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ { } \ fake multi-dispatch-quot callable? ] 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
|
||||||
|
] with-compilation-unit
|
||||||
|
|
@ -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
|
||||||
|
|
@ -0,0 +1,64 @@
|
||||||
|
IN: multi-methods.tests
|
||||||
|
USING: multi-methods tools.test math sequences namespaces system
|
||||||
|
kernel strings definitions prettyprint debugger arrays
|
||||||
|
hashtables continuations classes assocs accessors ;
|
||||||
|
|
||||||
|
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
|
||||||
|
[ { { } 3 } ] [ error get arguments>> ] 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
|
||||||
|
|
||||||
|
"error" some-var set
|
||||||
|
[ H{ } hook-test ] must-fail
|
||||||
|
[ t ] [ error get no-method? ] unit-test
|
||||||
|
[ { H{ } "error" } ] [ error get arguments>> ] 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 } ;
|
||||||
|
|
@ -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
|
||||||
Loading…
Reference in New Issue