1 ! Copyright (C) 2008 William Schlieper
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
4 USING: accessors kernel threads combinators concurrency.mailboxes
\r
5 sequences strings hashtables splitting fry assocs hashtables colors
\r
6 sorting qualified 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 ;
\r
14 RENAME: join sequences => sjoin
\r
22 TUPLE: ui-window < tabbed client ;
\r
24 M: ui-window ungraft*
\r
25 client>> terminate-irc ;
\r
27 TUPLE: irc-tab < frame listener client window ;
\r
29 : write-color ( str color -- )
\r
30 foreground associate format ;
\r
31 : dark-red T{ rgba f 0.5 0.0 0.0 1 } ;
\r
32 : dark-green T{ rgba f 0.0 0.5 0.0 1 } ;
\r
34 : dot-or-parens ( string -- string )
\r
36 [ "(" prepend ")" append ] if-empty ;
\r
38 GENERIC: write-irc ( irc-message -- )
\r
41 drop "* Ping" blue write-color ;
\r
43 M: privmsg write-irc
\r
44 "<" blue write-color
\r
45 [ irc-message-sender write ] keep
\r
46 "> " blue write-color
\r
50 [ type>> blue write-color ] keep
\r
51 ": " blue write-color
\r
54 TUPLE: own-message message nick timestamp ;
\r
56 : <own-message> ( message nick -- own-message )
\r
57 now own-message boa ;
\r
59 M: own-message write-irc
\r
60 "<" blue write-color
\r
61 [ nick>> bold font-style associate format ] keep
\r
62 "> " blue write-color
\r
66 "* " dark-green write-color
\r
67 irc-message-sender write
\r
68 " has entered the channel." dark-green write-color ;
\r
71 "* " dark-red write-color
\r
72 [ irc-message-sender write ] keep
\r
73 " has left the channel" dark-red write-color
\r
74 trailing>> dot-or-parens dark-red write-color ;
\r
77 "* " dark-red write-color
\r
78 [ irc-message-sender write ] keep
\r
79 " has left IRC" dark-red write-color
\r
80 trailing>> dot-or-parens dark-red write-color ;
\r
83 "* " dark-red write-color
\r
84 [ irc-message-sender write ] keep
\r
85 " has kicked " dark-red write-color
\r
86 [ who>> write ] keep
\r
87 " from the channel" dark-red write-color
\r
88 trailing>> dot-or-parens dark-red write-color ;
\r
90 : full-mode ( message -- mode )
\r
91 parameters>> rest " " sjoin ;
\r
94 "* " blue write-color
\r
95 [ irc-message-sender write ] keep
\r
96 " has applied mode " blue write-color
\r
97 [ full-mode write ] keep
\r
98 " to " blue write-color
\r
102 "* " blue write-color
\r
103 [ irc-message-sender write ] keep
\r
104 " is now known as " blue write-color
\r
107 M: unhandled write-irc
\r
108 "UNHANDLED: " write
\r
109 line>> blue write-color ;
\r
111 M: irc-end write-irc
\r
112 drop "* You have left IRC" dark-red write-color ;
\r
114 M: irc-disconnected write-irc
\r
115 drop "* Disconnected" dark-red write-color ;
\r
117 M: irc-connected write-irc
\r
118 drop "* Connected" dark-green write-color ;
\r
120 M: irc-listener-end write-irc
\r
123 M: irc-message write-irc
\r
124 drop ; ! catch all unimplemented writes, THIS WILL CHANGE
\r
126 GENERIC: time-happened ( message -- timestamp )
\r
128 M: irc-message time-happened timestamp>> ;
\r
130 M: object time-happened drop now ;
\r
132 : print-irc ( irc-message -- )
\r
133 [ time-happened timestamp>hms write " " write ]
\r
134 [ write-irc nl ] bi ;
\r
136 : send-message ( message -- )
\r
138 [ listener get write-message ] bi ;
\r
140 GENERIC: handle-inbox ( tab message -- )
\r
142 : value-labels ( assoc val -- seq )
\r
143 '[ nip , = ] assoc-filter keys sort-strings [ <label> ] map ;
\r
145 : add-gadget-color ( pack seq color -- pack )
\r
146 '[ , >>color add-gadget ] each ;
\r
148 M: object handle-inbox
\r
151 : display ( stream tab -- )
\r
153 [ , dup listener>> read-message handle-inbox ]
\r
154 [ ] while ] with-output-stream ] "ircv" spawn drop ;
\r
156 : <irc-pane> ( tab -- tab pane )
\r
158 [ <pane-stream> swap display ] 2keep ;
\r
160 TUPLE: irc-editor < editor outstream tab ;
\r
162 : <irc-editor> ( tab pane -- tab editor )
\r
163 irc-editor new-editor
\r
164 swap <pane-stream> >>outstream ;
\r
166 : editor-send ( irc-editor -- )
\r
168 [ [ irc-tab? ] find-parent ]
\r
170 [ "" swap set-editor-string ] } cleave
\r
171 '[ , irc-tab set , parse-message ] with-output-stream ;
\r
173 irc-editor "general" f {
\r
174 { T{ key-down f f "RET" } editor-send }
\r
175 { T{ key-down f f "ENTER" } editor-send }
\r
176 } define-command-map
\r
178 : new-irc-tab ( listener ui-window class -- irc-tab )
\r
182 <irc-pane> [ <scroller> @center grid-add ] keep
\r
183 <irc-editor> <scroller> @bottom grid-add ;
\r
186 [ listener>> ] [ window>> client>> ] bi add-listener ;
\r
188 M: irc-tab ungraft*
\r
189 [ listener>> ] [ window>> client>> ] bi remove-listener ;
\r
191 TUPLE: irc-channel-tab < irc-tab userlist ;
\r
193 : <irc-channel-tab> ( listener ui-window -- irc-tab )
\r
194 irc-channel-tab new-irc-tab
\r
195 <pile> [ <scroller> @right grid-add ] keep >>userlist ;
\r
197 : update-participants ( tab -- )
\r
198 [ userlist>> [ clear-gadget ] keep ]
\r
199 [ listener>> participants>> ] bi
\r
200 [ +operator+ value-labels dark-green add-gadget-color ]
\r
201 [ +voice+ value-labels blue add-gadget-color ]
\r
202 [ +normal+ value-labels black add-gadget-color ] tri drop ;
\r
204 M: participant-changed handle-inbox
\r
205 drop update-participants ;
\r
207 TUPLE: irc-server-tab < irc-tab ;
\r
209 : <irc-server-tab> ( listener -- irc-tab )
\r
210 f irc-server-tab new-irc-tab ;
\r
212 : <irc-nick-tab> ( listener ui-window -- irc-tab )
\r
213 irc-tab new-irc-tab ;
\r
215 M: irc-tab pref-dim*
\r
218 : join-channel ( name ui-window -- )
\r
219 [ dup <irc-channel-listener> ] dip
\r
220 [ <irc-channel-tab> swap ] keep
\r
223 : query-nick ( nick ui-window -- )
\r
224 [ dup <irc-nick-listener> ] dip
\r
225 [ <irc-nick-tab> swap ] keep
\r
228 : irc-window ( ui-window -- )
\r
230 [ client>> profile>> server>> ] bi
\r
233 : ui-connect ( profile -- ui-window )
\r
235 { [ [ <irc-server-listener> ] dip add-listener ]
\r
236 [ listeners>> +server-listener+ swap at <irc-server-tab> dup
\r
237 "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]
\r
239 [ connect-irc ] } cleave ;
\r
241 : server-open ( server port nick password channels -- )
\r
242 [ <irc-profile> ui-connect [ irc-window ] keep ] dip
\r
243 [ over join-channel ] each drop ;
\r
245 : main-run ( -- ) run-ircui ;
\r