1 ! Copyright (C) 2009 Bruno Deferrari
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs calendar classes.parser classes.tuple
4 combinators fry generic.parser kernel lexer
5 mirrors namespaces parser sequences splitting strings words ;
8 TUPLE: irc-message line prefix command parameters trailing timestamp sender ;
9 TUPLE: unhandled < irc-message ;
11 SYMBOL: string-irc-type-mapping
12 string-irc-type-mapping [ H{ } clone ] initialize
14 : register-irc-message-type ( type string -- )
15 string-irc-type-mapping get set-at ;
17 : irc>type ( string -- irc-message-class )
18 string-irc-type-mapping get at unhandled or ;
20 GENERIC: irc-trailing-slot ( irc-message -- string/f )
21 M: irc-message irc-trailing-slot
24 GENERIC: irc-parameter-slots ( irc-message -- seq )
25 M: irc-message irc-parameter-slots
28 GENERIC: process-irc-trailing ( irc-message -- )
29 M: irc-message process-irc-trailing
30 dup irc-trailing-slot [
31 swap [ trailing>> swap ] [ <mirror> ] bi set-at
34 GENERIC: process-irc-prefix ( irc-message -- )
35 M: irc-message process-irc-prefix
39 : [slot-setter] ( mirror -- quot )
40 '[ [ _ set-at ] [ drop ] if* ] ; inline
43 GENERIC: process-irc-parameters ( irc-message -- )
44 M: irc-message process-irc-parameters
45 dup irc-parameter-slots [
46 swap [ parameters>> swap ] [ <mirror> [slot-setter] ] bi 2each
49 GENERIC: post-process-irc-message ( irc-message -- )
50 M: irc-message post-process-irc-message drop ;
52 GENERIC: fill-irc-message-slots ( irc-message -- )
53 M: irc-message fill-irc-message-slots
56 [ process-irc-trailing ]
57 [ process-irc-prefix ]
58 [ process-irc-parameters ]
59 [ post-process-irc-message ]
62 GENERIC: irc-command-string ( irc-message -- string )
63 M: irc-message irc-command-string drop f ;
65 ! FIXME: inverse of post-process is missing
66 GENERIC: set-irc-parameters ( irc-message -- )
67 M: irc-message set-irc-parameters
68 dup irc-parameter-slots
69 [ over <mirror> '[ _ at ] map >>parameters ] when* drop ;
71 GENERIC: set-irc-trailing ( irc-message -- )
72 M: irc-message set-irc-trailing
73 dup irc-trailing-slot [ over <mirror> at >>trailing ] when* drop ;
75 GENERIC: set-irc-command ( irc-message -- )
76 M: irc-message set-irc-command
77 [ irc-command-string ] [ command<< ] bi ;
79 : irc-message>string ( irc-message -- string )
83 [ parameters>> " " join ]
84 [ trailing>> dup [ CHAR: : prefix ] when ]
85 } cleave 4array sift " " join ;
88 : ?define-irc-parameters ( class slot-names -- )
90 [ \ irc-parameter-slots create-method-in ] dip
91 [ [ "_" = not ] keep and ] map '[ drop _ ] define
94 : ?define-irc-trailing ( class slot-name -- )
96 [ \ irc-trailing-slot create-method-in ] dip
97 first '[ drop _ ] define
100 : define-irc-class ( class params -- )
101 [ { ":" "_" } member? ] reject
102 [ irc-message ] dip define-tuple-class ;
104 : define-irc-parameter-slots ( class params -- )
105 { ":" } split1 [ over ] dip
106 [ ?define-irc-parameters ] [ ?define-irc-trailing ] 2bi* ;
109 #! SYNTAX: name string parameters ;
110 #! IRC: type "COMMAND" slot1 ...;
111 #! IRC: type "COMMAND" slot1 ... : trailing-slot;
114 [ scan-object register-irc-message-type ] keep
116 [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ;