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

extra/irc/client/client-tests.factor

@@ -160,7 +160,7 @@ IN: irc.client.tests
     } cleave
     ] unit-test
 
-! Namelist notification
+! 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
@@ -173,3 +173,18 @@ IN: irc.client.tests
       [ terminate-irc ]
     } cleave
     ] unit-test
+
+{ T{ participant-changed f "somedude" +part+ } } [
+    { ":somedude!n=user@isp.net QUIT" } make-client
+    { [ "factorbot" set-nick ]
+      [ listeners>>
+        [ "#factortest" [ <irc-channel-listener>
+                          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

extra/irc/client/client.factor

@@ -88,10 +88,11 @@ SYMBOL: current-irc-client
 : irc-stream> ( -- stream ) irc> stream>> ;
 : irc-write ( s -- ) irc-stream> stream-write ;
 : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
+: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
 : listener> ( name -- listener/f ) irc> listeners>> at ;
 
 : maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
-    [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline
+    [ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline
 
 GENERIC: to-listener ( message obj -- )
 
@@ -147,24 +148,6 @@ DEFER: me?
     "JOIN " irc-write
     [ [ " :" ] dip 3append ] when* irc-print ;
 
-: /PART ( channel text -- )
-    [ "PART " irc-write irc-write ] dip
-    " :" irc-write irc-print ;
-
-: /KICK ( channel who -- )
-    [ "KICK " irc-write irc-write ] dip
-    " " irc-write irc-print ;
-
-: /PRIVMSG ( nick line -- )
-    [ "PRIVMSG " irc-write irc-write ] dip
-    " :" irc-write irc-print ;
-
-: /ACTION ( nick line -- )
-    [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ;
-
-: /QUIT ( text -- )
-    "QUIT :" irc-write irc-print ;
-
 : /PONG ( text -- )
     "PONG " irc-write irc-print ;
 
@@ -240,10 +223,14 @@ M: kick handle-incoming-irc ( kick -- )
 M: quit handle-incoming-irc ( quit -- )
     [ dup prefix>> parse-name listeners-with-participant
       [ to-listener ] with each ]
-    [ prefix>> parse-name remove-participant-from-all ]
     [ handle-participant-change ]
+    [ prefix>> parse-name remove-participant-from-all ]
     tri ;
 
+! FIXME: implement this
+! M: mode handle-incoming-irc ( mode -- ) call-next-method ;
+! M: nick handle-incoming-irc ( nick -- ) call-next-method ;
+
 : >nick/mode ( string -- nick mode )
     dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
 

extra/irc/ui/ui.factor

@@ -2,13 +2,14 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: accessors kernel threads combinators concurrency.mailboxes
-       sequences strings hashtables splitting fry assocs hashtables
+       sequences strings hashtables splitting fry assocs hashtables colors
+       sorting qualified unicode.case math.order
        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 ui.gadgets.packs ui.gadgets.labels
        io io.styles namespaces calendar calendar.format models continuations
        irc.client irc.client.private irc.messages irc.messages.private
-       irc.ui.commandparser irc.ui.load qualified ;
+       irc.ui.commandparser irc.ui.load ;
 
 RENAME: join sequences => sjoin
 
@@ -24,14 +25,8 @@ TUPLE: irc-tab < frame listener client userlist ;
 
 : write-color ( str color -- )
     foreground associate format ;
-: red { 0.5 0 0 1 } ;
+: dark-red T{ rgba f 0.5 0.0 0.0 1 } ;
-: green { 0 0.5 0 1 } ;
+: dark-green T{ rgba f 0.0 0.5 0.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 "." ]
@@ -65,21 +60,21 @@ M: own-message write-irc
     message>> write ;
 
 M: join write-irc
-    "* " green write-color
+    "* " dark-green write-color
     prefix>> parse-name write
-    " has entered the channel." green write-color ;
+    " has entered the channel." dark-green write-color ;
 
 M: part write-irc
-    "* " red write-color
+    "* " dark-red write-color
     [ prefix>> parse-name write ] keep
-    " has left the channel" red write-color
+    " has left the channel" dark-red write-color
-    trailing>> dot-or-parens red write-color ;
+    trailing>> dot-or-parens dark-red write-color ;
 
 M: quit write-irc
-    "* " red write-color
+    "* " dark-red write-color
     [ prefix>> parse-name write ] keep
-    " has left IRC" red write-color
+    " has left IRC" dark-red write-color
-    trailing>> dot-or-parens red write-color ;
+    trailing>> dot-or-parens dark-red write-color ;
 
 : full-mode ( message -- mode )
     parameters>> rest " " sjoin ;
@@ -92,18 +87,24 @@ M: mode write-irc
     " to " blue write-color
     channel>> write ;
 
+M: nick write-irc
+    "* " blue write-color
+    [ prefix>> parse-name write ] keep
+    " is now known as " blue write-color
+    trailing>> write ;
+
 M: unhandled write-irc
     "UNHANDLED: " write
     line>> blue write-color ;
 
 M: irc-end write-irc
-    drop "* You have left IRC" red write-color ;
+    drop "* You have left IRC" dark-red write-color ;
 
 M: irc-disconnected write-irc
-    drop "* Disconnected" red write-color ;
+    drop "* Disconnected" dark-red write-color ;
 
 M: irc-connected write-irc
-    drop "* Connected" green write-color ;
+    drop "* Connected" dark-green write-color ;
 
 M: irc-listener-end write-irc
     drop ;
@@ -124,15 +125,18 @@ M: irc-message write-irc
 
 GENERIC: handle-inbox ( tab message -- )
 
-: filter-participants ( pack alist val color -- pack )
+: value-labels ( assoc val -- seq )
-   '[ , = [ <label> , >>color add-gadget ] [ drop ] if ] assoc-each ;
+    '[ nip , = ] assoc-filter keys [ >lower <=> ] sort [ <label> ] map ;
+
+: add-gadget-color ( pack seq color -- pack )
+    '[ , >>color add-gadget ] each ;
 
 : update-participants ( tab -- )
     [ userlist>> [ clear-gadget ] keep ]
     [ listener>> participants>> ] bi
-    [ +operator+ green filter-participants ]
+    [ +operator+ value-labels dark-green add-gadget-color ]
-    [ +voice+ blue filter-participants ]
+    [ +voice+ value-labels blue add-gadget-color ]
-    [ +normal+ black filter-participants ] tri drop ;
+    [ +normal+ value-labels black add-gadget-color ] tri drop ;
 
 M: participant-changed handle-inbox
     drop update-participants ;