steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorforge.org/git/william42

db4
Slava Pestov 2008-08-11 01:40:35 -05:00
parent b411d896a4 1ef85fe1bc
commit 58a40025f4
6 changed files with 253 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/ui/gadgets/tabs/tabs.factor
View File

@ -48,8 +48,8 @@ DEFER: (del-page)
: del-page ( name tabbed -- ) : del-page ( name tabbed -- )
[ names>> index ] 2keep (del-page) ; [ names>> index ] 2keep (del-page) ;
: <tabbed> ( assoc -- tabbed ) : new-tabbed ( assoc class -- tabbed )
tabbed new-frame new-frame
0 <model> >>model 0 <model> >>model
<pile> 1 >>fill >>toggler <pile> 1 >>fill >>toggler
dup toggler>> @left grid-add dup toggler>> @left grid-add
@ -59,3 +59,4 @@ DEFER: (del-page)
bi bi
dup redo-toggler ; dup redo-toggler ;
: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;

2
extra/backtrack/backtrack.factor
View File

@ -66,3 +66,5 @@ MACRO: amb-execute ( seq -- quot )
tri* if tri* if
] with-scope ; inline ] with-scope ; inline
: cut-amb ( -- )
f failure set ;

312
extra/irc/client/client-tests.factor
View File

@ -1,190 +1,178 @@
USING: kernel tools.test accessors arrays sequences qualified 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 calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes assocs combinators ; concurrency.mailboxes classes assocs combinators ;
EXCLUDE: irc.messages => join ; EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_ RENAME: join irc.messages => join_
IN: irc.client.tests IN: irc.client.tests
! Utilities ! Streams for testing
: <test-stream> ( lines -- stream ) TUPLE: mb-writer lines last-line disposed ;
"\n" join <string-reader> <string-writer> <duplex-stream> ; TUPLE: mb-reader lines disposed ;
: <mb-writer> ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ;
: <mb-reader> ( -- mb-reader ) <mailbox> f mb-reader boa ;
: push-line ( line test-reader-stream -- ) lines>> mailbox-put ;
: <test-stream> ( -- stream ) <mb-reader> <mb-writer> <duplex-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 ) : spawn-client ( lines listeners -- irc-client )
"someserver" irc-port "factorbot" f <irc-profile> <irc-client> "someserver" irc-port "factorbot" f <irc-profile>
swap [ 2nip <test-stream> f ] curry >>connect ; <irc-client>
t >>is-running
<test-stream> >>stream
dup [ spawn-irc yield ] with-irc-client ;
: set-nick ( irc-client nickname -- ) ! to be used inside with-irc-client quotations
swap profile>> (>>nickname) ; : %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ;
: %join ( channel -- ) <irc-channel-listener> irc> add-listener ;
: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
: with-dummy-client ( irc-client quot -- ) : read-matching-message ( listener quot: ( msg -- ? ) -- irc-message )
[ current-irc-client ] dip with-variable ; inline [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
{ "" } make-client dup "factorbot" set-nick [ : with-irc ( quot: ( -- ) -- )
{ t } [ irc> profile>> nickname>> me? ] unit-test [ 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" { "factorbot" } [ irc> profile>> nickname>> ] unit-test
parse-irc-line irc-message-origin ] unit-test
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
parse-irc-line irc-message-origin ] unit-test
] with-dummy-client { "#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 ! Test login and nickname set
{ "factorbot" } [ [ { "factorbot2" } [
{ "NOTICE AUTH :*** Looking up your hostname..." ":some.where 001 factorbot2 :Welcome factorbot2" %push-line
"NOTICE AUTH :*** Checking ident" irc> profile>> nickname>>
"NOTICE AUTH :*** Found your hostname" ] unit-test
"NOTICE AUTH :*** No identd (auth) response" ] with-irc
":some.where 001 factorbot :Welcome factorbot"
} make-client
{ [ connect-irc ]
[ drop 0.1 seconds sleep ]
[ profile>> nickname>> ]
[ terminate-irc ]
} cleave ] unit-test
{ join_ "#factortest" } [ [ { 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 353 factorbot @ #factortest :@factorbot " ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 366 factorbot #factortest :End of /NAMES list." ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" } [ %push-line ] each
} make-client irc> join-messages>> 0.1 seconds mailbox-get-timeout
{ [ "factorbot" set-nick ] [ class ] [ trailing>> ] bi
[ connect-irc ] ] unit-test
[ drop 0.1 seconds sleep ] ] with-irc
[ join-messages>> 0.1 seconds mailbox-get-timeout ]
[ terminate-irc ]
} cleave
[ class ] [ trailing>> ] bi ] unit-test
{ +join+ "somebody" } [ [ { T{ participant-changed f "somebody" +join+ } } [
{ ":somebody!n=somebody@some.where JOIN :#factortest" } make-client "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
{ [ "factorbot" set-nick ] ":somebody!n=somebody@some.where JOIN :#factortest" %push-line
[ listeners>> [ participant-changed? ] read-matching-message
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ] ] unit-test
[ connect-irc ] ] with-irc
[ listeners>> [ "#factortest" ] dip at
[ read-message drop ] [ read-message drop ] [ read-message ] tri ]
[ terminate-irc ]
} cleave
[ action>> ] [ nick>> ] bi
] unit-test
{ privmsg "#factortest" "hello" } [ [ { privmsg "#factortest" "hello" } [
{ ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
{ [ "factorbot" set-nick ] ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
[ listeners>> [ privmsg? ] read-matching-message
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ] [ class ] [ name>> ] [ trailing>> ] tri
[ connect-irc ] ] unit-test
[ listeners>> [ "#factortest" ] dip at ] with-irc
[ read-message drop ] [ read-message ] bi ]
[ terminate-irc ]
} cleave
[ class ] [ name>> ] [ trailing>> ] tri
] unit-test
{ privmsg "factorbot" "hello" } [ [ { privmsg "factorbot" "hello" } [
{ ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client "somedude" <irc-nick-listener> [ %add-named-listener ] keep
{ [ "factorbot" set-nick ] ":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line
[ listeners>> [ privmsg? ] read-matching-message
[ "somedude" [ <irc-nick-listener> ] keep ] dip set-at ] [ class ] [ name>> ] [ trailing>> ] tri
[ connect-irc ] ] unit-test
[ listeners>> [ "somedude" ] dip at ] with-irc
[ read-message drop ] [ read-message ] bi ]
[ terminate-irc ]
} cleave
[ class ] [ name>> ] [ trailing>> ] tri
] unit-test
! Participants lists tests [ { mode } [
{ H{ { "somedude" +normal+ } } } [ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
{ ":somedude!n=user@isp.net JOIN :#factortest" } make-client ":ircserver.net MODE #factortest +ns" %push-line
{ [ "factorbot" set-nick ] [ mode? ] read-matching-message class
[ listeners>> ] unit-test
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ] ] with-irc
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [ ! Participant lists tests
{ ":somedude!n=user@isp.net PART #factortest" } make-client [ { H{ { "somedude" +normal+ } } } [
{ [ "factorbot" set-nick ] "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
[ listeners>> ":somedude!n=user@isp.net JOIN :#factortest" %push-line
[ "#factortest" [ <irc-channel-listener> participants>>
H{ { "somedude2" +normal+ } ] unit-test
{ "somedude" +normal+ } } clone >>participants ] keep ] with-irc
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [ [ { H{ { "somedude2" +normal+ } } } [
{ ":somedude!n=user@isp.net QUIT" } make-client "#factortest" <irc-channel-listener>
{ [ "factorbot" set-nick ] H{ { "somedude2" +normal+ }
[ listeners>> { "somedude" +normal+ } } clone >>participants
[ "#factortest" [ <irc-channel-listener> [ %add-named-listener ] keep
H{ { "somedude2" +normal+ } ":somedude!n=user@isp.net PART #factortest" %push-line
{ "somedude" +normal+ } } clone >>participants ] keep participants>>
] dip set-at ] ] unit-test
[ connect-irc ] ] with-irc
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [ [ { H{ { "somedude2" +normal+ } } } [
{ ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client "#factortest" <irc-channel-listener>
{ [ "factorbot" set-nick ] H{ { "somedude2" +normal+ }
[ listeners>> { "somedude" +normal+ } } clone >>participants
[ "#factortest" [ <irc-channel-listener> [ %add-named-listener ] keep
H{ { "somedude2" +normal+ } ":somedude!n=user@isp.net QUIT" %push-line
{ "somedude" +normal+ } } clone >>participants ] keep participants>>
] dip set-at ] ] unit-test
[ connect-irc ] ] with-irc
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ] [ { H{ { "somedude2" +normal+ } } } [
[ terminate-irc ] "#factortest" <irc-channel-listener>
} cleave H{ { "somedude2" +normal+ }
] unit-test { "somedude" +normal+ } } clone >>participants
[ %add-named-listener ] keep
":somedude2!n=user2@isp.net KICK #factortest somedude" %push-line
participants>>
] unit-test
] with-irc
[ { H{ { "somedude2" +normal+ } } } [
"#factortest" <irc-channel-listener>
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 ! Namelist change notification
{ T{ participant-changed f f f } } [ [ { T{ participant-changed f f f f } } [
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot " "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
{ [ "factorbot" set-nick ] ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
[ listeners>> [ participant-changed? ] read-matching-message
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ] ] unit-test
[ connect-irc ] ] with-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 "somedude" +part+ } } [ [ { T{ participant-changed f "somedude" +part+ f } } [
{ ":somedude!n=user@isp.net QUIT" } make-client "#factortest" <irc-channel-listener>
{ [ "factorbot" set-nick ] H{ { "somedude" +normal+ } } clone >>participants
[ listeners>> [ %add-named-listener ] keep
[ "#factortest" [ <irc-channel-listener> ":somedude!n=user@isp.net QUIT" %push-line
H{ { "somedude" +normal+ } } clone >>participants ] keep [ participant-changed? ] read-matching-message
] dip set-at ] ] unit-test
[ connect-irc ] ] with-irc
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at [ { T{ participant-changed f "somedude" +nick+ "somedude2" } } [
[ read-message drop ] [ read-message drop ] [ read-message ] tri ] "#factortest" <irc-channel-listener>
[ terminate-irc ] H{ { "somedude" +normal+ } } clone >>participants
} cleave [ %add-named-listener ] keep
] unit-test ":somedude!n=user2@isp.net NICK :somedude2" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc

89
extra/irc/client/client.factor
View File

@ -41,6 +41,7 @@ SYMBOL: +normal+
SYMBOL: +join+ SYMBOL: +join+
SYMBOL: +part+ SYMBOL: +part+
SYMBOL: +mode+ SYMBOL: +mode+
SYMBOL: +nick+
! listener objects ! listener objects
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ; : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
@ -59,7 +60,7 @@ SYMBOL: +mode+
! Message objects ! Message objects
! ====================================== ! ======================================
TUPLE: participant-changed nick action ; TUPLE: participant-changed nick action parameter ;
C: <participant-changed> participant-changed C: <participant-changed> participant-changed
SINGLETON: irc-listener-end ! send to a listener to stop its execution SINGLETON: irc-listener-end ! send to a listener to stop its execution
@ -100,17 +101,21 @@ M: string to-listener ( message string -- )
listener> [ +server-listener+ listener> ] unless* listener> [ +server-listener+ listener> ] unless*
[ to-listener ] [ drop ] if* ; [ to-listener ] [ drop ] if* ;
M: irc-listener to-listener ( message irc-listener -- )
in-messages>> mailbox-put ;
: unregister-listener ( name -- ) : unregister-listener ( name -- )
irc> listeners>> irc> listeners>>
[ at [ irc-listener-end ] dip to-listener ] [ at [ irc-listener-end ] dip to-listener ]
[ delete-at ] [ delete-at ]
2bi ; 2bi ;
M: irc-listener to-listener ( message irc-listener -- ) : (remove-participant) ( nick listener -- )
in-messages>> mailbox-put ; [ participants>> delete-at ]
[ [ +part+ f <participant-changed> ] dip to-listener ] 2bi ;
: remove-participant ( nick channel -- ) : remove-participant ( nick channel -- )
listener> [ participants>> delete-at ] [ drop ] if* ; listener> [ (remove-participant) ] [ drop ] if* ;
: listeners-with-participant ( nick -- seq ) : listeners-with-participant ( nick -- seq )
irc> listeners>> values irc> listeners>> values
@ -118,10 +123,24 @@ M: irc-listener to-listener ( message irc-listener -- )
with filter ; with filter ;
: remove-participant-from-all ( nick -- ) : remove-participant-from-all ( nick -- )
dup listeners-with-participant [ participants>> delete-at ] with each ; 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 -- ) : add-participant ( mode nick channel -- )
listener> [ participants>> set-at ] [ 2drop ] if* ; listener> [
[ participants>> set-at ]
[ [ +join+ f <participant-changed> ] dip to-listener ] 2bi
] [ 2drop ] if* ;
DEFER: me? DEFER: me?
@ -164,25 +183,6 @@ DEFER: me?
: broadcast-message-to-listeners ( message -- ) : broadcast-message-to-listeners ( message -- )
irc> listeners>> values [ to-listener ] 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+ <participant-changed> ]
[ trailing>> ] bi to-listener ;
M: part handle-participant-change ( part -- )
[ prefix>> parse-name +part+ <participant-changed> ]
[ channel>> ] bi to-listener ;
M: kick handle-participant-change ( kick -- )
[ who>> +part+ <participant-changed> ]
[ channel>> ] bi to-listener ;
M: quit handle-participant-change ( quit -- )
prefix>> parse-name
[ +part+ <participant-changed> ] [ listeners-with-participant ] bi
[ to-listener ] with each ;
GENERIC: handle-incoming-irc ( irc-message -- ) GENERIC: handle-incoming-irc ( irc-message -- )
M: irc-message handle-incoming-irc ( irc-message -- ) M: irc-message handle-incoming-irc ( irc-message -- )
@ -201,35 +201,36 @@ M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin to-listener ; dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- ) M: join handle-incoming-irc ( join -- )
{ [ maybe-forward-join ] [ maybe-forward-join ]
[ dup trailing>> to-listener ] [ dup trailing>> to-listener ]
[ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
[ handle-participant-change ] tri ;
} cleave ;
M: part handle-incoming-irc ( part -- ) M: part handle-incoming-irc ( part -- )
[ dup channel>> to-listener ] [ dup channel>> to-listener ]
[ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ] [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
[ handle-participant-change ] bi ;
tri ;
M: kick handle-incoming-irc ( kick -- ) M: kick handle-incoming-irc ( kick -- )
{ [ dup channel>> to-listener ] [ dup channel>> to-listener ]
[ [ who>> ] [ channel>> ] bi remove-participant ] [ [ who>> ] [ channel>> ] bi remove-participant ]
[ handle-participant-change ] [ dup who>> me? [ unregister-listener ] [ drop ] if ]
[ dup who>> me? [ unregister-listener ] [ drop ] if ] tri ;
} cleave ;
M: quit handle-incoming-irc ( quit -- ) M: quit handle-incoming-irc ( quit -- )
[ dup prefix>> parse-name listeners-with-participant [ dup prefix>> parse-name listeners-with-participant
[ to-listener ] with each ] [ to-listener ] with each ]
[ handle-participant-change ]
[ prefix>> parse-name remove-participant-from-all ] [ prefix>> parse-name remove-participant-from-all ]
tri ; bi ;
! FIXME: implement this M: mode handle-incoming-irc ( mode -- ) ! FIXME: modify participant list
! M: mode handle-incoming-irc ( mode -- ) call-next-method ; dup channel>> to-listener ;
! M: nick handle-incoming-irc ( nick -- ) call-next-method ;
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 ) : >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@ -241,7 +242,7 @@ M: quit handle-incoming-irc ( quit -- )
M: names-reply handle-incoming-irc ( names-reply -- ) M: names-reply handle-incoming-irc ( names-reply -- )
[ names-reply>participants ] [ channel>> listener> ] bi [ [ names-reply>participants ] [ channel>> listener> ] bi [
[ (>>participants) ] [ (>>participants) ]
[ [ f f <participant-changed> ] dip name>> to-listener ] bi [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
] [ drop ] if* ; ] [ drop ] if* ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
@ -367,7 +368,7 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
in-messages>> [ irc-connected ] dip mailbox-put ; in-messages>> [ irc-connected ] dip mailbox-put ;
: with-irc-client ( irc-client quot: ( -- ) -- ) : with-irc-client ( irc-client quot: ( -- ) -- )
[ current-irc-client ] dip with-variable ; inline [ \ current-irc-client ] dip with-variable ; inline
PRIVATE> PRIVATE>

11
extra/irc/ui/commands/commands.factor
View File

@ -6,8 +6,15 @@ USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
IN: irc.ui.commands IN: irc.ui.commands
: say ( string -- ) : say ( string -- )
[ client get profile>> nickname>> <own-message> print-irc ] irc-tab get
[ listener get write-message ] bi ; [ window>> client>> profile>> nickname>> <own-message> print-irc ]
[ listener>> write-message ] 2bi ;
: join ( string -- )
irc-tab get window>> join-channel ;
: query ( string -- )
irc-tab get window>> query-nick ;
: quote ( string -- ) : quote ( string -- )
drop ; ! THIS WILL CHANGE drop ; ! THIS WILL CHANGE

72
extra/irc/ui/ui.factor
View File

@ -19,9 +19,9 @@ SYMBOL: listener
SYMBOL: client 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 -- ) : write-color ( str color -- )
foreground associate format ; foreground associate format ;
@ -161,44 +161,54 @@ M: object handle-inbox
<scrolling-pane> <scrolling-pane>
[ <pane-stream> swap display ] 2keep ; [ <pane-stream> swap display ] 2keep ;
TUPLE: irc-editor < editor outstream listener client ; TUPLE: irc-editor < editor outstream tab ;
: <irc-editor> ( tab pane -- tab editor ) : <irc-editor> ( tab pane -- tab editor )
over irc-editor new-editor irc-editor new-editor
swap listener>> >>listener swap <pane-stream> >>outstream swap <pane-stream> >>outstream ;
over client>> >>client ;
: editor-send ( irc-editor -- ) : editor-send ( irc-editor -- )
{ [ outstream>> ] { [ outstream>> ]
[ listener>> ] [ [ irc-tab? ] find-parent ]
[ client>> ]
[ editor-string ] [ editor-string ]
[ "" swap set-editor-string ] } cleave [ "" 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 { irc-editor "general" f {
{ T{ key-down f f "RET" } editor-send } { T{ key-down f f "RET" } editor-send }
{ T{ key-down f f "ENTER" } editor-send } { T{ key-down f f "ENTER" } editor-send }
} define-command-map } define-command-map
: <irc-tab> ( listener client -- irc-tab ) : new-irc-tab ( listener ui-window class -- irc-tab )
irc-tab new-frame new-frame
swap client>> >>client swap >>listener swap >>window
swap >>listener
<irc-pane> [ <scroller> @center grid-add ] keep <irc-pane> [ <scroller> @center grid-add ] keep
<irc-editor> <scroller> @bottom grid-add ; <irc-editor> <scroller> @bottom grid-add ;
: <irc-channel-tab> ( listener client -- irc-tab )
<irc-tab>
<pile> [ <scroller> @right grid-add ] keep >>userlist ;
: <irc-server-tab> ( listener client -- irc-tab )
<irc-tab> ;
M: irc-tab graft* M: irc-tab graft*
[ listener>> ] [ client>> ] bi add-listener ; [ listener>> ] [ window>> client>> ] bi add-listener ;
M: irc-tab ungraft* M: irc-tab ungraft*
[ listener>> ] [ client>> ] bi remove-listener ; [ listener>> ] [ window>> client>> ] bi remove-listener ;
TUPLE: irc-channel-tab < irc-tab userlist ;
: <irc-channel-tab> ( listener ui-window -- irc-tab )
irc-tab new-irc-tab
<pile> [ <scroller> @right grid-add ] keep >>userlist ;
TUPLE: irc-server-tab < irc-tab ;
: <irc-server-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 ;
: <irc-nick-tab> ( listener ui-window -- irc-tab )
irc-tab new-irc-tab ;
M: irc-tab pref-dim* M: irc-tab pref-dim*
drop { 480 480 } ; drop { 480 480 } ;
@ -206,19 +216,25 @@ M: irc-tab pref-dim*
: join-channel ( name ui-window -- ) : join-channel ( name ui-window -- )
[ dup <irc-channel-listener> ] dip [ dup <irc-channel-listener> ] dip
[ <irc-channel-tab> swap ] keep [ <irc-channel-tab> swap ] keep
tabs>> add-page ; add-page ;
: query-nick ( nick ui-window -- )
[ dup <irc-nick-listener> ] dip
[ <irc-nick-tab> swap ] keep
add-page ;
: irc-window ( ui-window -- ) : irc-window ( ui-window -- )
[ tabs>> ] [ ]
[ client>> profile>> server>> ] bi [ client>> profile>> server>> ] bi
open-window ; open-window ;
: ui-connect ( profile -- ui-window ) : ui-connect ( profile -- ui-window )
<irc-client> ui-window new over >>client swap <irc-client>
[ connect-irc ] { [ [ <irc-server-listener> ] dip add-listener ]
[ [ <irc-server-listener> ] dip add-listener ] [ listeners>> +server-listener+ swap at <irc-server-tab> dup
[ listeners>> +server-listener+ swap at over <irc-tab> "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]
"Server" associate <tabbed> >>tabs ] tri ; [ >>client ]
[ connect-irc ] } cleave ;
: server-open ( server port nick password channels -- ) : server-open ( server port nick password channels -- )
[ <irc-profile> ui-connect [ irc-window ] keep ] dip [ <irc-profile> ui-connect [ irc-window ] keep ] dip