extra/irc/client/participants/participants.factor

   1 ! Copyright (C) 2009 Bruno Deferrari
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators irc.client.base
   4 irc.client.chats kernel sequences splitting ;
   5 IN: irc.client.participants
   6
   7 TUPLE: participant nick operator voice ;
   8 : <participant> ( name -- participant )
   9     {
  10         { [ "@" ?head ] [ t f ] }
  11         { [ "+" ?head ] [ f t ] }
  12         [ f f ]
  13     } cond participant boa ;
  14
  15 GENERIC: has-participant? ( name irc-chat -- ? )
  16 M: irc-chat         has-participant? 2drop f ;
  17 M: irc-channel-chat has-participant? participants>> key? ;
  18
  19 : rename-X ( new old assoc quot: ( obj value -- obj ) -- )
  20     '[ delete-at* drop swap @ ] [ nip set-at ] 3bi ; inline
  21
  22 : rename-nick-chat ( new old -- ) irc> chats>> [ >>name ] rename-X ;
  23 : rename-participant ( new old chat -- ) participants>> [ >>nick ] rename-X ;
  24 : part-participant ( nick irc-chat -- ) participants>> delete-at ;
  25 : participant-chats ( nick -- seq ) chats> [ has-participant? ] with filter ;
  26
  27 : quit-participant ( nick -- )
  28     dup participant-chats [ part-participant ] with each ;
  29
  30 : rename-participant* ( new old -- )
  31     [ dup participant-chats [ rename-participant ] 2with each ]
  32     [ dup chat> [ rename-nick-chat ] [ 2drop ] if ]
  33     2bi ;
  34
  35 : join-participant ( nick irc-channel-chat -- )
  36     participants>> [ <participant> dup nick>> ] dip set-at ;
  37
  38 : apply-mode ( ? participant mode -- )
  39     {
  40         { CHAR: o [ operator<< ] }
  41         { CHAR: v [ voice<< ] }
  42         [ 3drop ]
  43     } case ;
  44
  45 : apply-modes ( mode-line participant -- )
  46     [ unclip CHAR: + = ] dip
  47     '[ [ _ _ ] dip apply-mode ] each ;
  48
  49 : change-participant-mode ( mode channel nick -- )
  50     swap chat> participants>> at apply-modes ;
  51
  52 : ?clear-participants ( channel-chat -- )
  53     dup clear-participants>> [
  54         f >>clear-participants participants>> clear-assoc
  55     ] [ drop ] if ;