From a1ac7a5c019f2dfa8df2baf795681faed2480bbb Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 12 Jul 2008 00:46:05 -0300 Subject: [PATCH 01/33] irc.client: Add participant mode symbols --- extra/irc/client/client.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 2dbbe8b8f5..65dc2fa017 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -31,6 +31,15 @@ TUPLE: irc-channel-listener < irc-listener name password timeout participants ; TUPLE: irc-nick-listener < irc-listener name ; SYMBOL: +server-listener+ +! participant modes +SYMBOL: +operator+ +SYMBOL: +voice+ +SYMBOL: +normal+ + +: participant-mode ( n -- assoc ) + H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ; + +! listener objects : ( -- irc-listener ) irc-listener boa ; : ( -- irc-server-listener ) @@ -182,7 +191,7 @@ M: quit handle-incoming-irc ( quit -- ) call-next-method ; : >nick/mode ( string -- nick mode ) - dup first "+@" member? [ unclip ] [ f ] if ; + dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; : names-reply>participants ( names-reply -- participants ) trailing>> [ blank? ] trim " " split From 7a09b4aed3e8f428fe31040de143f0b07bfdaaa5 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Mon, 14 Jul 2008 21:39:52 -0300 Subject: [PATCH 02/33] irc.client: Add make-client-messages, move things around, etc --- extra/irc/client/client-tests.factor | 24 +-------------- extra/irc/messages/messages-tests.factor | 37 ++++++++++++++++++++++++ extra/irc/messages/messages.factor | 7 ++++- 3 files changed, 44 insertions(+), 24 deletions(-) create mode 100644 extra/irc/messages/messages-tests.factor diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 2883e47b81..2a1db8c22f 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -20,28 +20,6 @@ IN: irc.client.tests : with-dummy-client ( quot -- ) rot with-variable ; inline -! Parsing tests -irc-message new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing -1array -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - string>irc-message f >>timestamp ] unit-test - -privmsg new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing - "#factortest" >>name -1array -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line f >>timestamp ] unit-test - { "" } make-client dup "factorbot" set-nick current-irc-client [ { t } [ irc> profile>> nickname>> me? ] unit-test @@ -67,7 +45,7 @@ privmsg new profile>> nickname>> ] unit-test { join_ "#factortest" } [ - { ":factorbot!n=factorbo@some.where JOIN :#factortest" + { ":factorbot!n=factorbo@some.where JOIN :#factortest" ":ircserver.net MODE #factortest +ns" ":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 366 factorbot #factortest :End of /NAMES list." diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor new file mode 100644 index 0000000000..1bd6088f82 --- /dev/null +++ b/extra/irc/messages/messages-tests.factor @@ -0,0 +1,37 @@ +USING: kernel tools.test accessors arrays qualified + irc.messages irc.messages.private ; +EXCLUDE: sequences => join ; +IN: irc.messages.tests + +! Parsing tests +irc-message new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + string>irc-message f >>timestamp ] unit-test + +privmsg new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing + "#factortest" >>name +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + parse-irc-line f >>timestamp ] unit-test + +join new + ":someuser!n=user@some.where JOIN :#factortest" >>line + "someuser!n=user@some.where" >>prefix + "JOIN" >>command + { } >>parameters + "#factortest" >>trailing +1array +[ ":someuser!n=user@some.where JOIN :#factortest" + parse-irc-line f >>timestamp ] unit-test + diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 205630d790..24e09467b7 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -21,6 +21,10 @@ TUPLE: mode < irc-message name channel mode ; TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; +: make-client-message ( command parameters trailing -- irc-message ) + irc-message new now >>timestamp + [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; + GENERIC: irc-message>client-line ( irc-message -- string ) M: irc-message irc-message>client-line ( irc-message -- string ) @@ -58,6 +62,8 @@ M: irc-message irc-message>server-line ( irc-message -- string ) : split-trailing ( string -- string string/f ) ":" split1 ; +PRIVATE> + : string>irc-message ( string -- object ) dup split-prefix split-trailing [ [ blank? ] trim " " split unclip swap ] dip @@ -82,4 +88,3 @@ M: irc-message irc-message>server-line ( irc-message -- string ) [ [ tuple-slots ] [ parameters>> ] bi append ] dip [ all-slots over [ length ] bi@ min head ] keep slots>tuple ; -PRIVATE> From 22b67ed3783242f2f89bf051f650e00c97a86f39 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Mon, 14 Jul 2008 21:43:42 -0300 Subject: [PATCH 03/33] irc.client: Rename client message construcor, handle outgoing plain irc-messages. --- extra/irc/client/client.factor | 4 ++-- extra/irc/messages/messages.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 65dc2fa017..c1cf2e844c 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -209,8 +209,8 @@ M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) GENERIC: handle-outgoing-irc ( obj -- ) -! M: irc-message handle-outgoing-irc ( irc-message -- ) -! irc-message>string irc-print ; +M: irc-message handle-outgoing-irc ( irc-message -- ) + irc-message>client-line irc-print ; M: privmsg handle-outgoing-irc ( privmsg -- ) [ name>> ] [ trailing>> ] bi /PRIVMSG ; diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 24e09467b7..1d4fb5b239 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -21,7 +21,7 @@ TUPLE: mode < irc-message name channel mode ; TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; -: make-client-message ( command parameters trailing -- irc-message ) +: ( command parameters trailing -- irc-message ) irc-message new now >>timestamp [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; From 38e31b85c9a00a2ddc73626ce9bdc185af447c25 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 11 Jul 2008 01:16:15 -0300 Subject: [PATCH 04/33] irc.client: Handling of lists of participants in channels, fixes. --- extra/irc/client/client.factor | 45 +++++++++++++++++++++++------- extra/irc/messages/messages.factor | 4 ++- 2 files changed, 38 insertions(+), 11 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 472805f5ae..7ab0ea1ab1 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar accessors destructors namespaces io assocs arrays qualified fry - continuations threads strings classes combinators - irc.messages irc.messages.private ; + continuations threads strings classes combinators splitting hashtables + ascii irc.messages irc.messages.private ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client @@ -27,7 +27,7 @@ TUPLE: irc-client profile stream in-messages out-messages join-messages TUPLE: irc-listener in-messages out-messages ; TUPLE: irc-server-listener < irc-listener ; -TUPLE: irc-channel-listener < irc-listener name password timeout ; +TUPLE: irc-channel-listener < irc-listener name password timeout participants ; TUPLE: irc-nick-listener < irc-listener name ; SYMBOL: +server-listener+ @@ -37,7 +37,7 @@ SYMBOL: +server-listener+ irc-server-listener boa ; : ( name -- irc-channel-listener ) - rot f 60 seconds irc-channel-listener boa ; + rot f 60 seconds H{ } clone irc-channel-listener boa ; : ( name -- irc-nick-listener ) rot irc-nick-listener boa ; @@ -74,6 +74,18 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; listener> [ +server-listener+ listener> ] unless* [ in-messages>> mailbox-put ] [ drop ] if* ; +: remove-participant ( nick channel -- ) + listener> [ participants>> delete-at ] [ drop ] if* ; + +: add-participant ( nick mode channel -- ) + listener> [ participants>> set-at ] [ 2drop ] if* ; + +DEFER: me? + +: maybe-forward-join ( join -- ) + [ prefix>> parse-name me? ] keep and + [ irc> join-messages>> mailbox-put ] when* ; + ! ====================================== ! IRC client messages ! ====================================== @@ -153,17 +165,30 @@ M: privmsg handle-incoming-irc ( privmsg -- ) dup irc-message-origin to-listener ; M: join handle-incoming-irc ( join -- ) - [ [ prefix>> parse-name me? ] keep and - [ irc> join-messages>> mailbox-put ] when* ] + [ maybe-forward-join ] [ dup trailing>> to-listener ] - bi ; + [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] + tri ; M: part handle-incoming-irc ( part -- ) - dup channel>> to-listener ; + [ dup channel>> to-listener ] keep + [ prefix>> parse-name ] [ channel>> ] bi remove-participant ; M: kick handle-incoming-irc ( kick -- ) - [ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when - to-listener ; + [ [ ] [ channel>> ] bi to-listener ] + [ [ who>> ] [ channel>> ] bi remove-participant ] + [ [ ] [ who>> ] bi me? [ unregister-listener ] [ drop ] if ] + tri ; + +: >nick/mode ( string -- nick mode ) + dup first "+@" member? [ unclip ] [ f ] if ; + +: names-reply>participants ( names-reply -- participants ) + trailing>> [ blank? ] trim " " split + [ >nick/mode 2array ] map >hashtable ; + +M: names-reply handle-incoming-irc ( names-reply -- ) + [ names-reply>participants ] [ channel>> listener> ] bi (>>participants) ; M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) broadcast-message-to-listeners ; diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index f1beba9b26..fb41997b84 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -7,7 +7,7 @@ IN: irc.messages TUPLE: irc-message line prefix command parameters trailing timestamp ; TUPLE: logged-in < irc-message name ; TUPLE: ping < irc-message ; -TUPLE: join < irc-message channel ; +TUPLE: join < irc-message ; TUPLE: part < irc-message channel ; TUPLE: quit < irc-message ; TUPLE: privmsg < irc-message name ; @@ -16,6 +16,7 @@ TUPLE: roomlist < irc-message channel names ; TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name channel mode ; +TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; Date: Fri, 11 Jul 2008 20:23:31 -0300 Subject: [PATCH 05/33] irc.client: Some little changes, and handling of quit messages (removes participant from channels, still needs to forward it) --- extra/irc/client/client.factor | 46 ++++++++++++++++-------------- extra/irc/messages/messages.factor | 18 ++++++++++-- 2 files changed, 40 insertions(+), 24 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 7ab0ea1ab1..fb010dbc86 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -37,10 +37,10 @@ SYMBOL: +server-listener+ irc-server-listener boa ; : ( name -- irc-channel-listener ) - rot f 60 seconds H{ } clone irc-channel-listener boa ; + [ ] dip f 60 seconds H{ } clone irc-channel-listener boa ; : ( name -- irc-nick-listener ) - rot irc-nick-listener boa ; + [ ] dip irc-nick-listener boa ; ! ====================================== ! Message objects @@ -52,8 +52,8 @@ SINGLETON: irc-connected ! sent when connection is established UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : terminate-irc ( irc-client -- ) - [ in-messages>> irc-end swap mailbox-put ] - [ f >>is-running drop ] + [ [ irc-end ] dip in-messages>> mailbox-put ] + [ [ f ] dip (>>is-running) ] [ stream>> dispose ] tri ; @@ -77,6 +77,11 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : remove-participant ( nick channel -- ) listener> [ participants>> delete-at ] [ drop ] if* ; +: remove-participant-from-all ( nick -- ) + irc> listeners>> + [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with + assoc-each ; + : add-participant ( nick mode channel -- ) listener> [ participants>> set-at ] [ 2drop ] if* ; @@ -90,14 +95,6 @@ DEFER: me? ! IRC client messages ! ====================================== -GENERIC: irc-message>string ( irc-message -- string ) - -M: irc-message irc-message>string ( irc-message -- string ) - [ command>> ] - [ parameters>> " " sjoin ] - [ trailing>> dup [ CHAR: : prefix ] when ] - tri 3array " " sjoin ; - : /NICK ( nick -- ) "NICK " irc-write irc-print ; @@ -111,7 +108,7 @@ M: irc-message irc-message>string ( irc-message -- string ) : /JOIN ( channel password -- ) "JOIN " irc-write - [ " :" swap 3append ] when* irc-print ; + [ [ " :" ] dip 3append ] when* irc-print ; : /PART ( channel text -- ) [ "PART " irc-write irc-write ] dip @@ -175,11 +172,15 @@ M: part handle-incoming-irc ( part -- ) [ prefix>> parse-name ] [ channel>> ] bi remove-participant ; M: kick handle-incoming-irc ( kick -- ) - [ [ ] [ channel>> ] bi to-listener ] + [ dup channel>> to-listener ] [ [ who>> ] [ channel>> ] bi remove-participant ] - [ [ ] [ who>> ] bi me? [ unregister-listener ] [ drop ] if ] + [ dup who>> me? [ unregister-listener ] [ drop ] if ] tri ; +M: quit handle-incoming-irc ( quit -- ) + [ prefix>> parse-name remove-participant-from-all ] keep + call-next-method ; + : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ f ] if ; @@ -213,8 +214,8 @@ M: part handle-outgoing-irc ( privmsg -- ) ! ====================================== : irc-mailbox-get ( mailbox quot -- ) - swap 5 seconds - '[ , , , mailbox-get-timeout swap call ] + [ 5 seconds ] dip + '[ , , , [ mailbox-get-timeout ] dip call ] [ drop ] recover ; inline : handle-reader-message ( irc-message -- ) @@ -224,11 +225,12 @@ DEFER: (connect-irc) : (handle-disconnect) ( -- ) irc> - [ in-messages>> irc-disconnected swap mailbox-put ] + [ [ irc-disconnected ] dip in-messages>> mailbox-put ] [ dup reconnect-time>> sleep (connect-irc) ] [ profile>> nickname>> /LOGIN ] tri ; +! FIXME: do something with the exception, store somewhere to help debugging : handle-disconnect ( error -- ) drop irc> is-running>> [ (handle-disconnect) ] when ; @@ -300,7 +302,7 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- ) [ name>> ] keep set+run-listener ; M: irc-server-listener (add-listener) ( irc-server-listener -- ) - +server-listener+ swap set+run-listener ; + [ +server-listener+ ] dip set+run-listener ; GENERIC: (remove-listener) ( irc-listener -- ) @@ -309,7 +311,7 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- ) M: irc-channel-listener (remove-listener) ( irc-channel-listener -- ) [ [ out-messages>> ] [ name>> ] bi - \ part new swap >>channel mailbox-put ] keep + [ \ part new ] dip >>channel mailbox-put ] keep name>> unregister-listener ; M: irc-server-listener (remove-listener) ( irc-server-listener -- ) @@ -319,10 +321,10 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- ) [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep swap >>stream t >>is-running - in-messages>> irc-connected swap mailbox-put ; + in-messages>> [ irc-connected ] dip mailbox-put ; : with-irc-client ( irc-client quot -- ) - >r current-irc-client r> with-variable ; inline + [ current-irc-client ] dip with-variable ; inline PRIVATE> diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index fb41997b84..205630d790 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. -USING: kernel fry sequences splitting ascii calendar accessors combinators - classes.tuple math.order ; +USING: kernel fry splitting ascii calendar accessors combinators qualified + arrays classes.tuple math.order ; +RENAME: join sequences => sjoin +EXCLUDE: sequences => join ; IN: irc.messages TUPLE: irc-message line prefix command parameters trailing timestamp ; @@ -19,6 +21,18 @@ TUPLE: mode < irc-message name channel mode ; TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; +GENERIC: irc-message>client-line ( irc-message -- string ) + +M: irc-message irc-message>client-line ( irc-message -- string ) + [ command>> ] + [ parameters>> " " sjoin ] + [ trailing>> dup [ CHAR: : prefix ] when ] + tri 3array " " sjoin ; + +GENERIC: irc-message>server-line ( irc-message -- string ) +M: irc-message irc-message>server-line ( irc-message -- string ) + drop "not implemented yet" ; + Date: Sat, 12 Jul 2008 00:04:39 -0300 Subject: [PATCH 06/33] irc.client: Fix, remove-listener now parts from channels correctly --- extra/irc/client/client.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index fb010dbc86..2dbbe8b8f5 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -206,7 +206,7 @@ GENERIC: handle-outgoing-irc ( obj -- ) M: privmsg handle-outgoing-irc ( privmsg -- ) [ name>> ] [ trailing>> ] bi /PRIVMSG ; -M: part handle-outgoing-irc ( privmsg -- ) +M: part handle-outgoing-irc ( part -- ) [ channel>> ] [ trailing>> "" or ] bi /PART ; ! ====================================== @@ -263,6 +263,7 @@ DEFER: (connect-irc) { { [ dup string? ] [ strings>privmsg ] } { [ dup privmsg instance? ] [ swap >>name ] } + [ nip ] } cond ; : listener-loop ( name listener -- ) @@ -310,8 +311,8 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- ) name>> unregister-listener ; M: irc-channel-listener (remove-listener) ( irc-channel-listener -- ) - [ [ out-messages>> ] [ name>> ] bi - [ \ part new ] dip >>channel mailbox-put ] keep + [ [ name>> ] [ out-messages>> ] bi + [ [ part new ] dip >>channel ] dip mailbox-put ] keep name>> unregister-listener ; M: irc-server-listener (remove-listener) ( irc-server-listener -- ) From b7af781e580ca5694782dae7a161a8a0708c7464 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 12 Jul 2008 00:46:05 -0300 Subject: [PATCH 07/33] irc.client: Add participant mode symbols --- extra/irc/client/client.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 2dbbe8b8f5..65dc2fa017 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -31,6 +31,15 @@ TUPLE: irc-channel-listener < irc-listener name password timeout participants ; TUPLE: irc-nick-listener < irc-listener name ; SYMBOL: +server-listener+ +! participant modes +SYMBOL: +operator+ +SYMBOL: +voice+ +SYMBOL: +normal+ + +: participant-mode ( n -- assoc ) + H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ; + +! listener objects : ( -- irc-listener ) irc-listener boa ; : ( -- irc-server-listener ) @@ -182,7 +191,7 @@ M: quit handle-incoming-irc ( quit -- ) call-next-method ; : >nick/mode ( string -- nick mode ) - dup first "+@" member? [ unclip ] [ f ] if ; + dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; : names-reply>participants ( names-reply -- participants ) trailing>> [ blank? ] trim " " split From 66be27c186c30b3d062079411075237df8d59df9 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Mon, 14 Jul 2008 21:39:52 -0300 Subject: [PATCH 08/33] irc.client: Add make-client-messages, move things around, etc --- extra/irc/client/client-tests.factor | 24 +-------------- extra/irc/messages/messages-tests.factor | 37 ++++++++++++++++++++++++ extra/irc/messages/messages.factor | 7 ++++- 3 files changed, 44 insertions(+), 24 deletions(-) create mode 100644 extra/irc/messages/messages-tests.factor diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 2883e47b81..2a1db8c22f 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -20,28 +20,6 @@ IN: irc.client.tests : with-dummy-client ( quot -- ) rot with-variable ; inline -! Parsing tests -irc-message new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing -1array -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - string>irc-message f >>timestamp ] unit-test - -privmsg new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing - "#factortest" >>name -1array -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line f >>timestamp ] unit-test - { "" } make-client dup "factorbot" set-nick current-irc-client [ { t } [ irc> profile>> nickname>> me? ] unit-test @@ -67,7 +45,7 @@ privmsg new profile>> nickname>> ] unit-test { join_ "#factortest" } [ - { ":factorbot!n=factorbo@some.where JOIN :#factortest" + { ":factorbot!n=factorbo@some.where JOIN :#factortest" ":ircserver.net MODE #factortest +ns" ":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 366 factorbot #factortest :End of /NAMES list." diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor new file mode 100644 index 0000000000..1bd6088f82 --- /dev/null +++ b/extra/irc/messages/messages-tests.factor @@ -0,0 +1,37 @@ +USING: kernel tools.test accessors arrays qualified + irc.messages irc.messages.private ; +EXCLUDE: sequences => join ; +IN: irc.messages.tests + +! Parsing tests +irc-message new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + string>irc-message f >>timestamp ] unit-test + +privmsg new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing + "#factortest" >>name +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + parse-irc-line f >>timestamp ] unit-test + +join new + ":someuser!n=user@some.where JOIN :#factortest" >>line + "someuser!n=user@some.where" >>prefix + "JOIN" >>command + { } >>parameters + "#factortest" >>trailing +1array +[ ":someuser!n=user@some.where JOIN :#factortest" + parse-irc-line f >>timestamp ] unit-test + diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 205630d790..24e09467b7 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -21,6 +21,10 @@ TUPLE: mode < irc-message name channel mode ; TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; +: make-client-message ( command parameters trailing -- irc-message ) + irc-message new now >>timestamp + [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; + GENERIC: irc-message>client-line ( irc-message -- string ) M: irc-message irc-message>client-line ( irc-message -- string ) @@ -58,6 +62,8 @@ M: irc-message irc-message>server-line ( irc-message -- string ) : split-trailing ( string -- string string/f ) ":" split1 ; +PRIVATE> + : string>irc-message ( string -- object ) dup split-prefix split-trailing [ [ blank? ] trim " " split unclip swap ] dip @@ -82,4 +88,3 @@ M: irc-message irc-message>server-line ( irc-message -- string ) [ [ tuple-slots ] [ parameters>> ] bi append ] dip [ all-slots over [ length ] bi@ min head ] keep slots>tuple ; -PRIVATE> From 0038136950a6bf3b9e14282d31a759f69b0bc387 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Mon, 14 Jul 2008 21:43:42 -0300 Subject: [PATCH 09/33] irc.client: Rename client message construcor, handle outgoing plain irc-messages. --- extra/irc/client/client.factor | 4 ++-- extra/irc/messages/messages.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 65dc2fa017..c1cf2e844c 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -209,8 +209,8 @@ M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) GENERIC: handle-outgoing-irc ( obj -- ) -! M: irc-message handle-outgoing-irc ( irc-message -- ) -! irc-message>string irc-print ; +M: irc-message handle-outgoing-irc ( irc-message -- ) + irc-message>client-line irc-print ; M: privmsg handle-outgoing-irc ( privmsg -- ) [ name>> ] [ trailing>> ] bi /PRIVMSG ; diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 24e09467b7..1d4fb5b239 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -21,7 +21,7 @@ TUPLE: mode < irc-message name channel mode ; TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; -: make-client-message ( command parameters trailing -- irc-message ) +: ( command parameters trailing -- irc-message ) irc-message new now >>timestamp [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; From c4db578f04dd7e75489108725121da1de1d12a91 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Wed, 16 Jul 2008 00:31:06 -0300 Subject: [PATCH 10/33] irc.client: Manage participant list changes, forward quit messages to all channels with participant, mode tests. --- extra/irc/client/client-tests.factor | 20 ++++-- extra/irc/client/client.factor | 91 ++++++++++++++++++++-------- extra/irc/messages/messages.factor | 1 + 3 files changed, 82 insertions(+), 30 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 2a1db8c22f..100724ea58 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,7 +1,7 @@ USING: kernel tools.test accessors arrays sequences qualified io.streams.string io.streams.duplex namespaces threads calendar irc.client.private irc.client irc.messages.private - concurrency.mailboxes classes ; + concurrency.mailboxes classes assocs ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests @@ -42,7 +42,7 @@ IN: irc.client.tests ":some.where 001 factorbot :Welcome factorbot" } make-client [ connect-irc ] keep 1 seconds sleep - profile>> nickname>> ] unit-test + profile>> nickname>> ] unit-test { join_ "#factortest" } [ { ":factorbot!n=factorbo@some.where JOIN :#factortest" @@ -52,11 +52,19 @@ IN: irc.client.tests ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" } make-client dup "factorbot" set-nick [ connect-irc ] keep 1 seconds sleep - join-messages>> 5 seconds mailbox-get-timeout + join-messages>> 1 seconds mailbox-get-timeout [ class ] [ trailing>> ] bi ] unit-test -! TODO: user join -! ":somedude!n=user@isp.net JOIN :#factortest" + +{ +join+ "somebody" } [ + { ":somebody!n=somebody@some.where JOIN :#factortest" + } make-client dup "factorbot" set-nick + [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri + [ action>> ] [ nick>> ] bi + ] unit-test ! TODO: channel message -! ":somedude!n=user@isp.net PRIVMSG #factortest :hello" +! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" ! TODO: direct private message ! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello" \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index c1cf2e844c..b51e92107e 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -36,9 +36,14 @@ SYMBOL: +operator+ SYMBOL: +voice+ SYMBOL: +normal+ -: participant-mode ( n -- assoc ) +: participant-mode ( n -- mode ) H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ; +! participant changed actions +SYMBOL: +join+ +SYMBOL: +part+ +SYMBOL: +mode+ + ! listener objects : ( -- irc-listener ) irc-listener boa ; @@ -55,6 +60,9 @@ SYMBOL: +normal+ ! Message objects ! ====================================== +TUPLE: participant-changed nick action ; +C: participant-changed + SINGLETON: irc-end ! sent when the client isn't running anymore SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established @@ -79,19 +87,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : listener> ( name -- listener/f ) irc> listeners>> at ; : unregister-listener ( name -- ) irc> listeners>> delete-at ; -: to-listener ( message name -- ) +GENERIC: to-listener ( message obj -- ) + +M: string to-listener ( message string -- ) listener> [ +server-listener+ listener> ] unless* - [ in-messages>> mailbox-put ] [ drop ] if* ; + [ to-listener ] [ drop ] if* ; + +M: irc-listener to-listener ( message irc-listener -- ) + in-messages>> mailbox-put ; : remove-participant ( nick channel -- ) listener> [ participants>> delete-at ] [ drop ] if* ; -: remove-participant-from-all ( nick -- ) - irc> listeners>> - [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with - assoc-each ; +: listeners-with-participant ( nick -- seq ) + irc> listeners>> values + [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ] + with filter ; -: add-participant ( nick mode channel -- ) +: remove-participant-from-all ( nick -- ) + dup listeners-with-participant [ delete-at ] with each ; + +: add-participant ( mode nick channel -- ) listener> [ participants>> set-at ] [ 2drop ] if* ; DEFER: me? @@ -151,12 +167,31 @@ DEFER: me? dup name>> me? [ prefix>> parse-name ] [ name>> ] if ; : broadcast-message-to-listeners ( message -- ) - irc> listeners>> values [ in-messages>> mailbox-put ] with each ; + irc> listeners>> values [ to-listener ] with each ; + +GENERIC: handle-participant-change ( irc-message -- ) + +M: join handle-participant-change ( join -- ) + [ prefix>> parse-name +join+ ] + [ trailing>> ] bi to-listener ; + +M: part handle-participant-change ( part -- ) + [ prefix>> parse-name +part+ ] + [ channel>> ] bi to-listener ; + +M: kick handle-participant-change ( kick -- ) + [ who>> +part+ ] + [ channel>> ] bi to-listener ; + +M: quit handle-participant-change ( quit -- ) + prefix>> parse-name + [ +part+ ] [ listeners-with-participant ] bi + [ to-listener ] with each ; GENERIC: handle-incoming-irc ( irc-message -- ) M: irc-message handle-incoming-irc ( irc-message -- ) - +server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ; + +server-listener+ listener> [ to-listener ] [ drop ] if* ; M: logged-in handle-incoming-irc ( logged-in -- ) name>> irc> profile>> (>>nickname) ; @@ -171,24 +206,32 @@ M: privmsg handle-incoming-irc ( privmsg -- ) dup irc-message-origin to-listener ; M: join handle-incoming-irc ( join -- ) - [ maybe-forward-join ] - [ dup trailing>> to-listener ] - [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] - tri ; + { [ maybe-forward-join ] ! keep + [ dup trailing>> to-listener ] + [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] + [ handle-participant-change ] + } cleave ; M: part handle-incoming-irc ( part -- ) - [ dup channel>> to-listener ] keep - [ prefix>> parse-name ] [ channel>> ] bi remove-participant ; - -M: kick handle-incoming-irc ( kick -- ) - [ dup channel>> to-listener ] - [ [ who>> ] [ channel>> ] bi remove-participant ] - [ dup who>> me? [ unregister-listener ] [ drop ] if ] + [ dup channel>> to-listener ] + [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ] + [ handle-participant-change ] tri ; +M: kick handle-incoming-irc ( kick -- ) + { [ dup channel>> to-listener ] + [ [ who>> ] [ channel>> ] bi remove-participant ] + [ handle-participant-change ] + [ dup who>> me? [ unregister-listener ] [ drop ] if ] + } cleave ; + M: quit handle-incoming-irc ( quit -- ) - [ prefix>> parse-name remove-participant-from-all ] keep - call-next-method ; + { [ dup prefix>> parse-name listeners-with-participant + [ to-listener ] with each ] + [ handle-participant-change ] + [ prefix>> parse-name remove-participant-from-all ] + [ ] + } cleave call-next-method ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -234,7 +277,7 @@ DEFER: (connect-irc) : (handle-disconnect) ( -- ) irc> - [ [ irc-disconnected ] dip in-messages>> mailbox-put ] + [ [ irc-disconnected ] dip to-listener ] [ dup reconnect-time>> sleep (connect-irc) ] [ profile>> nickname>> /LOGIN ] tri ; diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 1d4fb5b239..5813c72723 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -34,6 +34,7 @@ M: irc-message irc-message>client-line ( irc-message -- string ) tri 3array " " sjoin ; GENERIC: irc-message>server-line ( irc-message -- string ) + M: irc-message irc-message>server-line ( irc-message -- string ) drop "not implemented yet" ; From 62fdbfd6716bfa15ef415025b080691dc6459b3a Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Wed, 16 Jul 2008 02:01:15 -0300 Subject: [PATCH 11/33] irc.client: Remove mailbox-get timeouts --- extra/irc/client/client.factor | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index b51e92107e..405d8ed9ed 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -241,7 +241,8 @@ M: quit handle-incoming-irc ( quit -- ) [ >nick/mode 2array ] map >hashtable ; M: names-reply handle-incoming-irc ( names-reply -- ) - [ names-reply>participants ] [ channel>> listener> ] bi (>>participants) ; + [ names-reply>participants ] [ channel>> listener> ] bi + [ (>>participants) ] [ drop ] if* ; M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) broadcast-message-to-listeners ; @@ -265,11 +266,6 @@ M: part handle-outgoing-irc ( part -- ) ! Reader/Writer ! ====================================== -: irc-mailbox-get ( mailbox quot -- ) - [ 5 seconds ] dip - '[ , , , [ mailbox-get-timeout ] dip call ] - [ drop ] recover ; inline - : handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ; @@ -299,14 +295,14 @@ DEFER: (connect-irc) [ (reader-loop) ] [ handle-disconnect ] recover ; : writer-loop ( -- ) - irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ; + irc> out-messages>> mailbox-get handle-outgoing-irc ; ! ====================================== ! Processing loops ! ====================================== : in-multiplexer-loop ( -- ) - irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ; + irc> in-messages>> mailbox-get handle-incoming-irc ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; @@ -319,9 +315,8 @@ DEFER: (connect-irc) } cond ; : listener-loop ( name listener -- ) - out-messages>> swap - '[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ] - irc-mailbox-get ; + out-messages>> mailbox-get maybe-annotate-with-name + irc> out-messages>> mailbox-put ; : spawn-irc-loop ( quot name -- ) [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip From 46df077192bc70a29fcd1c11c1ed5e0ac7d089d6 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Wed, 16 Jul 2008 05:16:50 -0400 Subject: [PATCH 12/33] Improved backtracking --- extra/backtrack/backtrack.factor | 55 ++++++++++++++++++++++++++++---- 1 file changed, 49 insertions(+), 6 deletions(-) diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 7ab11abd6d..22c9afb322 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -1,20 +1,63 @@ ! Copyright (C) 2008 William Schlieper ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences namespaces fry ; +USING: kernel continuations combinators sequences quotations arrays namespaces + fry summary assocs math math.order macros ; IN: backtrack SYMBOL: failure +V{ } failure set-global -: amb ( seq -- elt ) - failure get - '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each - , continue ] callcc1 ; +ERROR: amb-failure ; + +M: amb-failure summary drop "Backtracking failure" ; : fail ( -- ) - f amb drop ; + failure get dup empty? [ amb-failure ] + [ pop continue ] if ; : require ( ? -- ) [ fail ] unless ; +MACRO: checkpoint ( quot -- quot' ) + '[ [ '[ failure get push , continue ] callcc0 @ ] callcc0 ] ; + +: number-from ( from -- from+n ) + [ 1 + number-from ] checkpoint ; + + + { { +lt+ [ fail ] } + { +eq+ [ ] } + { +gt+ [ [ 1 + number-from-to ] checkpoint ] } } case ; + +: amb-integer ( seq -- int ) + length 1 - 0 number-from-to nip ; + +PRIVATE> + +: amb-lazy ( seq -- elt ) + [ amb-integer ] [ nth ] bi ; + +MACRO: amb ( seq -- quot ) + dup length + { { 0 [ drop [ fail f ] ] } + { 1 [ first 1quotation ] } + [ drop [ first ] [ rest ] bi + '[ , [ drop , amb ] checkpoint ] ] } case ; + +MACRO: amb-execute ( seq -- quot ) + [ length ] [ [ 1quotation ] assoc-map ] bi + '[ , amb , case ] ; + +: if-amb ( true false -- ) + [ + [ { t f } amb ] + [ '[ @ require t ] ] + [ '[ @ f ] ] + tri* if + ] with-scope ; inline + From 2b9df400af31c8d4e4732dde9dee3847aff0bec4 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Wed, 16 Jul 2008 06:08:44 -0400 Subject: [PATCH 13/33] Made backtrack actually faster by removing list push/pops --- extra/backtrack/backtrack.factor | 37 ++++++++++++++++++-------------- 1 file changed, 21 insertions(+), 16 deletions(-) diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 22c9afb322..3c1a794121 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -7,51 +7,56 @@ USING: kernel continuations combinators sequences quotations arrays namespaces IN: backtrack SYMBOL: failure -V{ } failure set-global ERROR: amb-failure ; M: amb-failure summary drop "Backtracking failure" ; : fail ( -- ) - failure get dup empty? [ amb-failure ] - [ pop continue ] if ; + failure get [ continue ] + [ amb-failure ] if* ; : require ( ? -- ) [ fail ] unless ; MACRO: checkpoint ( quot -- quot' ) - '[ [ '[ failure get push , continue ] callcc0 @ ] callcc0 ] ; + '[ failure get , + '[ '[ failure set , continue ] callcc0 + , failure set @ ] callcc0 ] ; : number-from ( from -- from+n ) [ 1 + number-from ] checkpoint ; - { { +lt+ [ fail ] } - { +eq+ [ ] } - { +gt+ [ [ 1 + number-from-to ] checkpoint ] } } case ; + 2dup < [ fail ] when unsafe-number-from-to ; : amb-integer ( seq -- int ) length 1 - 0 number-from-to nip ; +MACRO: unsafe-amb ( seq -- quot ) + dup length 1 = + [ first 1quotation ] + [ [ first ] [ rest ] bi + '[ , [ drop , unsafe-amb ] checkpoint ] ] if ; + PRIVATE> : amb-lazy ( seq -- elt ) [ amb-integer ] [ nth ] bi ; -MACRO: amb ( seq -- quot ) - dup length - { { 0 [ drop [ fail f ] ] } - { 1 [ first 1quotation ] } - [ drop [ first ] [ rest ] bi - '[ , [ drop , amb ] checkpoint ] ] } case ; +: amb ( seq -- elt ) + dup empty? + [ drop fail f ] + [ unsafe-amb ] if ; inline MACRO: amb-execute ( seq -- quot ) - [ length ] [ [ 1quotation ] assoc-map ] bi - '[ , amb , case ] ; + [ length 1 - ] [ [ 1quotation ] assoc-map ] bi + '[ , 0 unsafe-number-from-to nip , case ] ; : if-amb ( true false -- ) [ From cac7ffdc3c89b864c345e2fee42c2df44c4fab8e Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Wed, 16 Jul 2008 07:10:45 -0400 Subject: [PATCH 14/33] Removed helper functions from benchmark.backtrack --- extra/benchmark/backtrack/backtrack.factor | 12 ------------ 1 file changed, 12 deletions(-) mode change 100644 => 100755 extra/benchmark/backtrack/backtrack.factor diff --git a/extra/benchmark/backtrack/backtrack.factor b/extra/benchmark/backtrack/backtrack.factor old mode 100644 new mode 100755 index e9a5ad0ed8..5d011b5d36 --- a/extra/benchmark/backtrack/backtrack.factor +++ b/extra/benchmark/backtrack/backtrack.factor @@ -12,18 +12,6 @@ IN: benchmark.backtrack : nop ; -MACRO: amb-execute ( seq -- quot ) - [ length ] [ [ 1quotation ] assoc-map ] bi - '[ , amb , case ] ; - -: if-amb ( true false -- ) - [ - [ { t f } amb ] - [ '[ @ require t ] ] - [ '[ @ f ] ] - tri* if - ] with-scope ; inline - : do-something ( a b -- c ) { + - * } amb-execute ; From d0ae6bdb8f000be2c891edd605f3e9e238a27d0a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 16 Jul 2008 16:48:09 -0500 Subject: [PATCH 15/33] Make array length foldable --- core/arrays/arrays.factor | 8 ++++---- core/bootstrap/compiler/compiler.factor | 2 +- core/bootstrap/primitives.factor | 8 ++++++-- core/byte-arrays/byte-arrays.factor | 4 ++-- core/classes/tuple/tuple.factor | 2 +- core/hashtables/hashtables.factor | 6 +++--- core/sequences/sequences.factor | 3 --- 7 files changed, 17 insertions(+), 16 deletions(-) diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index 9c5f40d883..02e0e45544 100755 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private math math.private sequences -sequences.private ; +USING: accessors kernel kernel.private math math.private +sequences sequences.private ; IN: arrays M: array clone (clone) ; -M: array length array-capacity ; +M: array length length>> ; M: array nth-unsafe >r >fixnum r> array-nth ; M: array set-nth-unsafe >r >fixnum r> set-array-nth ; M: array resize resize-array ; diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 04e53046fe..f25eafeb17 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -37,7 +37,7 @@ nl array? hashtable? vector? tuple? sbuf? node? tombstone? - array-capacity array-nth set-array-nth + array-nth set-array-nth wrap probe diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index b2b6dc4e59..a6ebf13f4d 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -225,7 +225,9 @@ bi { "imaginary" { "real" "math" } read-only } } define-builtin -"array" "arrays" create { } define-builtin +"array" "arrays" create { + { "length" { "array-capacity" "sequences.private" } read-only } +} define-builtin "wrapper" "kernel" create { { "wrapped" read-only } @@ -261,7 +263,9 @@ bi { "sub-primitive" read-only } } define-builtin -"byte-array" "byte-arrays" create { } define-builtin +"byte-array" "byte-arrays" create { + { "length" { "array-capacity" "sequences.private" } read-only } +} define-builtin "callstack" "kernel" create { } define-builtin diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index d603470810..5461da2b84 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien.accessors sequences +USING: accessors kernel kernel.private alien.accessors sequences sequences.private math ; IN: byte-arrays M: byte-array clone (clone) ; -M: byte-array length array-capacity ; +M: byte-array length length>> ; M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 17d8e36935..4216a5dc3d 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -91,7 +91,7 @@ ERROR: bad-superclass class ; #! 4 slot == superclasses>> rot dup tuple? [ layout-of 4 slot - 2dup array-capacity fixnum< + 2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if ] [ 3drop f ] if ; inline diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index e804bb76fa..943071a9f8 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -12,7 +12,7 @@ TUPLE: hashtable > 1 fixnum-fast fixnum-bitand ; inline : hash@ ( key array -- i ) >r hashcode >fixnum dup fixnum+fast r> wrap ; inline @@ -30,7 +30,7 @@ TUPLE: hashtable ] if ; inline : key@ ( key hash -- array n ? ) - array>> dup array-capacity 0 eq? + array>> dup length>> 0 eq? [ no-key ] [ 2dup hash@ (key@) ] if ; inline : ( n -- array ) @@ -71,7 +71,7 @@ TUPLE: hashtable : hash-large? ( hash -- ? ) [ count>> 3 fixnum*fast 1 fixnum+fast ] - [ array>> array-capacity ] bi fixnum> ; inline + [ array>> length>> ] bi fixnum> ; inline : hash-stale? ( hash -- ? ) [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 11cfb975df..07900a900d 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -60,9 +60,6 @@ INSTANCE: immutable-sequence sequence Date: Wed, 16 Jul 2008 19:33:33 -0400 Subject: [PATCH 16/33] Added participant lists --- extra/irc/ui/load/load.factor | 2 +- extra/irc/ui/ui.factor | 85 ++++++++++++++++++++++++++--------- 2 files changed, 66 insertions(+), 21 deletions(-) diff --git a/extra/irc/ui/load/load.factor b/extra/irc/ui/load/load.factor index 6655f310e7..e6f4d07b56 100755 --- a/extra/irc/ui/load/load.factor +++ b/extra/irc/ui/load/load.factor @@ -5,7 +5,7 @@ USING: kernel io.files parser editors sequences ; IN: irc.ui.load -: file-or ( path path -- path ) over exists? ? ; +: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ; : personal-ui-rc ( -- path ) home ".ircui-rc" append-path ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 12f9d01183..a79920efe5 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -5,8 +5,8 @@ USING: accessors kernel threads combinators concurrency.mailboxes sequences strings hashtables splitting fry assocs hashtables ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures - ui.gadgets.tabs ui.gadgets.grids - io io.styles namespaces calendar calendar.format + ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels + io io.styles namespaces calendar calendar.format models irc.client irc.client.private irc.messages irc.messages.private irc.ui.commandparser irc.ui.load ; @@ -18,11 +18,18 @@ SYMBOL: client TUPLE: ui-window client tabs ; +TUPLE: irc-tab < frame listener client listmodel ; + : write-color ( str color -- ) foreground associate format ; : red { 0.5 0 0 1 } ; : green { 0 0.5 0 1 } ; : blue { 0 0 1 1 } ; +: black { 0 0 0 1 } ; + +: colors H{ { +operator+ { 0 0.5 0 1 } } + { +voice+ { 0 0 1 1 } } + { +normal+ { 0 0 0 1 } } } ; : dot-or-parens ( string -- string ) dup empty? [ drop "." ] @@ -64,6 +71,14 @@ M: quit write-irc " has left IRC" red write-color trailing>> dot-or-parens red write-color ; +M: mode write-irc + "* " blue write-color + [ name>> write ] keep + " has applied mode " blue write-color + [ mode>> write ] keep + " to " blue write-color + channel>> write ; + M: irc-end write-irc drop "* You have left IRC" red write-color ; @@ -84,20 +99,39 @@ M: irc-message write-irc [ print-irc ] [ listener get write-message ] bi ; -: display ( stream listener -- ) +GENERIC: handle-inbox ( tab message -- ) + +: filter-participants ( assoc val -- alist ) + [ >alist ] dip + '[ second , = ] filter ; + +: update-participants ( tab -- ) + [ listmodel>> ] [ listener>> participants>> ] bi + [ +operator+ filter-participants ] + [ +voice+ filter-participants ] + [ +normal+ filter-participants ] tri + append append swap set-model ; + +M: participant-changed handle-inbox + drop update-participants ; + +M: object handle-inbox + nip print-irc ; + +: display ( stream tab -- ) '[ , [ [ t ] - [ , read-message print-irc ] + [ , dup listener>> read-message handle-inbox ] [ ] while ] with-output-stream ] "ircv" spawn drop ; -: ( listener -- pane ) +: ( tab -- tab pane ) - [ swap display ] keep ; + [ swap display ] 2keep ; TUPLE: irc-editor < editor outstream listener client ; -: ( page pane listener -- client editor ) - irc-editor new-editor - swap >>listener swap >>outstream +: ( tab pane -- tab editor ) + over irc-editor new-editor + swap listener>> >>listener swap >>outstream over client>> >>client ; : editor-send ( irc-editor -- ) @@ -113,25 +147,36 @@ irc-editor "general" f { { T{ key-down f f "ENTER" } editor-send } } define-command-map -TUPLE: irc-page < frame listener client ; +: ( -- gadget model ) + [ drop ] + [ first2 [