Merge branch 'master' of git://factorforge.org/git/william42
Slava Pestov
commit
86221a23d7
|
|
@ -1,20 +1,68 @@
|
|||
! 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
|
||||
|
||||
: 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 [ continue ]
|
||||
[ amb-failure ] if* ;
|
||||
|
||||
: require ( ? -- )
|
||||
[ fail ] unless ;
|
||||
|
||||
MACRO: checkpoint ( quot -- quot' )
|
||||
'[ failure get ,
|
||||
'[ '[ failure set , continue ] callcc0
|
||||
, failure set @ ] callcc0 ] ;
|
||||
|
||||
: number-from ( from -- from+n )
|
||||
[ 1 + number-from ] checkpoint ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: unsafe-number-from-to ( to from -- to from+n )
|
||||
2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;
|
||||
|
||||
: number-from-to ( to from -- to from+n )
|
||||
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 ;
|
||||
|
||||
: amb ( seq -- elt )
|
||||
dup empty?
|
||||
[ drop fail f ]
|
||||
[ unsafe-amb ] if ; inline
|
||||
|
||||
MACRO: amb-execute ( seq -- quot )
|
||||
[ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi
|
||||
'[ , 0 unsafe-number-from-to nip , case ] ;
|
||||
|
||||
: if-amb ( true false -- )
|
||||
[
|
||||
[ { t f } amb ]
|
||||
[ '[ @ require t ] ]
|
||||
[ '[ @ f ] ]
|
||||
tri* if
|
||||
] with-scope ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -12,18 +12,6 @@ IN: benchmark.backtrack
|
|||
|
||||
: nop ;
|
||||
|
||||
MACRO: amb-execute ( seq -- quot )
|
||||
[ length ] [ <enum> [ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -64,21 +42,29 @@ privmsg new
|
|||
":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"
|
||||
{ ":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 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" [ <irc-channel-listener> ] 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"
|
||||
|
|
@ -31,6 +31,20 @@ 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 -- mode )
|
||||
H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
|
||||
|
||||
! participant changed actions
|
||||
SYMBOL: +join+
|
||||
SYMBOL: +part+
|
||||
SYMBOL: +mode+
|
||||
|
||||
! listener objects
|
||||
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
|
||||
|
||||
: <irc-server-listener> ( -- irc-server-listener )
|
||||
|
|
@ -46,6 +60,9 @@ SYMBOL: +server-listener+
|
|||
! Message objects
|
||||
! ======================================
|
||||
|
||||
TUPLE: participant-changed nick action ;
|
||||
C: <participant-changed> 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
|
||||
|
|
@ -70,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?
|
||||
|
|
@ -142,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+ <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 -- )
|
||||
|
||||
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) ;
|
||||
|
|
@ -162,34 +206,43 @@ 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 ] [ f ] if ;
|
||||
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
|
||||
|
||||
: 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) ;
|
||||
[ names-reply>participants ] [ channel>> listener> ] bi
|
||||
[ (>>participants) ] [ drop ] if* ;
|
||||
|
||||
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
|
||||
broadcast-message-to-listeners ;
|
||||
|
|
@ -200,8 +253,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 ;
|
||||
|
|
@ -213,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 ;
|
||||
|
||||
|
|
@ -225,7 +273,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 ;
|
||||
|
|
@ -247,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 ;
|
||||
|
|
@ -267,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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -21,6 +21,10 @@ TUPLE: mode < irc-message name channel mode ;
|
|||
TUPLE: names-reply < irc-message who = channel ;
|
||||
TUPLE: unhandled < irc-message ;
|
||||
|
||||
: <irc-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 )
|
||||
|
|
@ -30,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" ;
|
||||
|
||||
|
|
@ -58,6 +63,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 +89,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>
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <irc-pane> ( listener -- pane )
|
||||
: <irc-pane> ( tab -- tab pane )
|
||||
<scrolling-pane>
|
||||
[ <pane-stream> swap display ] keep ;
|
||||
[ <pane-stream> swap display ] 2keep ;
|
||||
|
||||
TUPLE: irc-editor < editor outstream listener client ;
|
||||
|
||||
: <irc-editor> ( page pane listener -- client editor )
|
||||
irc-editor new-editor
|
||||
swap >>listener swap <pane-stream> >>outstream
|
||||
: <irc-editor> ( tab pane -- tab editor )
|
||||
over irc-editor new-editor
|
||||
swap listener>> >>listener swap <pane-stream> >>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 ;
|
||||
: <irc-list> ( -- gadget model )
|
||||
[ drop ]
|
||||
[ first2 [ <label> ] dip >>color ]
|
||||
{ } <model> [ <list> ] keep ;
|
||||
|
||||
: <irc-page> ( listener client -- irc-page )
|
||||
irc-page new-frame
|
||||
swap client>> >>client swap [ >>listener ] keep
|
||||
[ <irc-pane> [ <scroller> @center grid-add* ] keep ]
|
||||
[ <irc-editor> <scroller> @bottom grid-add* ] bi ;
|
||||
: <irc-tab> ( listener client -- irc-tab )
|
||||
irc-tab new-frame
|
||||
swap client>> >>client swap >>listener
|
||||
<irc-pane> [ <scroller> @center grid-add* ] keep
|
||||
<irc-editor> <scroller> @bottom grid-add* ;
|
||||
|
||||
M: irc-page graft*
|
||||
: <irc-channel-tab> ( listener client -- irc-tab )
|
||||
<irc-tab>
|
||||
<irc-list> [ <scroller> @right grid-add* ] dip >>listmodel
|
||||
[ update-participants ] keep ;
|
||||
|
||||
: <irc-server-tab> ( listener client -- irc-tab )
|
||||
<irc-tab> ;
|
||||
|
||||
M: irc-tab graft*
|
||||
[ listener>> ] [ client>> ] bi
|
||||
add-listener ;
|
||||
|
||||
M: irc-page ungraft*
|
||||
M: irc-tab ungraft*
|
||||
[ listener>> ] [ client>> ] bi
|
||||
remove-listener ;
|
||||
|
||||
: join-channel ( name ui-window -- )
|
||||
[ dup <irc-channel-listener> ] dip
|
||||
[ <irc-page> swap ] keep
|
||||
[ <irc-channel-tab> swap ] keep
|
||||
tabs>> add-page ;
|
||||
|
||||
: irc-window ( ui-window -- )
|
||||
|
|
@ -142,12 +187,12 @@ M: irc-page ungraft*
|
|||
: ui-connect ( profile -- ui-window )
|
||||
<irc-client> ui-window new over >>client swap
|
||||
[ connect-irc ]
|
||||
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>
|
||||
[ listeners>> +server-listener+ swap at over <irc-tab>
|
||||
"Server" associate <tabbed> >>tabs ] bi ;
|
||||
|
||||
: server-open ( server port nick password channels -- )
|
||||
[ <irc-profile> ui-connect [ irc-window ] keep ] dip
|
||||
[ over join-channel ] each ;
|
||||
[ over join-channel ] each drop ;
|
||||
|
||||
: main-run ( -- ) run-ircui ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue