Merge branch 'master' of git://factorforge.org/git/william42
Slava Pestov
commit
9e504087c7
|
|
@ -0,0 +1 @@
|
|||
William Schlieper
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel continuations sequences namespaces fry ;
|
||||
|
||||
IN: backtrack
|
||||
|
||||
SYMBOL: failure
|
||||
|
||||
: amb ( seq -- elt )
|
||||
failure get
|
||||
'[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each
|
||||
, continue ] callcc1 ;
|
||||
|
||||
: fail ( -- )
|
||||
f amb drop ;
|
||||
|
||||
: require ( ? -- )
|
||||
[ fail ] unless ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Simple non-determinism
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax quotations kernel ;
|
||||
USING: help.markup help.syntax quotations kernel irc.messages ;
|
||||
IN: irc.client
|
||||
|
||||
HELP: irc-client "IRC Client object"
|
||||
|
|
@ -21,13 +21,25 @@ HELP: connect-irc "Connecting to an irc server"
|
|||
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
|
||||
|
||||
HELP: add-listener "Listening to irc channels/users/etc"
|
||||
{ $values { "irc-client" "an irc client object" } { "irc-listener" "an irc listener object" } }
|
||||
{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } }
|
||||
{ $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ;
|
||||
|
||||
HELP: remove-listener "Stop an unregister listener"
|
||||
{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } }
|
||||
{ $description "Unregisters " { $snippet "irc-listener" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ;
|
||||
|
||||
HELP: terminate-irc "Terminates an irc client"
|
||||
{ $values { "irc-client" "an irc client object" } }
|
||||
{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying listeners." } ;
|
||||
|
||||
HELP: write-message "Sends a message through a listener"
|
||||
{ $values { "message" "a string or irc message object" } { "irc-listener" "an irc listener object" } }
|
||||
{ $description "Sends " { $snippet "message" } " through " { $snippet "irc-listener" } ". Strings are automatically promoted to privmsg objects." } ;
|
||||
|
||||
HELP: read-message "Reads a message from a listener"
|
||||
{ $values { "irc-listener" "an irc listener object" } { "message" "an irc message object" } }
|
||||
{ $description "Reads " { $snippet "message" } " from " { $snippet "irc-listener" } "." } ;
|
||||
|
||||
ARTICLE: "irc.client" "IRC Client"
|
||||
"An IRC Client library"
|
||||
{ $heading "IRC objects:" }
|
||||
|
|
@ -42,6 +54,9 @@ ARTICLE: "irc.client" "IRC Client"
|
|||
{ $subsection connect-irc }
|
||||
{ $subsection terminate-irc }
|
||||
{ $subsection add-listener }
|
||||
{ $subsection remove-listener }
|
||||
{ $subsection read-message }
|
||||
{ $subsection write-message }
|
||||
{ $heading "IRC messages" }
|
||||
"Some of the RFC defined irc messages as objects:"
|
||||
{ $table
|
||||
|
|
@ -78,11 +93,11 @@ ARTICLE: "irc.client" "IRC Client"
|
|||
"! Create a channel listener"
|
||||
"\"#mychannel123\" <irc-channel-listener> mychannel set"
|
||||
"! Register and start listener (this joins the channel)"
|
||||
"bot get mychannel get add-listener"
|
||||
"mychannel get bot get add-listener"
|
||||
"! Send a message to the channel"
|
||||
"\"what's up?\" mychannel get out-messages>> mailbox-put"
|
||||
"\"what's up?\" mychannel get write-message"
|
||||
"! Read a message from the channel"
|
||||
"mychannel get in-messages>> mailbox-get"
|
||||
"mychannel get read-message"
|
||||
}
|
||||
;
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: irc.client.tests
|
|||
swap [ 2nip <test-stream> f ] curry >>connect ;
|
||||
|
||||
: set-nick ( irc-client nickname -- )
|
||||
[ nick>> ] dip >>name drop ;
|
||||
swap profile>> (>>nickname) ;
|
||||
|
||||
: with-dummy-client ( quot -- )
|
||||
rot with-variable ; inline
|
||||
|
|
@ -42,9 +42,9 @@ privmsg new
|
|||
parse-irc-line f >>timestamp ] unit-test
|
||||
|
||||
{ "" } make-client dup "factorbot" set-nick current-irc-client [
|
||||
{ t } [ irc> nick>> name>> me? ] unit-test
|
||||
{ t } [ irc> profile>> nickname>> me? ] unit-test
|
||||
|
||||
{ "factorbot" } [ irc> nick>> name>> ] unit-test
|
||||
{ "factorbot" } [ irc> profile>> nickname>> ] unit-test
|
||||
|
||||
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
|
||||
|
||||
|
|
@ -63,7 +63,7 @@ privmsg new
|
|||
":some.where 001 factorbot :Welcome factorbot"
|
||||
} make-client
|
||||
[ connect-irc ] keep 1 seconds sleep
|
||||
nick>> name>> ] unit-test
|
||||
profile>> nickname>> ] unit-test
|
||||
|
||||
{ join_ "#factortest" } [
|
||||
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators concurrency.mailboxes fry io strings
|
||||
io.encodings.8-bit io.sockets kernel namespaces sequences
|
||||
splitting threads calendar classes.tuple
|
||||
classes ascii assocs accessors destructors continuations ;
|
||||
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 ;
|
||||
RENAME: join sequences => sjoin
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.client
|
||||
|
||||
! ======================================
|
||||
|
|
@ -14,18 +16,12 @@ SYMBOL: current-irc-client
|
|||
|
||||
: irc-port 6667 ; ! Default irc port
|
||||
|
||||
! "setup" objects
|
||||
TUPLE: irc-profile server port nickname password ;
|
||||
C: <irc-profile> irc-profile
|
||||
|
||||
! "live" objects
|
||||
TUPLE: nick name channels log ;
|
||||
C: <nick> nick
|
||||
|
||||
TUPLE: irc-client profile nick stream in-messages out-messages join-messages
|
||||
TUPLE: irc-client profile stream in-messages out-messages join-messages
|
||||
listeners is-running connect reconnect-time ;
|
||||
: <irc-client> ( profile -- irc-client )
|
||||
f V{ } clone V{ } clone <nick>
|
||||
f <mailbox> <mailbox> <mailbox> H{ } clone f
|
||||
[ <inet> latin1 <client> ] 15 seconds irc-client boa ;
|
||||
|
||||
|
|
@ -33,6 +29,7 @@ TUPLE: irc-listener in-messages out-messages ;
|
|||
TUPLE: irc-server-listener < irc-listener ;
|
||||
TUPLE: irc-channel-listener < irc-listener name password timeout ;
|
||||
TUPLE: irc-nick-listener < irc-listener name ;
|
||||
SYMBOL: +server-listener+
|
||||
|
||||
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
|
||||
|
||||
|
|
@ -54,20 +51,6 @@ SINGLETON: irc-disconnected ! sent when connection is lost
|
|||
SINGLETON: irc-connected ! sent when connection is established
|
||||
UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
|
||||
|
||||
TUPLE: irc-message line prefix command parameters trailing timestamp ;
|
||||
TUPLE: logged-in < irc-message name ;
|
||||
TUPLE: ping < irc-message ;
|
||||
TUPLE: join < irc-message ;
|
||||
TUPLE: part < irc-message name channel ;
|
||||
TUPLE: quit < irc-message ;
|
||||
TUPLE: privmsg < irc-message name ;
|
||||
TUPLE: kick < irc-message channel who ;
|
||||
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: unhandled < irc-message ;
|
||||
|
||||
: terminate-irc ( irc-client -- )
|
||||
[ in-messages>> irc-end swap mailbox-put ]
|
||||
[ f >>is-running drop ]
|
||||
|
|
@ -88,13 +71,21 @@ TUPLE: unhandled < irc-message ;
|
|||
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
|
||||
|
||||
: to-listener ( message name -- )
|
||||
listener> [ f listener> ] unless*
|
||||
listener> [ +server-listener+ listener> ] unless*
|
||||
[ in-messages>> mailbox-put ] [ drop ] if* ;
|
||||
|
||||
! ======================================
|
||||
! 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 ;
|
||||
|
||||
|
|
@ -131,58 +122,12 @@ TUPLE: unhandled < irc-message ;
|
|||
: /PONG ( text -- )
|
||||
"PONG " irc-write irc-print ;
|
||||
|
||||
! ======================================
|
||||
! Message parsing
|
||||
! ======================================
|
||||
|
||||
: split-at-first ( seq separators -- before after )
|
||||
dupd '[ , member? ] find
|
||||
[ cut 1 tail ]
|
||||
[ swap ]
|
||||
if ;
|
||||
|
||||
: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
|
||||
|
||||
: parse-name ( string -- string )
|
||||
remove-heading-: "!" split-at-first drop ;
|
||||
|
||||
: split-prefix ( string -- string/f string )
|
||||
dup ":" head?
|
||||
[ remove-heading-: " " split1 ]
|
||||
[ f swap ]
|
||||
if ;
|
||||
|
||||
: split-trailing ( string -- string string/f )
|
||||
":" split1 ;
|
||||
|
||||
: string>irc-message ( string -- object )
|
||||
dup split-prefix split-trailing
|
||||
[ [ blank? ] trim " " split unclip swap ] dip
|
||||
now irc-message boa ;
|
||||
|
||||
: parse-irc-line ( string -- message )
|
||||
string>irc-message
|
||||
dup command>> {
|
||||
{ "PING" [ \ ping ] }
|
||||
{ "NOTICE" [ \ notice ] }
|
||||
{ "001" [ \ logged-in ] }
|
||||
{ "433" [ \ nick-in-use ] }
|
||||
{ "JOIN" [ \ join ] }
|
||||
{ "PART" [ \ part ] }
|
||||
{ "PRIVMSG" [ \ privmsg ] }
|
||||
{ "QUIT" [ \ quit ] }
|
||||
{ "MODE" [ \ mode ] }
|
||||
{ "KICK" [ \ kick ] }
|
||||
[ drop \ unhandled ]
|
||||
} case
|
||||
[ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
|
||||
|
||||
! ======================================
|
||||
! Server message handling
|
||||
! ======================================
|
||||
|
||||
: me? ( string -- ? )
|
||||
irc> nick>> name>> = ;
|
||||
irc> profile>> nickname>> = ;
|
||||
|
||||
: irc-message-origin ( irc-message -- name )
|
||||
dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
|
||||
|
|
@ -193,10 +138,10 @@ TUPLE: unhandled < irc-message ;
|
|||
GENERIC: handle-incoming-irc ( irc-message -- )
|
||||
|
||||
M: irc-message handle-incoming-irc ( irc-message -- )
|
||||
f listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
|
||||
+server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
|
||||
|
||||
M: logged-in handle-incoming-irc ( logged-in -- )
|
||||
name>> irc> nick>> (>>name) ;
|
||||
name>> irc> profile>> (>>nickname) ;
|
||||
|
||||
M: ping handle-incoming-irc ( ping -- )
|
||||
trailing>> /PONG ;
|
||||
|
|
@ -208,8 +153,13 @@ M: privmsg handle-incoming-irc ( privmsg -- )
|
|||
dup irc-message-origin to-listener ;
|
||||
|
||||
M: join handle-incoming-irc ( join -- )
|
||||
dup trailing>> listener>
|
||||
[ irc> join-messages>> ] unless* mailbox-put ;
|
||||
[ [ prefix>> parse-name me? ] keep and
|
||||
[ irc> join-messages>> mailbox-put ] when* ]
|
||||
[ dup trailing>> to-listener ]
|
||||
bi ;
|
||||
|
||||
M: part handle-incoming-irc ( part -- )
|
||||
dup channel>> to-listener ;
|
||||
|
||||
M: kick handle-incoming-irc ( kick -- )
|
||||
[ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when
|
||||
|
|
@ -224,8 +174,14 @@ 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: privmsg handle-outgoing-irc ( privmsg -- )
|
||||
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
|
||||
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
|
||||
|
||||
M: part handle-outgoing-irc ( privmsg -- )
|
||||
[ channel>> ] [ trailing>> "" or ] bi /PART ;
|
||||
|
||||
! ======================================
|
||||
! Reader/Writer
|
||||
|
|
@ -306,6 +262,7 @@ DEFER: (connect-irc)
|
|||
2bi ;
|
||||
|
||||
GENERIC: (add-listener) ( irc-listener -- )
|
||||
|
||||
M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
|
||||
[ [ name>> ] [ password>> ] bi /JOIN ]
|
||||
[ [ [ drop irc> join-messages>> ]
|
||||
|
|
@ -318,7 +275,20 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
|
|||
[ name>> ] keep set+run-listener ;
|
||||
|
||||
M: irc-server-listener (add-listener) ( irc-server-listener -- )
|
||||
f swap set+run-listener ;
|
||||
+server-listener+ swap set+run-listener ;
|
||||
|
||||
GENERIC: (remove-listener) ( irc-listener -- )
|
||||
|
||||
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 swap >>channel mailbox-put ] keep
|
||||
name>> unregister-listener ;
|
||||
|
||||
M: irc-server-listener (remove-listener) ( irc-server-listener -- )
|
||||
drop +server-listener+ unregister-listener ;
|
||||
|
||||
: (connect-irc) ( irc-client -- )
|
||||
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
|
||||
|
|
@ -326,13 +296,22 @@ M: irc-server-listener (add-listener) ( irc-server-listener -- )
|
|||
t >>is-running
|
||||
in-messages>> irc-connected swap mailbox-put ;
|
||||
|
||||
: with-irc-client ( irc-client quot -- )
|
||||
>r current-irc-client r> with-variable ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: connect-irc ( irc-client -- )
|
||||
dup current-irc-client [
|
||||
dup [
|
||||
[ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
|
||||
spawn-irc
|
||||
] with-variable ;
|
||||
] with-irc-client ;
|
||||
|
||||
: add-listener ( irc-listener irc-client -- )
|
||||
current-irc-client rot '[ , (add-listener) ] with-variable ;
|
||||
swap '[ , (add-listener) ] with-irc-client ;
|
||||
|
||||
: remove-listener ( irc-listener irc-client -- )
|
||||
swap '[ , (remove-listener) ] with-irc-client ;
|
||||
|
||||
: write-message ( message irc-listener -- ) out-messages>> mailbox-put ;
|
||||
: read-message ( irc-listener -- message ) in-messages>> mailbox-get ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Bruno Deferrari
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
! 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 ;
|
||||
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: part < irc-message channel ;
|
||||
TUPLE: quit < irc-message ;
|
||||
TUPLE: privmsg < irc-message name ;
|
||||
TUPLE: kick < irc-message channel who ;
|
||||
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: unhandled < irc-message ;
|
||||
|
||||
<PRIVATE
|
||||
! ======================================
|
||||
! Message parsing
|
||||
! ======================================
|
||||
|
||||
: split-at-first ( seq separators -- before after )
|
||||
dupd '[ , member? ] find
|
||||
[ cut 1 tail ]
|
||||
[ swap ]
|
||||
if ;
|
||||
|
||||
: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
|
||||
|
||||
: parse-name ( string -- string )
|
||||
remove-heading-: "!" split-at-first drop ;
|
||||
|
||||
: split-prefix ( string -- string/f string )
|
||||
dup ":" head?
|
||||
[ remove-heading-: " " split1 ]
|
||||
[ f swap ]
|
||||
if ;
|
||||
|
||||
: split-trailing ( string -- string string/f )
|
||||
":" split1 ;
|
||||
|
||||
: string>irc-message ( string -- object )
|
||||
dup split-prefix split-trailing
|
||||
[ [ blank? ] trim " " split unclip swap ] dip
|
||||
now irc-message boa ;
|
||||
|
||||
: parse-irc-line ( string -- message )
|
||||
string>irc-message
|
||||
dup command>> {
|
||||
{ "PING" [ \ ping ] }
|
||||
{ "NOTICE" [ \ notice ] }
|
||||
{ "001" [ \ logged-in ] }
|
||||
{ "433" [ \ nick-in-use ] }
|
||||
{ "JOIN" [ \ join ] }
|
||||
{ "PART" [ \ part ] }
|
||||
{ "PRIVMSG" [ \ privmsg ] }
|
||||
{ "QUIT" [ \ quit ] }
|
||||
{ "MODE" [ \ mode ] }
|
||||
{ "KICK" [ \ kick ] }
|
||||
[ drop \ unhandled ]
|
||||
} case
|
||||
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
|
||||
[ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
@ -0,0 +1 @@
|
|||
William Schlieper
|
||||
|
|
@ -0,0 +1 @@
|
|||
A simple IRC client
|
||||
|
|
@ -0,0 +1,130 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors kernel threads combinators concurrency.mailboxes
|
||||
sequences strings hashtables splitting fry assocs hashtables
|
||||
ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers
|
||||
ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs
|
||||
io io.styles namespaces irc.client irc.messages ;
|
||||
|
||||
IN: irc.ui
|
||||
|
||||
SYMBOL: client
|
||||
|
||||
TUPLE: ui-window client tabs ;
|
||||
|
||||
: write-color ( str color -- )
|
||||
foreground associate format ;
|
||||
: red { 0.5 0 0 1 } ;
|
||||
: green { 0 0.5 0 1 } ;
|
||||
: blue { 0 0 1 1 } ;
|
||||
|
||||
: prefix>nick ( prefix -- nick )
|
||||
"!" split first ;
|
||||
|
||||
GENERIC: write-irc ( irc-message -- )
|
||||
|
||||
M: privmsg write-irc
|
||||
"<" blue write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
">" blue write-color
|
||||
" " write
|
||||
trailing>> write ;
|
||||
|
||||
M: join write-irc
|
||||
"* " green write-color
|
||||
prefix>> prefix>nick write
|
||||
" has entered the channel." green write-color ;
|
||||
|
||||
M: part write-irc
|
||||
"* " red write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
" has left the channel(" red write-color
|
||||
trailing>> write
|
||||
")" red write-color ;
|
||||
|
||||
M: quit write-irc
|
||||
"* " red write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
" has left IRC(" red write-color
|
||||
trailing>> write
|
||||
")" red write-color ;
|
||||
|
||||
M: irc-end write-irc
|
||||
drop "* You have left IRC" red write-color ;
|
||||
|
||||
M: irc-disconnected write-irc
|
||||
drop "* Disconnected" red write-color ;
|
||||
|
||||
M: irc-connected write-irc
|
||||
drop "* Connected" green write-color ;
|
||||
|
||||
M: irc-message write-irc
|
||||
drop ; ! catch all unimplemented writes, THIS WILL CHANGE
|
||||
|
||||
: print-irc ( irc-message -- )
|
||||
write-irc nl ;
|
||||
|
||||
: send-message ( message listener client -- )
|
||||
"<" blue write-color
|
||||
profile>> nickname>> bold font-style associate format
|
||||
">" blue write-color
|
||||
" " write
|
||||
over write nl
|
||||
out-messages>> mailbox-put ;
|
||||
|
||||
: display ( stream listener -- )
|
||||
'[ , [ [ t ]
|
||||
[ , read-message print-irc ]
|
||||
[ ] while ] with-output-stream ] "ircv" spawn drop ;
|
||||
|
||||
: <irc-pane> ( listener -- pane )
|
||||
<scrolling-pane>
|
||||
[ <pane-stream> swap display ] keep ;
|
||||
|
||||
TUPLE: irc-editor outstream listener client ;
|
||||
|
||||
: <irc-editor> ( pane listener client -- editor )
|
||||
[ <editor> irc-editor construct-editor
|
||||
swap >>listener swap <pane-stream> >>outstream
|
||||
] dip client>> >>client ;
|
||||
|
||||
: editor-send ( irc-editor -- )
|
||||
{ [ outstream>> ]
|
||||
[ editor-string ]
|
||||
[ listener>> ]
|
||||
[ client>> ]
|
||||
[ "" swap set-editor-string ] } cleave
|
||||
'[ , , , send-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
|
||||
|
||||
: irc-page ( name pane editor tabbed -- )
|
||||
[ [ <scroller> @bottom frame, ! editor
|
||||
<scroller> @center frame, ! pane
|
||||
] make-frame swap ] dip add-page ;
|
||||
|
||||
: join-channel ( name ui-window -- )
|
||||
[ dup <irc-channel-listener> ] dip
|
||||
[ client>> add-listener ]
|
||||
[ drop <irc-pane> dup ]
|
||||
[ [ <irc-editor> ] keep ] 2tri
|
||||
tabs>> irc-page ;
|
||||
|
||||
: irc-window ( ui-window -- )
|
||||
[ tabs>> ]
|
||||
[ client>> profile>> server>> ] bi
|
||||
open-window ;
|
||||
|
||||
: ui-connect ( profile -- ui-window )
|
||||
<irc-client> ui-window new over >>client swap
|
||||
[ connect-irc ]
|
||||
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>
|
||||
"Server" associate <tabbed> >>tabs ] bi ;
|
||||
|
||||
: freenode-connect ( -- ui-window )
|
||||
"irc.freenode.org" 8001 "factor-irc" f
|
||||
<irc-profile> ui-connect [ irc-window ] keep ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
William Schlieper
|
||||
|
|
@ -0,0 +1 @@
|
|||
Tabbed windows
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors kernel fry math math.vectors sequences arrays vectors assocs
|
||||
hashtables models models.range models.compose combinators
|
||||
ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs
|
||||
ui.gadgets.incremental ui.gadgets.viewports ui.gadgets.books ;
|
||||
|
||||
IN: ui.gadgets.tabs
|
||||
|
||||
TUPLE: tabbed names model toggler content ;
|
||||
|
||||
DEFER: (del-page)
|
||||
|
||||
: add-toggle ( model n name toggler -- )
|
||||
[ [ gadget-parent '[ , , , (del-page) ] "X" swap
|
||||
<bevel-button> @right frame, ] 3keep
|
||||
[ swapd <toggle-button> @center frame, ] dip ] make-frame
|
||||
swap add-gadget ;
|
||||
|
||||
: redo-toggler ( tabbed -- )
|
||||
[ names>> ] [ model>> ] [ toggler>> ] tri
|
||||
[ clear-gadget ] keep
|
||||
[ [ length ] keep ] 2dip
|
||||
'[ , _ _ , add-toggle ] 2each ;
|
||||
|
||||
: (del-page) ( n name tabbed -- )
|
||||
{ [ [ remove ] change-names redo-toggler ]
|
||||
[ [ names>> length ] [ model>> ] bi
|
||||
[ [ = ] keep swap [ 1- ] when
|
||||
[ > ] keep swap [ 1- ] when dup ] change-model ]
|
||||
[ content>> nth-gadget unparent ]
|
||||
[ model>> [ ] change-model ] ! refresh
|
||||
} cleave ;
|
||||
|
||||
: add-page ( page name tabbed -- )
|
||||
[ names>> push ] 2keep
|
||||
[ [ model>> swap ]
|
||||
[ names>> length 1 - swap ]
|
||||
[ toggler>> ] tri add-toggle ]
|
||||
[ content>> add-gadget ] bi ;
|
||||
|
||||
: del-page ( name tabbed -- )
|
||||
[ names>> index ] 2keep (del-page) ;
|
||||
|
||||
: <tabbed> ( assoc -- tabbed )
|
||||
tabbed new
|
||||
[ <pile> 1 >>fill g-> (>>toggler) @left frame,
|
||||
[ keys >vector g (>>names) ]
|
||||
[ values 0 <model> [ <book> g-> (>>content) @center frame, ] keep ] bi
|
||||
g swap >>model redo-toggler ] build-frame ;
|
||||
Loading…
Reference in New Issue