! Copyright (C) 2008 William Schlieper\r
! See http://factorcode.org/license.txt for BSD license.\r
\r
-USING: kernel continuations sequences namespaces fry ;\r
+USING: kernel continuations combinators sequences quotations arrays namespaces\r
+ fry summary assocs math math.order macros ;\r
\r
IN: backtrack\r
\r
SYMBOL: failure\r
\r
-: amb ( seq -- elt )\r
- failure get\r
- '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each\r
- , continue ] callcc1 ;\r
+ERROR: amb-failure ;\r
+\r
+M: amb-failure summary drop "Backtracking failure" ;\r
\r
: fail ( -- )\r
- f amb drop ;\r
+ failure get [ continue ]\r
+ [ amb-failure ] if* ;\r
\r
: require ( ? -- )\r
[ fail ] unless ;\r
\r
+MACRO: checkpoint ( quot -- quot' )\r
+ '[ failure get ,\r
+ '[ '[ failure set , continue ] callcc0\r
+ , failure set @ ] callcc0 ] ;\r
+\r
+: number-from ( from -- from+n )\r
+ [ 1 + number-from ] checkpoint ;\r
+\r
+<PRIVATE\r
+\r
+: unsafe-number-from-to ( to from -- to from+n )\r
+ 2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;\r
+\r
+: number-from-to ( to from -- to from+n )\r
+ 2dup < [ fail ] when unsafe-number-from-to ;\r
+\r
+: amb-integer ( seq -- int )\r
+ length 1 - 0 number-from-to nip ;\r
+\r
+MACRO: unsafe-amb ( seq -- quot )\r
+ dup length 1 =\r
+ [ first 1quotation ]\r
+ [ [ first ] [ rest ] bi\r
+ '[ , [ drop , unsafe-amb ] checkpoint ] ] if ;\r
+\r
+PRIVATE> \r
+\r
+: amb-lazy ( seq -- elt )\r
+ [ amb-integer ] [ nth ] bi ;\r
+\r
+: amb ( seq -- elt )\r
+ dup empty?\r
+ [ drop fail f ]\r
+ [ unsafe-amb ] if ; inline\r
+\r
+MACRO: amb-execute ( seq -- quot )\r
+ [ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi\r
+ '[ , 0 unsafe-number-from-to nip , case ] ;\r
+\r
+: if-amb ( true false -- )\r
+ [\r
+ [ { t f } amb ]\r
+ [ '[ @ require t ] ]\r
+ [ '[ @ f ] ]\r
+ tri* if\r
+ ] with-scope ; inline\r
+\r
: 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 ;
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
: 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
":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"
\ No newline at end of file
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 )
! 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
: 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* ;
+: listeners-with-participant ( nick -- seq )
+ irc> listeners>> values
+ [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
+ with filter ;
+
: remove-participant-from-all ( nick -- )
- irc> listeners>>
- [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with
- assoc-each ;
+ dup listeners-with-participant [ delete-at ] with each ;
-: add-participant ( nick mode channel -- )
+: add-participant ( mode nick channel -- )
listener> [ participants>> set-at ] [ 2drop ] if* ;
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) ;
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 ;
+ [ 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 ]
- [ dup who>> me? [ unregister-listener ] [ drop ] if ]
- tri ;
+ { [ 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 ;
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 ;
! 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 ;
: (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 ;
[ (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 ;
} 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
--- /dev/null
+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
+
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 )
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" ;
: split-trailing ( string -- string string/f )
":" split1 ;
+PRIVATE>
+
: string>irc-message ( string -- object )
dup split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
[ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
-PRIVATE>
\r
IN: irc.ui.load\r
\r
-: file-or ( path path -- path ) over exists? ? ;\r
+: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;\r
\r
: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;\r
\r
sequences strings hashtables splitting fry assocs hashtables\r
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
- ui.gadgets.tabs ui.gadgets.grids\r
- io io.styles namespaces calendar calendar.format\r
+ ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels\r
+ io io.styles namespaces calendar calendar.format models\r
irc.client irc.client.private irc.messages irc.messages.private\r
irc.ui.commandparser irc.ui.load ;\r
\r
\r
TUPLE: ui-window client tabs ;\r
\r
+TUPLE: irc-tab < frame listener client listmodel ;\r
+\r
: write-color ( str color -- )\r
foreground associate format ;\r
: red { 0.5 0 0 1 } ;\r
: green { 0 0.5 0 1 } ;\r
: blue { 0 0 1 1 } ;\r
+: black { 0 0 0 1 } ;\r
+\r
+: colors H{ { +operator+ { 0 0.5 0 1 } }\r
+ { +voice+ { 0 0 1 1 } }\r
+ { +normal+ { 0 0 0 1 } } } ;\r
\r
: dot-or-parens ( string -- string )\r
dup empty? [ drop "." ]\r
" has left IRC" red write-color\r
trailing>> dot-or-parens red write-color ;\r
\r
+M: mode write-irc\r
+ "* " blue write-color\r
+ [ name>> write ] keep\r
+ " has applied mode " blue write-color\r
+ [ mode>> write ] keep\r
+ " to " blue write-color\r
+ channel>> write ;\r
+\r
M: irc-end write-irc\r
drop "* You have left IRC" red write-color ;\r
\r
[ print-irc ]\r
[ listener get write-message ] bi ;\r
\r
-: display ( stream listener -- )\r
+GENERIC: handle-inbox ( tab message -- )\r
+\r
+: filter-participants ( assoc val -- alist )\r
+ [ >alist ] dip\r
+ '[ second , = ] filter ;\r
+\r
+: update-participants ( tab -- )\r
+ [ listmodel>> ] [ listener>> participants>> ] bi\r
+ [ +operator+ filter-participants ]\r
+ [ +voice+ filter-participants ]\r
+ [ +normal+ filter-participants ] tri\r
+ append append swap set-model ;\r
+\r
+M: participant-changed handle-inbox\r
+ drop update-participants ;\r
+\r
+M: object handle-inbox\r
+ nip print-irc ;\r
+\r
+: display ( stream tab -- )\r
'[ , [ [ t ]\r
- [ , read-message print-irc ]\r
+ [ , dup listener>> read-message handle-inbox ]\r
[ ] while ] with-output-stream ] "ircv" spawn drop ;\r
\r
-: <irc-pane> ( listener -- pane )\r
+: <irc-pane> ( tab -- tab pane )\r
<scrolling-pane>\r
- [ <pane-stream> swap display ] keep ;\r
+ [ <pane-stream> swap display ] 2keep ;\r
\r
TUPLE: irc-editor < editor outstream listener client ;\r
\r
-: <irc-editor> ( page pane listener -- client editor )\r
- irc-editor new-editor\r
- swap >>listener swap <pane-stream> >>outstream\r
+: <irc-editor> ( tab pane -- tab editor )\r
+ over irc-editor new-editor\r
+ swap
listener>> >>listener swap <pane-stream> >>outstream
\r over client>> >>client ;\r
\r
: editor-send ( irc-editor -- )\r
{ T{ key-down f f "ENTER" } editor-send }\r
} define-command-map\r
\r
-TUPLE: irc-page < frame listener client ;\r
+: <irc-list> ( -- gadget model )\r
+ [ drop ]\r
+ [ first2 [ <label> ] dip >>color ]\r
+ { } <model> [ <list> ] keep ;\r
+\r
+: <irc-tab> ( listener client -- irc-tab )\r
+ irc-tab new-frame\r
+ swap client>> >>client swap >>listener\r
+ <irc-pane> [ <scroller> @center grid-add* ] keep\r
+ <irc-editor> <scroller> @bottom grid-add* ;\r
+\r
+: <irc-channel-tab> ( listener client -- irc-tab )\r
+ <irc-tab>\r
+ <irc-list> [ <scroller> @right grid-add* ] dip >>listmodel\r
+ [ update-participants ] keep ;\r
\r
-: <irc-page> ( listener client -- irc-page )\r
- irc-page new-frame\r
- swap client>> >>client swap [ >>listener ] keep\r
- [ <irc-pane> [ <scroller> @center grid-add* ] keep ]\r
- [ <irc-editor> <scroller> @bottom grid-add* ] bi ;\r
+: <irc-server-tab> ( listener client -- irc-tab )\r
+ <irc-tab> ;\r
\r
-M: irc-page graft*\r
+M: irc-tab graft*\r
[ listener>> ] [ client>> ] bi\r
add-listener ;\r
\r
-M: irc-page ungraft*\r
+M: irc-tab ungraft*\r
[ listener>> ] [ client>> ] bi\r
remove-listener ;\r
\r
: join-channel ( name ui-window -- )\r
[ dup <irc-channel-listener> ] dip\r
- [ <irc-page> swap ] keep\r
+ [ <irc-channel-tab> swap ] keep\r
tabs>> add-page ;\r
\r
: irc-window ( ui-window -- )\r
: ui-connect ( profile -- ui-window )\r
<irc-client> ui-window new over >>client swap\r
[ connect-irc ]\r
- [ listeners>> +server-listener+ swap at <irc-pane> <scroller>\r
+ [ listeners>> +server-listener+ swap at over <irc-tab>\r
"Server" associate <tabbed> >>tabs ] bi ;\r
\r
: server-open ( server port nick password channels -- )\r
[ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
- [ over join-channel ] each ;\r
+ [ over join-channel ] each drop ;\r
\r
: main-run ( -- ) run-ircui ;\r
\r
projects / factor.git / commitdiff