From 1603be0cec3a03925c7ec8f3bf3c7fc8ea23b72b Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 7 Aug 2008 14:00:54 -0300 Subject: [PATCH 1/4] irc.client: Improve testing, better handling of participant list changes notifications, fix quit notification. --- extra/irc/client/client-tests.factor | 285 ++++++++++++--------------- extra/irc/client/client.factor | 62 +++--- 2 files changed, 147 insertions(+), 200 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 1b338df442..97532cbd95 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,190 +1,153 @@ USING: kernel tools.test accessors arrays sequences qualified - io.streams.string io.streams.duplex namespaces threads + io io.streams.duplex namespaces threads calendar irc.client.private irc.client irc.messages.private concurrency.mailboxes classes assocs combinators ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests -! Utilities -: ( lines -- stream ) - "\n" join ; +! Streams for testing +TUPLE: mb-writer lines last-line disposed ; +TUPLE: mb-reader lines disposed ; +: ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ; +: ( -- mb-reader ) f mb-reader boa ; +: push-line ( line test-reader-stream -- ) lines>> mailbox-put ; +: ( -- stream ) ; +M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ; +M: mb-writer stream-flush ( mb-writer -- ) drop ; +M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ; +M: mb-writer stream-nl ( mb-writer -- ) + [ [ last-line>> concat ] [ lines>> ] bi push ] keep + V{ } clone >>last-line drop ; -: make-client ( lines -- irc-client ) - "someserver" irc-port "factorbot" f - swap [ 2nip f ] curry >>connect ; +: spawn-client ( lines listeners -- irc-client ) + "someserver" irc-port "factorbot" f + + t >>is-running + >>stream + dup [ spawn-irc yield ] with-irc-client ; -: set-nick ( irc-client nickname -- ) - swap profile>> (>>nickname) ; +! to be used inside with-irc-client quotations +: %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ; +: %join ( channel -- ) irc> add-listener ; +: %push-line ( line -- ) irc> stream>> in>> push-line yield yield ; -: with-dummy-client ( irc-client quot -- ) - [ current-irc-client ] dip with-variable ; inline +: read-matching-message ( listener quot: ( msg -- ? ) -- irc-message ) + [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; -{ "" } make-client dup "factorbot" set-nick [ - { t } [ irc> profile>> nickname>> me? ] unit-test +: with-irc ( quot: ( -- ) -- ) + [ spawn-client ] dip [ f %push-line ] compose with-irc-client ; inline - { "factorbot" } [ irc> profile>> nickname>> ] unit-test +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! TESTS +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test +[ { t } [ irc> profile>> nickname>> me? ] unit-test - { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line irc-message-origin ] unit-test + { "factorbot" } [ irc> profile>> nickname>> ] unit-test - { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" - parse-irc-line irc-message-origin ] unit-test -] with-dummy-client + { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test + + { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + parse-irc-line irc-message-origin ] unit-test + + { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" + parse-irc-line irc-message-origin ] unit-test +] with-irc ! Test login and nickname set -{ "factorbot" } [ - { "NOTICE AUTH :*** Looking up your hostname..." - "NOTICE AUTH :*** Checking ident" - "NOTICE AUTH :*** Found your hostname" - "NOTICE AUTH :*** No identd (auth) response" - ":some.where 001 factorbot :Welcome factorbot" - } make-client - { [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ profile>> nickname>> ] - [ terminate-irc ] - } cleave ] unit-test +[ { "factorbot2" } [ + ":some.where 001 factorbot2 :Welcome factorbot2" %push-line + irc> profile>> nickname>> + ] unit-test +] with-irc -{ 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." - ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" - } make-client - { [ "factorbot" set-nick ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ join-messages>> 0.1 seconds mailbox-get-timeout ] - [ terminate-irc ] - } cleave - [ class ] [ trailing>> ] bi ] unit-test +[ { join_ "#factortest" } [ + { ":factorbot!n=factorbo@some.where JOIN :#factortest" + ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." + ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" + } [ %push-line ] each + irc> join-messages>> 0.1 seconds mailbox-get-timeout + [ class ] [ trailing>> ] bi + ] unit-test +] with-irc -{ +join+ "somebody" } [ - { ":somebody!n=somebody@some.where JOIN :#factortest" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "#factortest" ] dip at - [ read-message drop ] [ read-message drop ] [ read-message ] tri ] - [ terminate-irc ] - } cleave - [ action>> ] [ nick>> ] bi - ] unit-test +[ { T{ participant-changed f "somebody" +join+ } } [ + "#factortest" [ %add-named-listener ] keep + ":somebody!n=somebody@some.where JOIN :#factortest" %push-line + [ participant-changed? ] read-matching-message + ] unit-test +] with-irc -{ privmsg "#factortest" "hello" } [ - { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "#factortest" ] dip at - [ read-message drop ] [ read-message ] bi ] - [ terminate-irc ] - } cleave - [ class ] [ name>> ] [ trailing>> ] tri - ] unit-test +[ { privmsg "#factortest" "hello" } [ + "#factortest" [ %add-named-listener ] keep + ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line + [ privmsg? ] read-matching-message + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test +] with-irc -{ privmsg "factorbot" "hello" } [ - { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "somedude" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "somedude" ] dip at - [ read-message drop ] [ read-message ] bi ] - [ terminate-irc ] - } cleave - [ class ] [ name>> ] [ trailing>> ] tri - ] unit-test +[ { privmsg "factorbot" "hello" } [ + "somedude" [ %add-named-listener ] keep + ":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line + [ privmsg? ] read-matching-message + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test +] with-irc ! Participants lists tests -{ H{ { "somedude" +normal+ } } } [ - { ":somedude!n=user@isp.net JOIN :#factortest" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at participants>> ] - [ terminate-irc ] - } cleave - ] unit-test +[ { H{ { "somedude" +normal+ } } } [ + "#factortest" [ %add-named-listener ] keep + ":somedude!n=user@isp.net JOIN :#factortest" %push-line + participants>> + ] unit-test +] with-irc -{ H{ { "somedude2" +normal+ } } } [ - { ":somedude!n=user@isp.net PART #factortest" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ - H{ { "somedude2" +normal+ } - { "somedude" +normal+ } } clone >>participants ] keep - ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at participants>> ] - [ terminate-irc ] - } cleave - ] unit-test +[ { H{ { "somedude2" +normal+ } } } [ + "#factortest" + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude!n=user@isp.net PART #factortest" %push-line + participants>> + ] unit-test +] with-irc -{ H{ { "somedude2" +normal+ } } } [ - { ":somedude!n=user@isp.net QUIT" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ - H{ { "somedude2" +normal+ } - { "somedude" +normal+ } } clone >>participants ] keep - ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at participants>> ] - [ terminate-irc ] - } cleave - ] unit-test +[ { H{ { "somedude2" +normal+ } } } [ + "#factortest" + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude!n=user@isp.net QUIT" %push-line + participants>> + ] unit-test +] with-irc -{ H{ { "somedude2" +normal+ } } } [ - { ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ - H{ { "somedude2" +normal+ } - { "somedude" +normal+ } } clone >>participants ] keep - ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at participants>> ] - [ terminate-irc ] - } cleave - ] unit-test +[ { H{ { "somedude2" +normal+ } } } [ + "#factortest" + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude2!n=user2@isp.net KICK #factortest somedude" %push-line + participants>> + ] unit-test +] with-irc ! Namelist change notification -{ T{ participant-changed f f f } } [ - { ":ircserver.net 353 factorbot @ #factortest :@factorbot " - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ] - [ terminate-irc ] - } cleave - ] unit-test +[ { T{ participant-changed f f f } } [ + "#factortest" [ %add-named-listener ] keep + ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line + [ participant-changed? ] read-matching-message + ] unit-test +] with-irc -{ T{ participant-changed f "somedude" +part+ } } [ - { ":somedude!n=user@isp.net QUIT" } make-client - { [ "factorbot" set-nick ] - [ listeners>> - [ "#factortest" [ - H{ { "somedude" +normal+ } } clone >>participants ] keep - ] dip set-at ] - [ connect-irc ] - [ drop 0.1 seconds sleep ] - [ listeners>> [ "#factortest" ] dip at - [ read-message drop ] [ read-message drop ] [ read-message ] tri ] - [ terminate-irc ] - } cleave - ] unit-test \ No newline at end of file +[ { T{ participant-changed f "somedude" +part+ } } [ + "#factortest" + H{ { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude!n=user@isp.net QUIT" %push-line + [ participant-changed? ] read-matching-message + ] unit-test +] with-irc \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 99922b1fb5..07885a3f82 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -100,17 +100,21 @@ M: string to-listener ( message string -- ) listener> [ +server-listener+ listener> ] unless* [ to-listener ] [ drop ] if* ; +M: irc-listener to-listener ( message irc-listener -- ) + in-messages>> mailbox-put ; + : unregister-listener ( name -- ) irc> listeners>> [ at [ irc-listener-end ] dip to-listener ] [ delete-at ] 2bi ; -M: irc-listener to-listener ( message irc-listener -- ) - in-messages>> mailbox-put ; +: (remove-participant) ( nick listener -- ) + [ participants>> delete-at ] + [ [ +part+ ] dip to-listener ] 2bi ; : remove-participant ( nick channel -- ) - listener> [ participants>> delete-at ] [ drop ] if* ; + listener> [ (remove-participant) ] [ drop ] if* ; : listeners-with-participant ( nick -- seq ) irc> listeners>> values @@ -118,10 +122,13 @@ M: irc-listener to-listener ( message irc-listener -- ) with filter ; : remove-participant-from-all ( nick -- ) - dup listeners-with-participant [ participants>> delete-at ] with each ; + dup listeners-with-participant [ (remove-participant) ] with each ; : add-participant ( mode nick channel -- ) - listener> [ participants>> set-at ] [ 2drop ] if* ; + listener> [ + [ participants>> set-at ] + [ [ +join+ ] dip to-listener ] 2bi + ] [ 2drop ] if* ; DEFER: me? @@ -164,25 +171,6 @@ DEFER: me? : broadcast-message-to-listeners ( message -- ) 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 -- ) @@ -201,31 +189,27 @@ 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 +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] - [ handle-participant-change ] - } cleave ; + [ maybe-forward-join ] + [ dup trailing>> to-listener ] + [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] + tri ; M: part handle-incoming-irc ( part -- ) [ dup channel>> to-listener ] [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ] - [ handle-participant-change ] - tri ; + bi ; 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 ; + [ dup channel>> to-listener ] + [ [ who>> ] [ channel>> ] bi remove-participant ] + [ dup who>> me? [ unregister-listener ] [ drop ] if ] + tri ; M: quit handle-incoming-irc ( quit -- ) [ dup prefix>> parse-name listeners-with-participant [ to-listener ] with each ] - [ handle-participant-change ] [ prefix>> parse-name remove-participant-from-all ] - tri ; + bi ; ! FIXME: implement this ! M: mode handle-incoming-irc ( mode -- ) call-next-method ; @@ -367,7 +351,7 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- ) in-messages>> [ irc-connected ] dip mailbox-put ; : with-irc-client ( irc-client quot: ( -- ) -- ) - [ current-irc-client ] dip with-variable ; inline + [ \ current-irc-client ] dip with-variable ; inline PRIVATE> From cd77f8ba503997b9894fca442dc05f2707689b15 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 7 Aug 2008 23:02:29 -0300 Subject: [PATCH 2/4] irc.client: Handle nick changes in participant lists and forward to channels with the participant. Forward mode messages to channels. --- extra/irc/client/client-tests.factor | 37 +++++++++++++++++++++++----- extra/irc/client/client.factor | 31 +++++++++++++++++------ 2 files changed, 55 insertions(+), 13 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 97532cbd95..2b4b501952 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -30,7 +30,7 @@ M: mb-writer stream-nl ( mb-writer -- ) ! to be used inside with-irc-client quotations : %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ; : %join ( channel -- ) irc> add-listener ; -: %push-line ( line -- ) irc> stream>> in>> push-line yield yield ; +: %push-line ( line -- ) irc> stream>> in>> push-line yield ; : read-matching-message ( listener quot: ( msg -- ? ) -- irc-message ) [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; @@ -96,7 +96,14 @@ M: mb-writer stream-nl ( mb-writer -- ) ] unit-test ] with-irc -! Participants lists tests +[ { mode } [ + "#factortest" [ %add-named-listener ] keep + ":ircserver.net MODE #factortest +ns" %push-line + [ mode? ] read-matching-message class + ] unit-test +] with-irc + +! Participant lists tests [ { H{ { "somedude" +normal+ } } } [ "#factortest" [ %add-named-listener ] keep ":somedude!n=user@isp.net JOIN :#factortest" %push-line @@ -134,8 +141,17 @@ M: mb-writer stream-nl ( mb-writer -- ) ] unit-test ] with-irc +[ { H{ { "somedude2" +normal+ } } } [ + "#factortest" + H{ { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude!n=user2@isp.net NICK :somedude2" %push-line + participants>> + ] unit-test +] with-irc + ! Namelist change notification -[ { T{ participant-changed f f f } } [ +[ { T{ participant-changed f f f f } } [ "#factortest" [ %add-named-listener ] keep ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line @@ -143,11 +159,20 @@ M: mb-writer stream-nl ( mb-writer -- ) ] unit-test ] with-irc -[ { T{ participant-changed f "somedude" +part+ } } [ +[ { T{ participant-changed f "somedude" +part+ f } } [ "#factortest" - H{ { "somedude" +normal+ } } clone >>participants + H{ { "somedude" +normal+ } } clone >>participants [ %add-named-listener ] keep ":somedude!n=user@isp.net QUIT" %push-line [ participant-changed? ] read-matching-message ] unit-test -] with-irc \ No newline at end of file +] with-irc + +[ { T{ participant-changed f "somedude" +nick+ "somedude2" } } [ + "#factortest" + H{ { "somedude" +normal+ } } clone >>participants + [ %add-named-listener ] keep + ":somedude!n=user2@isp.net NICK :somedude2" %push-line + [ participant-changed? ] read-matching-message + ] unit-test +] with-irc diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 07885a3f82..e91767b22d 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -41,6 +41,7 @@ SYMBOL: +normal+ SYMBOL: +join+ SYMBOL: +part+ SYMBOL: +mode+ +SYMBOL: +nick+ ! listener objects : ( -- irc-listener ) irc-listener boa ; @@ -59,7 +60,7 @@ SYMBOL: +mode+ ! Message objects ! ====================================== -TUPLE: participant-changed nick action ; +TUPLE: participant-changed nick action parameter ; C: participant-changed SINGLETON: irc-listener-end ! send to a listener to stop its execution @@ -111,7 +112,7 @@ M: irc-listener to-listener ( message irc-listener -- ) : (remove-participant) ( nick listener -- ) [ participants>> delete-at ] - [ [ +part+ ] dip to-listener ] 2bi ; + [ [ +part+ f ] dip to-listener ] 2bi ; : remove-participant ( nick channel -- ) listener> [ (remove-participant) ] [ drop ] if* ; @@ -124,10 +125,21 @@ M: irc-listener to-listener ( message irc-listener -- ) : remove-participant-from-all ( nick -- ) dup listeners-with-participant [ (remove-participant) ] with each ; +: notify-rename ( newnick oldnick listener -- ) + [ participant-changed new +nick+ >>action + [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ; + +: rename-participant ( newnick oldnick listener -- ) + [ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ] + [ notify-rename ] 3bi ; + +: rename-participant-in-all ( oldnick newnick -- ) + swap dup listeners-with-participant [ rename-participant ] with with each ; + : add-participant ( mode nick channel -- ) listener> [ [ participants>> set-at ] - [ [ +join+ ] dip to-listener ] 2bi + [ [ +join+ f ] dip to-listener ] 2bi ] [ 2drop ] if* ; DEFER: me? @@ -211,9 +223,14 @@ M: quit handle-incoming-irc ( quit -- ) [ prefix>> parse-name remove-participant-from-all ] bi ; -! FIXME: implement this -! M: mode handle-incoming-irc ( mode -- ) call-next-method ; -! M: nick handle-incoming-irc ( nick -- ) call-next-method ; +M: mode handle-incoming-irc ( mode -- ) ! FIXME: modify participant list + dup channel>> to-listener ; + +M: nick handle-incoming-irc ( nick -- ) + [ dup prefix>> parse-name listeners-with-participant + [ to-listener ] with each ] + [ [ prefix>> parse-name ] [ trailing>> ] bi rename-participant-in-all ] + bi ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -225,7 +242,7 @@ M: quit handle-incoming-irc ( quit -- ) M: names-reply handle-incoming-irc ( names-reply -- ) [ names-reply>participants ] [ channel>> listener> ] bi [ [ (>>participants) ] - [ [ f f ] dip name>> to-listener ] bi + [ [ f f f ] dip name>> to-listener ] bi ] [ drop ] if* ; M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) From d46b5387d506941bb3254098ead070a73e33f3a2 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Sat, 9 Aug 2008 22:33:58 -0400 Subject: [PATCH 3/4] backtrack: Added cut-amb --- extra/backtrack/backtrack.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 3c1a794121..db2c50173c 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -66,3 +66,5 @@ MACRO: amb-execute ( seq -- quot ) tri* if ] with-scope ; inline +: cut-amb ( -- ) + f failure set ; From 1ef85fe1bc373996729f1287a041206566cbfcf4 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Mon, 11 Aug 2008 01:22:26 -0400 Subject: [PATCH 4/4] irc.ui: Various added features --- extra/irc/ui/commands/commands.factor | 11 +++- extra/irc/ui/ui.factor | 72 ++++++++++++++++----------- extra/ui/gadgets/tabs/tabs.factor | 5 +- 3 files changed, 56 insertions(+), 32 deletions(-) diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor index 59f4526d23..ddae783f06 100755 --- a/extra/irc/ui/commands/commands.factor +++ b/extra/irc/ui/commands/commands.factor @@ -6,8 +6,15 @@ USING: accessors kernel irc.client irc.messages irc.ui namespaces ; IN: irc.ui.commands : say ( string -- ) - [ client get profile>> nickname>> print-irc ] - [ listener get write-message ] bi ; + irc-tab get + [ window>> client>> profile>> nickname>> print-irc ] + [ listener>> write-message ] 2bi ; + +: join ( string -- ) + irc-tab get window>> join-channel ; + +: query ( string -- ) + irc-tab get window>> query-nick ; : quote ( string -- ) drop ; ! THIS WILL CHANGE diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index a524168d54..4757e36660 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -19,9 +19,9 @@ SYMBOL: listener SYMBOL: client -TUPLE: ui-window client tabs ; +TUPLE: ui-window < tabbed client ; -TUPLE: irc-tab < frame listener client userlist ; +TUPLE: irc-tab < frame listener client window userlist ; : write-color ( str color -- ) foreground associate format ; @@ -161,44 +161,54 @@ M: object handle-inbox [ swap display ] 2keep ; -TUPLE: irc-editor < editor outstream listener client ; +TUPLE: irc-editor < editor outstream tab ; : ( tab pane -- tab editor ) - over irc-editor new-editor - swap listener>> >>listener swap >>outstream - over client>> >>client ; + irc-editor new-editor + swap >>outstream ; : editor-send ( irc-editor -- ) { [ outstream>> ] - [ listener>> ] - [ client>> ] + [ [ irc-tab? ] find-parent ] [ editor-string ] [ "" swap set-editor-string ] } cleave - '[ , listener set , client set , parse-message ] with-output-stream ; + '[ , irc-tab set , parse-message ] with-output-stream ; irc-editor "general" f { { T{ key-down f f "RET" } editor-send } { T{ key-down f f "ENTER" } editor-send } } define-command-map -: ( listener client -- irc-tab ) - irc-tab new-frame - swap client>> >>client swap >>listener +: new-irc-tab ( listener ui-window class -- irc-tab ) + new-frame + swap >>window + swap >>listener [ @center grid-add ] keep @bottom grid-add ; -: ( listener client -- irc-tab ) - - [ @right grid-add ] keep >>userlist ; - -: ( listener client -- irc-tab ) - ; - M: irc-tab graft* - [ listener>> ] [ client>> ] bi add-listener ; + [ listener>> ] [ window>> client>> ] bi add-listener ; M: irc-tab ungraft* - [ listener>> ] [ client>> ] bi remove-listener ; + [ listener>> ] [ window>> client>> ] bi remove-listener ; + +TUPLE: irc-channel-tab < irc-tab userlist ; + +: ( listener ui-window -- irc-tab ) + irc-tab new-irc-tab + [ @right grid-add ] keep >>userlist ; + +TUPLE: irc-server-tab < irc-tab ; + +: ( listener -- irc-tab ) + f irc-server-tab new-irc-tab ; + +M: irc-server-tab ungraft* + [ window>> client>> terminate-irc ] + [ listener>> ] [ window>> client>> ] tri remove-listener ; + +: ( listener ui-window -- irc-tab ) + irc-tab new-irc-tab ; M: irc-tab pref-dim* drop { 480 480 } ; @@ -206,19 +216,25 @@ M: irc-tab pref-dim* : join-channel ( name ui-window -- ) [ dup ] dip [ swap ] keep - tabs>> add-page ; + add-page ; + +: query-nick ( nick ui-window -- ) + [ dup ] dip + [ swap ] keep + add-page ; : irc-window ( ui-window -- ) - [ tabs>> ] + [ ] [ client>> profile>> server>> ] bi open-window ; : ui-connect ( profile -- ui-window ) - ui-window new over >>client swap - [ connect-irc ] - [ [ ] dip add-listener ] - [ listeners>> +server-listener+ swap at over - "Server" associate >>tabs ] tri ; + + { [ [ ] dip add-listener ] + [ listeners>> +server-listener+ swap at dup + "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ] + [ >>client ] + [ connect-irc ] } cleave ; : server-open ( server port nick password channels -- ) [ ui-connect [ irc-window ] keep ] dip diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor index 12031e5911..50e2df2e9e 100755 --- a/extra/ui/gadgets/tabs/tabs.factor +++ b/extra/ui/gadgets/tabs/tabs.factor @@ -48,8 +48,8 @@ DEFER: (del-page) : del-page ( name tabbed -- ) [ names>> index ] 2keep (del-page) ; -: ( assoc -- tabbed ) - tabbed new-frame +: new-tabbed ( assoc class -- tabbed ) + new-frame 0 >>model 1 >>fill >>toggler dup toggler>> @left grid-add @@ -59,3 +59,4 @@ DEFER: (del-page) bi dup redo-toggler ; +: ( assoc -- tabbed ) tabbed new-tabbed ;