unmaintained/irc-ui/ui.factor

   1 ! Copyright (C) 2008 William Schlieper
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors kernel threads combinators concurrency.mailboxes
   5        sequences strings hashtables splitting fry assocs hashtables colors
   6        sorting unicode math.order
   7        ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
   8        ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
   9        ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
  10        io io.styles namespaces calendar calendar.format models continuations
  11        irc.client irc.client.private irc.messages
  12        irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;
  13
  14 RENAME: join sequences => sjoin
  15
  16 IN: irc.ui
  17
  18 SYMBOL: chat
  19
  20 SYMBOL: client
  21
  22 TUPLE: ui-window < tabbed client ;
  23
  24 M: ui-window ungraft*
  25     client>> terminate-irc ;
  26
  27 TUPLE: irc-tab < frame chat client window ;
  28
  29 : write-color ( str color -- )
  30     foreground associate format ;
  31 CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 }
  32 CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 }
  33 CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 }
  34
  35 : dot-or-parens ( string -- string )
  36     [ "." ]
  37     [ "(" prepend ")" append ] if-empty ;
  38
  39 GENERIC: write-irc ( irc-message -- )
  40
  41 M: ping write-irc
  42     drop "* Ping" blue write-color ;
  43
  44 M: privmsg write-irc
  45     "<" dark-blue write-color
  46     [ irc-message-sender write ] keep
  47     "> " dark-blue write-color
  48     trailing>> write ;
  49
  50 M: notice write-irc
  51     [ type>> dark-blue write-color ] keep
  52     ": " dark-blue write-color
  53     trailing>> write ;
  54
  55 TUPLE: own-message message nick timestamp ;
  56
  57 : <own-message> ( message nick -- own-message )
  58     now own-message boa ;
  59
  60 M: own-message write-irc
  61     "<" dark-blue write-color
  62     [ nick>> bold font-style associate format ] keep
  63     "> " dark-blue write-color
  64     message>> write ;
  65
  66 M: join write-irc
  67     "* " dark-green write-color
  68     irc-message-sender write
  69     " has entered the channel." dark-green write-color ;
  70
  71 M: part write-irc
  72     "* " dark-red write-color
  73     [ irc-message-sender write ] keep
  74     " has left the channel" dark-red write-color
  75     trailing>> dot-or-parens dark-red write-color ;
  76
  77 M: quit write-irc
  78     "* " dark-red write-color
  79     [ irc-message-sender write ] keep
  80     " has left IRC" dark-red write-color
  81     trailing>> dot-or-parens dark-red write-color ;
  82
  83 M: kick write-irc
  84     "* " dark-red write-color
  85     [ irc-message-sender write ] keep
  86     " has kicked " dark-red write-color
  87     [ who>> write ] keep
  88     " from the channel" dark-red write-color
  89     trailing>> dot-or-parens dark-red write-color ;
  90
  91 M: mode write-irc
  92     "* " dark-blue write-color
  93     [ name>> write ] keep
  94     " has applied mode " dark-blue write-color
  95     [ mode>> write ] keep
  96     " to " dark-blue write-color
  97     parameter>> write ;
  98
  99 M: nick write-irc
 100     "* " dark-blue write-color
 101     [ irc-message-sender write ] keep
 102     " is now known as " blue write-color
 103     trailing>> write ;
 104
 105 M: unhandled write-irc
 106     "UNHANDLED: " write
 107     line>> dark-blue write-color ;
 108
 109 M: irc-end write-irc
 110     drop "* You have left IRC" dark-red write-color ;
 111
 112 M: irc-disconnected write-irc
 113     drop "* Disconnected" dark-red write-color ;
 114
 115 M: irc-connected write-irc
 116     drop "* Connected" dark-green write-color ;
 117
 118 M: irc-chat-end write-irc
 119     drop ;
 120
 121 M: irc-message write-irc
 122     "UNIMPLEMENTED" write
 123     [ class pprint ] keep
 124     ": " write
 125     line>> dark-blue write-color ;
 126
 127 GENERIC: time-happened ( message -- timestamp )
 128
 129 M: irc-message time-happened timestamp>> ;
 130
 131 M: object time-happened drop now ;
 132
 133 : print-irc ( irc-message -- )
 134     [ time-happened timestamp>hms write " " write ]
 135     [ write-irc nl ] bi ;
 136
 137 : send-message ( message -- )
 138     [ print-irc ]
 139     [ chat get speak ] bi ;
 140
 141 GENERIC: handle-inbox ( tab message -- )
 142
 143 : value-labels ( assoc val -- seq )
 144     '[ nip _ = ] assoc-filter keys sort-strings [ <label> ] map ;
 145
 146 : add-gadget-color ( pack seq color -- pack )
 147     '[ _ >>color add-gadget ] each ;
 148
 149 M: object handle-inbox
 150     nip print-irc ;
 151
 152 : display ( stream tab -- )
 153     '[ _ [ [ t ]
 154            [ _ dup chat>> hear handle-inbox ]
 155            while ] with-output-stream ] "ircv" spawn drop ;
 156
 157 : <irc-pane> ( tab -- tab pane )
 158     <scrolling-pane>
 159     [ <pane-stream> swap display ] 2keep ;
 160
 161 TUPLE: irc-editor < editor outstream tab ;
 162
 163 : <irc-editor> ( tab pane -- tab editor )
 164     irc-editor new-editor
 165     swap <pane-stream> >>outstream ;
 166
 167 : editor-send ( irc-editor -- )
 168     { [ outstream>> ]
 169       [ [ irc-tab? ] find-parent ]
 170       [ editor-string ]
 171       [ "" swap set-editor-string ] } cleave
 172      '[ _ irc-tab set _ parse-message ] with-output-stream ;
 173
 174 irc-editor "general" f {
 175     { T{ key-down f f "RET" } editor-send }
 176     { T{ key-down f f "ENTER" } editor-send }
 177 } define-command-map
 178
 179 : new-irc-tab ( chat ui-window class -- irc-tab )
 180     new-frame
 181     swap >>window
 182     swap >>chat
 183     <irc-pane> [ <scroller> @center grid-add ] keep
 184     <irc-editor> <scroller> @bottom grid-add ;
 185
 186 M: irc-tab graft*
 187     [ chat>> ] [ window>> client>> ] bi attach-chat ;
 188
 189 M: irc-tab ungraft*
 190     chat>> detach-chat ;
 191
 192 TUPLE: irc-channel-tab < irc-tab userlist ;
 193
 194 : <irc-channel-tab> ( chat ui-window -- irc-tab )
 195     irc-channel-tab new-irc-tab
 196     <pile> [ <scroller> @right grid-add ] keep >>userlist ;
 197
 198 : update-participants ( tab -- )
 199     [ userlist>> [ clear-gadget ] keep ]
 200     [ chat>> participants>> ] bi
 201     [ +operator+ value-labels dark-green add-gadget-color ]
 202     [ +voice+ value-labels blue add-gadget-color ]
 203     [ +normal+ value-labels black add-gadget-color ] tri drop ;
 204
 205 M: participant-changed handle-inbox
 206     drop update-participants ;
 207
 208 TUPLE: irc-server-tab < irc-tab ;
 209
 210 : <irc-server-tab> ( chat -- irc-tab )
 211     f irc-server-tab new-irc-tab ;
 212
 213 : <irc-nick-tab> ( chat ui-window -- irc-tab )
 214     irc-tab new-irc-tab ;
 215
 216 M: irc-tab pref-dim*
 217     drop { 480 480 } ;
 218
 219 : join-channel ( name ui-window -- )
 220     [ dup <irc-channel-chat> ] dip
 221     [ <irc-channel-tab> swap ] keep
 222     add-page ;
 223
 224 : query-nick ( nick ui-window -- )
 225     [ dup <irc-nick-chat> ] dip
 226     [ <irc-nick-tab> swap ] keep
 227     add-page ;
 228
 229 : irc-window ( ui-window -- )
 230     [ ]
 231     [ client>> profile>> server>> ] bi
 232     open-window ;
 233
 234 : ui-connect ( profile -- ui-window )
 235     <irc-client>
 236     { [ [ <irc-server-chat> ] dip attach-chat ]
 237       [ chats>> +server-chat+ swap at <irc-server-tab> dup
 238         "Server" associate ui-window new-tabbed [ swap window<< ] keep ]
 239       [ >>client ]
 240       [ connect-irc ] } cleave ;
 241
 242 : server-open ( server port nick password channels -- )
 243     [ <irc-profile> ui-connect [ irc-window ] keep ] dip
 244     [ over join-channel ] each drop ;
 245
 246 : main-run ( -- ) run-ircui ;
 247
 248 MAIN: main-run
 249
 250 "irc.ui.commands" require