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\r
   6        ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
   7        ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
   8        ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
   9        io io.styles namespaces calendar calendar.format models continuations\r
  10        irc.client irc.client.private irc.messages irc.messages.private\r
  11        irc.ui.commandparser irc.ui.load qualified ;\r
  12 \r
  13 RENAME: join sequences => sjoin\r
  14 \r
  15 IN: irc.ui\r
  16 \r
  17 SYMBOL: listener\r
  18 \r
  19 SYMBOL: client\r
  20 \r
  21 TUPLE: ui-window client tabs ;\r
  22 \r
  23 TUPLE: irc-tab < frame listener client userlist ;\r
  24 \r
  25 : write-color ( str color -- )\r
  26     foreground associate format ;\r
  27 : red { 0.5 0 0 1 } ;\r
  28 : green { 0 0.5 0 1 } ;\r
  29 : blue { 0 0 1 1 } ;\r
  30 : black { 0 0 0 1 } ;\r
  31 \r
  32 : colors H{ { +operator+ { 0 0.5 0 1 } }\r
  33             { +voice+ { 0 0 1 1 } }\r
  34             { +normal+ { 0 0 0 1 } } } ;\r
  35 \r
  36 : dot-or-parens ( string -- string )\r
  37     dup empty? [ drop "." ]\r
  38     [ "(" prepend ")" append ] if ;\r
  39 \r
  40 GENERIC: write-irc ( irc-message -- )\r
  41 \r
  42 M: privmsg write-irc\r
  43     "<" blue write-color\r
  44     [ prefix>> parse-name write ] keep\r
  45     "> " blue write-color\r
  46     trailing>> write ;\r
  47 \r
  48 TUPLE: own-message message nick timestamp ;\r
  49 \r
  50 : <own-message> ( message nick -- own-message )\r
  51     now own-message boa ;\r
  52 \r
  53 M: own-message write-irc\r
  54     "<" blue write-color\r
  55     [ nick>> bold font-style associate format ] keep\r
  56     "> " blue write-color\r
  57     message>> write ;\r
  58 \r
  59 M: join write-irc\r
  60     "* " green write-color\r
  61     prefix>> parse-name write\r
  62     " has entered the channel." green write-color ;\r
  63 \r
  64 M: part write-irc\r
  65     "* " red write-color\r
  66     [ prefix>> parse-name write ] keep\r
  67     " has left the channel" red write-color\r
  68     trailing>> dot-or-parens red write-color ;\r
  69 \r
  70 M: quit write-irc\r
  71     "* " red write-color\r
  72     [ prefix>> parse-name write ] keep\r
  73     " has left IRC" red write-color\r
  74     trailing>> dot-or-parens red write-color ;\r
  75 \r
  76 : full-mode ( message -- mode )\r
  77     parameters>> rest " " sjoin ;\r
  78 \r
  79 M: mode write-irc\r
  80     "* " blue write-color\r
  81     [ prefix>> parse-name write ] keep\r
  82     " has applied mode " blue write-color\r
  83     [ full-mode write ] keep\r
  84     " to " blue write-color\r
  85     channel>> write ;\r
  86 \r
  87 M: unhandled write-irc\r
  88     "UNHANDLED: " write\r
  89     line>> blue write-color ;\r
  90 \r
  91 M: irc-end write-irc\r
  92     drop "* You have left IRC" red write-color ;\r
  93 \r
  94 M: irc-disconnected write-irc\r
  95     drop "* Disconnected" red write-color ;\r
  96 \r
  97 M: irc-connected write-irc\r
  98     drop "* Connected" green write-color ;\r
  99 \r
 100 M: irc-listener-end write-irc\r
 101     drop ;\r
 102 \r
 103 M: irc-message write-irc\r
 104     drop ; ! catch all unimplemented writes, THIS WILL CHANGE    \r
 105 \r
 106 : time-happened ( irc-message -- timestamp )\r
 107     [ timestamp>> ] [ 2drop now ] recover ;\r
 108 \r
 109 : print-irc ( irc-message -- )\r
 110     [ time-happened timestamp>hms write " " write ]\r
 111     [ write-irc nl ] bi ;\r
 112 \r
 113 : send-message ( message -- )\r
 114     [ print-irc ]\r
 115     [ listener get write-message ] bi ;\r
 116 \r
 117 GENERIC: handle-inbox ( tab message -- )\r
 118 \r
 119 : filter-participants ( pack alist val color -- )\r
 120    '[ , = [ <label> , >>color add-gadget ] [ drop ] if ] assoc-each ;\r
 121 \r
 122 : update-participants ( tab -- )\r
 123     [ userlist>> [ clear-gadget ] keep ]\r
 124     [ listener>> participants>> ] bi\r
 125     [ +operator+ green filter-participants ]\r
 126     [ +voice+ blue filter-participants ]\r
 127     [ +normal+ black filter-participants ] 2tri ;\r
 128 \r
 129 M: participant-changed handle-inbox\r
 130     drop update-participants ;\r
 131 \r
 132 M: object handle-inbox\r
 133     nip print-irc ;\r
 134 \r
 135 : display ( stream tab -- )\r
 136     '[ , [ [ t ]\r
 137            [ , dup listener>> read-message handle-inbox ]\r
 138            [  ] while ] with-output-stream ] "ircv" spawn drop ;\r
 139 \r
 140 : <irc-pane> ( tab -- tab pane )\r
 141     <scrolling-pane>\r
 142     [ <pane-stream> swap display ] 2keep ;\r
 143 \r
 144 TUPLE: irc-editor < editor outstream listener client ;\r
 145 \r
 146 : <irc-editor> ( tab pane -- tab editor )\r
 147     over irc-editor new-editor\r
 148     swap listener>> >>listener swap <pane-stream> >>outstream\r
 149     over client>> >>client ;\r
 150 \r
 151 : editor-send ( irc-editor -- )\r
 152     { [ outstream>> ]\r
 153       [ listener>> ]\r
 154       [ client>> ]\r
 155       [ editor-string ]\r
 156       [ "" swap set-editor-string ] } cleave\r
 157      '[ , listener set , client set , parse-message ] with-output-stream ;\r
 158 \r
 159 irc-editor "general" f {\r
 160     { T{ key-down f f "RET" } editor-send }\r
 161     { T{ key-down f f "ENTER" } editor-send }\r
 162 } define-command-map\r
 163 \r
 164 : <irc-tab> ( listener client -- irc-tab )\r
 165     irc-tab new-frame\r
 166     swap client>> >>client swap >>listener\r
 167     <irc-pane> [ <scroller> @center grid-add ] keep\r
 168     <irc-editor> <scroller> @bottom grid-add ;\r
 169 \r
 170 : <irc-channel-tab> ( listener client -- irc-tab )\r
 171     <irc-tab>\r
 172     <pile> [ <scroller> @right grid-add ] keep >>userlist ;\r
 173 \r
 174 : <irc-server-tab> ( listener client -- irc-tab )\r
 175     <irc-tab> ;\r
 176 \r
 177 M: irc-tab graft*\r
 178     [ listener>> ] [ client>> ] bi add-listener ;\r
 179 \r
 180 M: irc-tab ungraft*\r
 181     [ listener>> ] [ client>> ] bi remove-listener ;\r
 182 \r
 183 M: irc-tab pref-dim*\r
 184     drop { 480 480 } ;\r
 185 \r
 186 : join-channel ( name ui-window -- )\r
 187     [ dup <irc-channel-listener> ] dip\r
 188     [ <irc-channel-tab> swap ] keep\r
 189     tabs>> add-page ;\r
 190 \r
 191 : irc-window ( ui-window -- )\r
 192     [ tabs>> ]\r
 193     [ client>> profile>> server>> ] bi\r
 194     open-window ;\r
 195 \r
 196 : ui-connect ( profile -- ui-window )\r
 197     <irc-client> ui-window new over >>client swap\r
 198     [ connect-irc ]\r
 199     [ [ <irc-server-listener> ] dip add-listener ]\r
 200     [ listeners>> +server-listener+ swap at over <irc-tab>\r
 201       "Server" associate <tabbed> >>tabs ] tri ;\r
 202 \r
 203 : server-open ( server port nick password channels -- )\r
 204     [ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
 205     [ over join-channel ] each drop ;\r
 206 \r
 207 : main-run ( -- ) run-ircui ;\r
 208 \r
 209 MAIN: main-run\r