irc: IRC messages reimplemented

extra/irc/client/client-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax quotations kernel irc.messages ;
+USING: help.markup help.syntax quotations kernel irc.messages irc.messages.base irc.messages.parser ;
 IN: irc.client
 
 HELP: irc-client "IRC Client object" ;
@@ -56,15 +56,15 @@ ARTICLE: "irc.client" "IRC Client"
 "Some of the RFC defined irc messages as objects:"
 { $table
   { { $link irc-message } "base of all irc messages" }
-  { { $link logged-in } "logged in to server" }
+  { { $link rpl-welcome } "logged in to server" }
   { { $link ping } "ping message" }
   { { $link join } "channel join" }
   { { $link part } "channel part" }
   { { $link quit } "quit from irc" }
   { { $link privmsg } "private message (to client or channel)" }
   { { $link kick } "kick from channel" }
-  { { $link roomlist } "list of participants in channel" }
+  { { $link rpl-names } "list of participants in channel" }
-  { { $link nick-in-use } "chosen nick is in use by another client" }
+  { { $link rpl-nickname-in-use } "chosen nick is in use by another client" }
   { { $link notice } "notice message" }
   { { $link mode } "mode change" }
   { { $link unhandled } "uninmplemented/unhandled message" }

extra/irc/client/client-tests.factor

@@ -1,7 +1,7 @@
 USING: kernel tools.test accessors arrays sequences
        io io.streams.duplex namespaces threads destructors
-       calendar irc.client.private irc.client irc.messages.private
+       calendar irc.client.private irc.client irc.messages
-       concurrency.mailboxes classes assocs combinators ;
+       concurrency.mailboxes classes assocs combinators irc.messages.parser ;
 EXCLUDE: irc.messages => join ;
 RENAME: join irc.messages => join_
 IN: irc.client.tests
@@ -49,13 +49,13 @@ M: mb-writer dispose drop ;
 
   { "factorbot" } [ irc> nick>> ] unit-test
 
-  { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+!  { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
 
   { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
-                      parse-irc-line forward-name ] unit-test
+                      string>irc-message forward-name ] unit-test
 
   { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
-                   parse-irc-line forward-name ] unit-test
+                   string>irc-message forward-name ] unit-test
 ] with-irc
 
 ! Test login and nickname set
@@ -102,7 +102,7 @@ M: mb-writer dispose drop ;
       "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
       ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
       [ privmsg? ] read-matching-message
-      [ class ] [ name>> ] [ trailing>> ] tri
+      [ class ] [ target>> ] [ trailing>> ] tri
   ] unit-test
 ] with-irc
 
@@ -110,7 +110,7 @@ M: mb-writer dispose drop ;
       "ircuser" <irc-nick-chat>  [ %add-named-chat ] keep
       ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
       [ privmsg? ] read-matching-message
-      [ class ] [ name>> ] [ trailing>> ] tri
+      [ class ] [ target>> ] [ trailing>> ] tri
   ] unit-test
 ] with-irc
 

extra/irc/client/client.factor

@@ -3,7 +3,7 @@
 USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
        accessors destructors namespaces io assocs arrays fry
        continuations threads strings classes combinators splitting hashtables
-       ascii irc.messages ;
+       ascii irc.messages irc.messages.base irc.messages.parser call ;
 RENAME: join sequences => sjoin
 EXCLUDE: sequences => join ;
 IN: irc.client
@@ -74,12 +74,12 @@ SINGLETON: irc-disconnected ! sent when connection is lost
 SINGLETON: irc-connected    ! sent when connection is established
 
 : terminate-irc ( irc-client -- )
-    [ is-running>> ] keep and [
+    dup is-running>> [
         f >>is-running
         [ stream>> dispose ] keep
         [ in-messages>> ] [ out-messages>> ] bi 2array
         [ irc-end swap mailbox-put ] each
-    ] when* ;
+    ] [ drop ] if ;
 
 <PRIVATE
 
@@ -120,7 +120,7 @@ M: irc-chat to-chat in-messages>> mailbox-put ;
 
 : chats-with-participant ( nick -- seq )
     irc> chats>> values
-    [ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ]
+    [ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ]
     with filter ;
 
 : to-chats-with-participant ( message nickname -- )
@@ -165,11 +165,10 @@ M: irc-chat to-chat in-messages>> mailbox-put ;
     " hostname servername :irc.factor" irc-print ;
 
 : /CONNECT ( server port -- stream )
-    irc> connect>> call drop ; inline
+    irc> connect>> call( host port -- stream local ) drop ;
 
 : /JOIN ( channel password -- )
-    "JOIN " irc-write
+    "JOIN " irc-write [ " :" swap 3append ] when* irc-print ;
-    [ [ " :" ] dip 3append ] when* irc-print ;
 
 : /PONG ( text -- )
     "PONG " irc-write irc-print ;
@@ -187,7 +186,7 @@ M: join forward-name trailing>> ;
 M: part forward-name channel>> ;
 M: kick forward-name channel>> ;
 M: mode forward-name name>> ;
-M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ;
+M: privmsg forward-name dup target>> me? [ sender>> ] [ target>> ] if ;
 
 UNION: single-forward join part kick mode privmsg ;
 UNION: multiple-forward nick quit ;
@@ -200,48 +199,48 @@ M: irc-message forward-message
 M: single-forward forward-message dup forward-name to-chat ;
 
 M: multiple-forward forward-message
-    dup irc-message-sender to-chats-with-participant ;
+    dup sender>> to-chats-with-participant ;
   
 M: broadcast-forward forward-message
     irc> chats>> values [ to-chat ] with each ;
 
 GENERIC: process-message ( irc-message -- )
 M: object      process-message drop ; 
-M: logged-in   process-message
+M: rpl-welcome process-message
-    name>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
+    nickname>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
     values [ initialize-chat ] each ;
 M: ping        process-message trailing>> /PONG ;
-M: nick-in-use process-message name>> "_" append /NICK ;
+M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
 
 M: join process-message
-    [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
+    [ drop +normal+ ] [ sender>> ] [ trailing>> ] tri
     dup chat> [ add-participant ] [ 3drop ] if ;
 
 M: part process-message
-    [ irc-message-sender ] [ channel>> ] bi remove-participant ;
+    [ sender>> ] [ channel>> ] bi remove-participant ;
 
 M: kick process-message
-    [ [ who>> ] [ channel>> ] bi remove-participant ]
+    [ [ user>> ] [ channel>> ] bi remove-participant ]
-    [ dup who>> me? [ unregister-chat ] [ drop ] if ]
+    [ dup user>> me? [ unregister-chat ] [ drop ] if ]
     bi ;
 
 M: quit process-message
-    irc-message-sender remove-participant-from-all ;
+    sender>> remove-participant-from-all ;
 
 M: nick process-message
-    [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
+    [ sender>> ] [ trailing>> ] bi rename-participant-in-all ;
 
 M: mode process-message ( mode -- )
-    [ channel-mode? ] keep and [
+    dup channel-mode? [
         [ name>> ] [ mode>> ] [ parameter>> ] tri
         [ change-participant-mode ] [ 2drop ] if*
-    ] when* ;
+    ] [ drop ] if ;
 
 : >nick/mode ( string -- nick mode )
     dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
 
 : names-reply>participants ( names-reply -- participants )
-    trailing>> [ blank? ] trim " " split
+    nicks>> [ blank? ] trim " " split
     [ >nick/mode 2array ] map >hashtable ;
 
 : maybe-clean-participants ( channel-chat -- )
@@ -249,14 +248,14 @@ M: mode process-message ( mode -- )
         H{ } clone >>participants f >>clean-participants
     ] when drop ;
 
-M: names-reply process-message
+M: rpl-names process-message
     [ names-reply>participants ] [ channel>> chat> ] bi [
         [ maybe-clean-participants ] 
         [ participants>> 2array assoc-combine ]
         [ (>>participants) ] tri
     ] [ drop ] if* ;
 
-M: end-of-names process-message
+M: rpl-names-end process-message
     channel>> chat> [
         t >>clean-participants
         [ f f f <participant-changed> ] dip name>> to-chat
@@ -268,7 +267,7 @@ M: end-of-names process-message
 
 GENERIC: handle-outgoing-irc ( irc-message -- ? )
 M: irc-end     handle-outgoing-irc drop f ;
-M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ;
+M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
 
 ! ======================================
 ! Reader/Writer
@@ -293,9 +292,9 @@ DEFER: (connect-irc)
 : (reader-loop) ( -- ? )
     irc> stream>> [
         |dispose stream-readln [
-            parse-irc-line handle-reader-message t
+            string>irc-message handle-reader-message t
         ] [
-            handle-disconnect
+            f handle-disconnect
         ] if*
     ] with-destructors ;
 
@@ -314,7 +313,7 @@ DEFER: (connect-irc)
     [ forward-message ] [ process-message ] [ irc-end? not ] tri ;
 
 : strings>privmsg ( name string -- privmsg )
-    privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
+    privmsg new [ (>>trailing) ] keep [ (>>target) ] keep ;
 
 : maybe-annotate-with-name ( name obj -- obj )
     { { [ dup string? ] [ strings>privmsg ] }
@@ -325,7 +324,7 @@ DEFER: (connect-irc)
 GENERIC: annotate-message ( chat object -- object )
 M: object  annotate-message nip ;
 M: part    annotate-message swap name>> >>channel ;
-M: privmsg annotate-message swap name>> >>name ;
+M: privmsg annotate-message swap name>> >>target ;
 M: string  annotate-message [ name>> ] dip strings>privmsg ;
 
 : spawn-irc ( -- )
@@ -335,7 +334,7 @@ M: string  annotate-message [ name>> ] dip strings>privmsg ;
     3drop ;
 
 GENERIC: (attach-chat) ( irc-chat -- )
-USE: prettyprint
+
 M: irc-chat (attach-chat)
     [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ]
     [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ]

extra/irc/messages/base/authors.txt

@@ -0,0 +1 @@
+Bruno Deferrari

extra/irc/messages/base/base.factor

@@ -0,0 +1,115 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes.parser classes.tuple
+       combinators fry generic.parser kernel lexer
+       mirrors namespaces parser sequences splitting strings words ;
+IN: irc.messages.base
+
+TUPLE: irc-message line prefix command parameters trailing timestamp sender ;
+TUPLE: unhandled < irc-message ;
+
+SYMBOL: string-irc-type-mapping
+string-irc-type-mapping [ H{ } clone ] initialize
+
+: register-irc-message-type ( type string -- )
+    string-irc-type-mapping get set-at ;
+
+: irc>type ( string -- irc-message-class )
+    string-irc-type-mapping get at unhandled or ;
+
+GENERIC: irc-trailing-slot ( irc-message -- string/f )
+M: irc-message irc-trailing-slot
+    drop f ;
+
+GENERIC: irc-parameter-slots ( irc-message -- seq )
+M: irc-message irc-parameter-slots
+    drop f ;
+
+GENERIC: process-irc-trailing ( irc-message -- )
+M: irc-message process-irc-trailing
+    dup irc-trailing-slot [
+        swap [ trailing>> swap ] [ <mirror> ] bi set-at
+    ] [ drop ] if* ;
+
+GENERIC: process-irc-prefix ( irc-message -- )
+M: irc-message process-irc-prefix
+    drop ;
+
+<PRIVATE
+: [slot-setter] ( mirror -- quot )
+    '[ [ _ set-at ] [ drop ] if* ] ; inline
+PRIVATE>
+
+GENERIC: process-irc-parameters ( irc-message -- )
+M: irc-message process-irc-parameters
+    dup irc-parameter-slots [
+        swap [ parameters>> swap ] [ <mirror> [slot-setter] ] bi 2each
+    ] [ drop ] if* ;
+
+GENERIC: post-process-irc-message ( irc-message -- )
+M: irc-message post-process-irc-message drop ;
+
+GENERIC: fill-irc-message-slots ( irc-message -- )
+M: irc-message fill-irc-message-slots
+    {
+        [ process-irc-trailing ]
+        [ process-irc-prefix ]
+        [ process-irc-parameters ]
+        [ post-process-irc-message ]
+    } cleave ;
+
+GENERIC: irc-command-string ( irc-message -- string )
+M: irc-message irc-command-string drop f ;
+
+! FIXME: inverse of post-process is missing
+GENERIC: set-irc-parameters ( irc-message -- )
+M: irc-message set-irc-parameters
+    dup irc-parameter-slots
+    [ over <mirror> '[ _ at ] map >>parameters ] when* drop ;
+
+GENERIC: set-irc-trailing ( irc-message -- )
+M: irc-message set-irc-trailing
+    dup irc-trailing-slot [ over <mirror> at >>trailing ] when* drop ;
+
+GENERIC: set-irc-command ( irc-message -- )
+M: irc-message set-irc-command
+    [ irc-command-string ] [ (>>command) ] bi ;
+
+: irc-message>string ( irc-message -- string )
+    {
+        [ prefix>> ]
+        [ command>> ]
+        [ parameters>> " " join ]
+        [ trailing>> dup [ CHAR: : prefix ] when ]
+    } cleave 4array sift " " join ;
+
+<PRIVATE
+: ?define-irc-parameters ( class slot-names -- )
+    dup empty? not [
+        [ \ irc-parameter-slots create-method-in ] dip
+        [ [ "_" = not ] keep and ] map '[ drop _ ] define
+    ] [ 2drop ] if ;
+
+: ?define-irc-trailing ( class slot-name -- )
+    [
+        [ \ irc-trailing-slot create-method-in ] dip
+        first '[ drop _ ] define
+    ] [ drop ] if* ;
+
+: define-irc-class ( class params -- )
+    [ { ":" "_" } member? not ] filter
+    [ irc-message ] dip define-tuple-class ;
+
+: define-irc-parameter-slots ( class params -- )
+    { ":" } split1 [ over ] dip
+    [ ?define-irc-parameters ] [ ?define-irc-trailing ] 2bi* ;
+PRIVATE>
+
+#! SYNTAX:
+#! IRC: type "COMMAND" slot1 ...;
+#! IRC: type "COMMAND" slot1 ... : trailing-slot;
+: IRC: ( name string parameters -- )
+    CREATE-CLASS
+    [ scan-object register-irc-message-type ] keep
+    ";" parse-tokens
+    [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ; parsing

extra/irc/messages/base/summary.txt

@@ -0,0 +1 @@
+IRC messages base implementation

extra/irc/messages/messages-tests.factor

@@ -1,19 +1,10 @@
 USING: kernel tools.test accessors arrays
-       irc.messages irc.messages.private ;
+       irc.messages.parser irc.messages ;
 EXCLUDE: sequences => join ;
 IN: irc.messages.tests
 
 
-{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
-
-{ T{ irc-message
-     { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
-     { prefix "someuser!n=user@some.where" }
-     { command  "PRIVMSG" }
-     { parameters { "#factortest" } }
-     { trailing "hi" } } }
-[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
-  string>irc-message f >>timestamp ] unit-test
 
 { T{ privmsg
      { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
@@ -21,9 +12,10 @@ IN: irc.messages.tests
      { command "PRIVMSG" }
      { parameters { "#factortest" } }
      { trailing "hi" }
-     { name "#factortest" } } }
+     { target "#factortest" }
+     { text "hi" } } }
 [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
-  parse-irc-line f >>timestamp ] unit-test
+  string>irc-message f >>timestamp ] unit-test
 
 { T{ join
      { line ":someuser!n=user@some.where JOIN :#factortest" }
@@ -32,7 +24,7 @@ IN: irc.messages.tests
      { parameters { } }
      { trailing "#factortest" } } }
 [ ":someuser!n=user@some.where JOIN :#factortest"
-  parse-irc-line f >>timestamp ] unit-test
+  string>irc-message f >>timestamp ] unit-test
 
 { T{ mode
      { line ":ircserver.net MODE #factortest +ns" }
@@ -42,7 +34,7 @@ IN: irc.messages.tests
      { name "#factortest" }
      { mode "+ns" } } }
 [ ":ircserver.net MODE #factortest +ns"
-  parse-irc-line f >>timestamp ] unit-test
+  string>irc-message f >>timestamp ] unit-test
 
 { T{ mode
      { line ":ircserver.net MODE #factortest +o someuser" }
@@ -53,7 +45,7 @@ IN: irc.messages.tests
      { mode "+o" }
      { parameter "someuser" } } }
 [ ":ircserver.net MODE #factortest +o someuser"
-  parse-irc-line f >>timestamp ] unit-test
+  string>irc-message f >>timestamp ] unit-test
 
 { T{ nick
      { line ":someuser!n=user@some.where NICK :someuser2" }
@@ -62,9 +54,9 @@ IN: irc.messages.tests
      { parameters  { } }
      { trailing "someuser2" } } }
 [ ":someuser!n=user@some.where NICK :someuser2"
-  parse-irc-line f >>timestamp ] unit-test
+  string>irc-message f >>timestamp ] unit-test
 
-{ T{ nick-in-use
+{ T{ rpl-nickname-in-use
      { line ":ircserver.net 433 * nickname :Nickname is already in use" }
      { prefix "ircserver.net" }
      { command "433" }
@@ -72,4 +64,4 @@ IN: irc.messages.tests
      { name "nickname" }
      { trailing "Nickname is already in use" } } }
 [ ":ircserver.net 433 * nickname :Nickname is already in use"
-  parse-irc-line f >>timestamp ] unit-test
+  string>irc-message f >>timestamp ] unit-test

extra/irc/messages/messages.factor

@@ -1,179 +1,63 @@
 ! Copyright (C) 2008 Bruno Deferrari
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel fry splitting ascii calendar accessors combinators
-       arrays classes.tuple math.order ;
+       arrays classes.tuple math.order words assocs strings
-RENAME: join sequences => sjoin
+       irc.messages.base ;
 EXCLUDE: sequences => join ;
 IN: irc.messages
 
-TUPLE: irc-message line prefix command parameters trailing timestamp ;
+! connection
-TUPLE: logged-in < irc-message name ;
+IRC: pass        "PASS"    password ;
-TUPLE: ping < irc-message ;
+IRC: nick        "NICK"    nickname ;
-TUPLE: join < irc-message ;
+IRC: user        "USER"    user mode _ : realname ;
-TUPLE: part < irc-message channel ;
+IRC: oper        "OPER"    name password ;
-TUPLE: quit < irc-message ;
+IRC: mode        "MODE"    name mode parameter ;
-TUPLE: nick < irc-message ;
+IRC: service     "SERVICE" nickname _ distribution type _ : info ;
-TUPLE: privmsg < irc-message name ;
+IRC: quit        "QUIT"    : comment ;
-TUPLE: kick < irc-message channel who ;
+IRC: squit       "SQUIT"   server : comment ;
-TUPLE: roomlist < irc-message channel names ;
+! channel operations
-TUPLE: nick-in-use < irc-message name ;
+IRC: join        "JOIN"    channel ;
-TUPLE: notice < irc-message type ;
+IRC: part        "PART"    channel : comment ;
-TUPLE: mode < irc-message name mode parameter ;
+IRC: topic       "TOPIC"   channel : topic ;
-TUPLE: names-reply < irc-message who channel ;
+IRC: names       "NAMES"   channel ;
-TUPLE: end-of-names < irc-message who channel ;
+IRC: list        "LIST"    channel ;
-TUPLE: unhandled < irc-message ;
+IRC: invite      "INVITE"  nickname channel ;
-
+IRC: kick        "KICK"    channel user : comment ;
-: <irc-client-message> ( command parameters trailing -- irc-message )
+! chating
-    irc-message new
+IRC: privmsg     "PRIVMSG" target : text ;
-        now >>timestamp
+IRC: notice      "NOTICE"  target : text ;
-        swap >>trailing
+! server queries
-        swap >>parameters
+IRC: motd        "MOTD"    target ;
-        swap >>command ;
+IRC: lusers      "LUSERS"  mask target ;
-
+IRC: version     "VERSION" target ;
-<PRIVATE
+IRC: stats       "STATS"   query target ;
-
+IRC: links       "LINKS"   server mask ;
-GENERIC: command-string>> ( irc-message -- string )
+IRC: time        "TIME"    target ;
-
+IRC: connect     "CONNECT" server port remote-server ;
-M: irc-message command-string>> ( irc-message -- string ) command>> ;
+IRC: trace       "TRACE"   target ;
-M: ping        command-string>> ( ping -- string )    drop "PING" ;
+IRC: admin       "ADMIN"   target ;
-M: join        command-string>> ( join -- string )    drop "JOIN" ;
+IRC: info        "INFO"    target ;
-M: part        command-string>> ( part -- string )    drop "PART" ;
+! service queries
-M: quit        command-string>> ( quit -- string )    drop "QUIT" ;
+IRC: servlist    "SERVLIST" mask type ;
-M: nick        command-string>> ( nick -- string )    drop "NICK" ;
+IRC: squery      "SQUERY"  service-name : text ;
-M: privmsg     command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
+! user queries
-M: notice      command-string>> ( notice -- string )  drop "NOTICE" ;
+IRC: who         "WHO"     mask operator ;
-M: mode        command-string>> ( mode -- string )    drop "MODE" ;
+IRC: whois       "WHOIS"   target mask ;
-M: kick        command-string>> ( kick -- string )    drop "KICK" ;
+IRC: whowas      "WHOWAS"  nickname count target ;
-
+! misc
-GENERIC: command-parameters>> ( irc-message -- seq )
+IRC: kill        "KILL"    nickname : comment ;
-
+IRC: ping        "PING"    server1 server2 ;
-M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
+IRC: pong        "PONG"    server1 server2 ;
-M: ping        command-parameters>> ( ping -- seq )    drop { } ;
+IRC: error       "ERROR"   : message ;
-M: join        command-parameters>> ( join -- seq )    drop { } ;
+! numeric replies
-M: part        command-parameters>> ( part -- seq )    channel>> 1array ;
+IRC: rpl-welcome         "001" nickname : comment ;
-M: quit        command-parameters>> ( quit -- seq )    drop { } ;
+IRC: rpl-whois-user      "311" nicnamek user host _ : real-name ;
-M: nick        command-parameters>> ( nick -- seq )    drop { } ;
+IRC: rpl-channel-modes   "324" channel mode params ;
-M: privmsg     command-parameters>> ( privmsg -- seq ) name>> 1array ;
+IRC: rpl-notopic         "331" channel : topic ;
-M: notice      command-parameters>> ( norice -- seq )  type>> 1array ;
+IRC: rpl-topic           "332" channel : topic ;
-M: kick command-parameters>> ( kick -- seq )
+IRC: rpl-inviting        "341" channel nickname ;
-    [ channel>> ] [ who>> ] bi 2array ;
+IRC: rpl-names           "353" nickname _ channel : nicks ;
-M: mode command-parameters>> ( mode -- seq )
+IRC: rpl-names-end       "366" nickname channel : comment ;
-    [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
+! error replies
-
+IRC: rpl-nickname-in-use "433" _ name ;
-GENERIC# >>command-parameters 1 ( irc-message params -- irc-message )
+IRC: rpl-nick-collision  "436" nickname : comment ;
-
-M: irc-message >>command-parameters ( irc-message params -- irc-message )
-    drop ;
-
-M: logged-in >>command-parameters ( part params -- part )
-    first >>name ;
-
-M: privmsg >>command-parameters ( privmsg params -- privmsg )
-    first >>name ;
-
-M: notice >>command-parameters ( notice params -- notice )
-    first >>type ;
-
-M: part >>command-parameters ( part params -- part )
-    first >>channel ;
-
-M: kick >>command-parameters ( kick params -- kick )
-    first2 [ >>channel ] [ >>who ] bi* ;
-
-M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use )
-    second >>name ;
-
-M: names-reply >>command-parameters ( names-reply params -- names-reply )
-    first3 nip [ >>who ] [ >>channel ] bi* ;
-
-M: end-of-names >>command-parameters ( names-reply params -- names-reply )
-    first2 [ >>who ] [ >>channel ] bi* ;
-
-M: mode >>command-parameters ( mode params -- mode )
-    dup length {
-        { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
-        { 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
-        [ drop first >>name dup trailing>> >>mode ]
-    } case ;
-
-PRIVATE>
-
-GENERIC: irc-message>client-line ( irc-message -- string )
-
-M: irc-message irc-message>client-line ( irc-message -- string )
-    [ command-string>> ]
-    [ command-parameters>> " " sjoin ]
-    [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
-    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" ;
-
-<PRIVATE
-
-! ======================================
-! Message parsing
-! ======================================
-
-: split-at-first ( seq separators -- before after )
-    dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
-
-: remove-heading-: ( seq -- seq )
-    ":" ?head drop ;
-
-: 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 ;
-
-: copy-message-in ( command irc-message -- command )
-    {
-        [ line>>      >>line ]
-        [ prefix>>    >>prefix ]
-        [ command>>   >>command ]
-        [ trailing>>  >>trailing ]
-        [ timestamp>> >>timestamp ]
-        [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
-    } cleave ;
-
-PRIVATE>
-
-UNION: sender-in-prefix privmsg join part quit kick mode nick ;
-GENERIC: irc-message-sender ( irc-message -- sender )
-M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
-    prefix>> parse-name ;
-
-: string>irc-message ( string -- object )
-    dup split-prefix split-trailing
-    [ [ blank? ] trim " " split unclip swap ] dip
-    now irc-message boa ;
-
-: irc-message>command ( irc-message -- command )
-    [
-        command>> {
-            { "PING"    [ ping ] }
-            { "NOTICE"  [ notice ] }
-            { "001"     [ logged-in ] }
-            { "433"     [ nick-in-use ] }
-            { "353"     [ names-reply ] }
-            { "366"     [ end-of-names ] }
-            { "JOIN"    [ join ] }
-            { "PART"    [ part ] }
-            { "NICK"    [ nick ] }
-            { "PRIVMSG" [ privmsg ] }
-            { "QUIT"    [ quit ] }
-            { "MODE"    [ mode ] }
-            { "KICK"    [ kick ] }
-            [ drop unhandled ]
-        } case new
-    ] keep copy-message-in ;
-
-: parse-irc-line ( string -- message )
-    string>irc-message irc-message>command ;

extra/irc/messages/parser/authors.txt

@@ -0,0 +1 @@
+Bruno Deferrari

extra/irc/messages/parser/parser.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel fry splitting ascii calendar accessors combinators
+       arrays classes.tuple math.order words assocs
+       irc.messages.base sequences ;
+IN: irc.messages.parser
+
+<PRIVATE
+: split-at-first ( seq separators -- before after )
+    dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
+
+: split-trailing ( string -- string string/f ) ":" split1 ;
+: remove-heading-: ( seq -- seq ) ":" ?head drop ;
+
+: split-prefix ( string -- string/f string )
+    dup ":" head? [
+        remove-heading-: " " split1
+    ] [ f swap ] if ;
+
+: split-message ( string -- prefix command parameters trailing )
+    split-prefix split-trailing
+    [ [ blank? ] trim " " split unclip swap ] dip ;
+
+: sender ( irc-message -- sender )
+    prefix>> [ remove-heading-: "!" split-at-first drop ] [ f ] if* ;
+PRIVATE>
+
+: string>irc-message ( string -- irc-message )
+    dup split-message
+    [ [ irc>type new ] [ >>command ] bi ]
+    [ >>parameters ]
+    [ >>trailing ]
+    tri*
+    [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
+    now >>timestamp dup sender >>sender ;

extra/irc/messages/parser/summary.txt

@@ -0,0 +1 @@
+Basic parser for irc messages

extra/irc/messages/summary.txt

@@ -0,0 +1 @@
+IRC message definitions