extra/irc/ui/ui.factor

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