extra/irc/messages/base/base.factor

   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 ;
   6 IN: irc.messages.base
   7
   8 TUPLE: irc-message line prefix command parameters trailing timestamp sender ;
   9 TUPLE: unhandled < irc-message ;
  10
  11 SYMBOL: string-irc-type-mapping
  12 string-irc-type-mapping [ H{ } clone ] initialize
  13
  14 : register-irc-message-type ( type string -- )
  15     string-irc-type-mapping get set-at ;
  16
  17 : irc>type ( string -- irc-message-class )
  18     string-irc-type-mapping get at unhandled or ;
  19
  20 GENERIC: irc-trailing-slot ( irc-message -- string/f )
  21 M: irc-message irc-trailing-slot
  22     drop f ;
  23
  24 GENERIC: irc-parameter-slots ( irc-message -- seq )
  25 M: irc-message irc-parameter-slots
  26     drop f ;
  27
  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
  32     ] [ drop ] if* ;
  33
  34 GENERIC: process-irc-prefix ( irc-message -- )
  35 M: irc-message process-irc-prefix
  36     drop ;
  37
  38 <PRIVATE
  39 : [slot-setter] ( mirror -- quot )
  40     '[ [ _ set-at ] [ drop ] if* ] ; inline
  41 PRIVATE>
  42
  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
  47     ] [ drop ] if* ;
  48
  49 GENERIC: post-process-irc-message ( irc-message -- )
  50 M: irc-message post-process-irc-message drop ;
  51
  52 GENERIC: fill-irc-message-slots ( irc-message -- )
  53 M: irc-message fill-irc-message-slots
  54     gmt >>timestamp
  55     {
  56         [ process-irc-trailing ]
  57         [ process-irc-prefix ]
  58         [ process-irc-parameters ]
  59         [ post-process-irc-message ]
  60     } cleave ;
  61
  62 GENERIC: irc-command-string ( irc-message -- string )
  63 M: irc-message irc-command-string drop f ;
  64
  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 ;
  70
  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 ;
  74
  75 GENERIC: set-irc-command ( irc-message -- )
  76 M: irc-message set-irc-command
  77     [ irc-command-string ] [ command<< ] bi ;
  78
  79 : irc-message>string ( irc-message -- string )
  80     {
  81         [ prefix>> ]
  82         [ command>> ]
  83         [ parameters>> " " join ]
  84         [ trailing>> dup [ CHAR: : prefix ] when ]
  85     } cleave 4array sift " " join ;
  86
  87 <PRIVATE
  88 : ?define-irc-parameters ( class slot-names -- )
  89     dup empty? not [
  90         [ \ irc-parameter-slots create-method-in ] dip
  91         [ [ "_" = not ] keep and ] map '[ drop _ ] define
  92     ] [ 2drop ] if ;
  93
  94 : ?define-irc-trailing ( class slot-name -- )
  95     [
  96         [ \ irc-trailing-slot create-method-in ] dip
  97         first '[ drop _ ] define
  98     ] [ drop ] if* ;
  99
 100 : define-irc-class ( class params -- )
 101     [ { ":" "_" } member? not ] filter
 102     [ irc-message ] dip define-tuple-class ;
 103
 104 : define-irc-parameter-slots ( class params -- )
 105     { ":" } split1 [ over ] dip
 106     [ ?define-irc-parameters ] [ ?define-irc-trailing ] 2bi* ;
 107 PRIVATE>
 108
 109 #! SYNTAX: name string parameters ;
 110 #! IRC: type "COMMAND" slot1 ...;
 111 #! IRC: type "COMMAND" slot1 ... : trailing-slot;
 112 SYNTAX: IRC:
 113     scan-new-class
 114     [ scan-object register-irc-message-type ] keep
 115     ";" parse-tokens
 116     [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ;