1 ! Copyright (C) 2008 William Schlieper
2 ! See http://factorcode.org/license.txt for BSD license.
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 ;
14 RENAME: join sequences => sjoin
22 TUPLE: ui-window < tabbed client ;
25 client>> terminate-irc ;
27 TUPLE: irc-tab < frame chat client window ;
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 }
35 : dot-or-parens ( string -- string )
37 [ "(" prepend ")" append ] if-empty ;
39 GENERIC: write-irc ( irc-message -- )
42 drop "* Ping" blue write-color ;
45 "<" dark-blue write-color
46 [ irc-message-sender write ] keep
47 "> " dark-blue write-color
51 [ type>> dark-blue write-color ] keep
52 ": " dark-blue write-color
55 TUPLE: own-message message nick timestamp ;
57 : <own-message> ( message nick -- own-message )
60 M: own-message write-irc
61 "<" dark-blue write-color
62 [ nick>> bold font-style associate format ] keep
63 "> " dark-blue write-color
67 "* " dark-green write-color
68 irc-message-sender write
69 " has entered the channel." dark-green write-color ;
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 ;
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 ;
84 "* " dark-red write-color
85 [ irc-message-sender write ] keep
86 " has kicked " dark-red write-color
88 " from the channel" dark-red write-color
89 trailing>> dot-or-parens dark-red write-color ;
92 "* " dark-blue write-color
94 " has applied mode " dark-blue write-color
96 " to " dark-blue write-color
100 "* " dark-blue write-color
101 [ irc-message-sender write ] keep
102 " is now known as " blue write-color
105 M: unhandled write-irc
107 line>> dark-blue write-color ;
110 drop "* You have left IRC" dark-red write-color ;
112 M: irc-disconnected write-irc
113 drop "* Disconnected" dark-red write-color ;
115 M: irc-connected write-irc
116 drop "* Connected" dark-green write-color ;
118 M: irc-chat-end write-irc
121 M: irc-message write-irc
122 "UNIMPLEMENTED" write
123 [ class pprint ] keep
125 line>> dark-blue write-color ;
127 GENERIC: time-happened ( message -- timestamp )
129 M: irc-message time-happened timestamp>> ;
131 M: object time-happened drop now ;
133 : print-irc ( irc-message -- )
134 [ time-happened timestamp>hms write " " write ]
135 [ write-irc nl ] bi ;
137 : send-message ( message -- )
139 [ chat get speak ] bi ;
141 GENERIC: handle-inbox ( tab message -- )
143 : value-labels ( assoc val -- seq )
144 '[ nip _ = ] assoc-filter keys sort-strings [ <label> ] map ;
146 : add-gadget-color ( pack seq color -- pack )
147 '[ _ >>color add-gadget ] each ;
149 M: object handle-inbox
152 : display ( stream tab -- )
154 [ _ dup chat>> hear handle-inbox ]
155 while ] with-output-stream ] "ircv" spawn drop ;
157 : <irc-pane> ( tab -- tab pane )
159 [ <pane-stream> swap display ] 2keep ;
161 TUPLE: irc-editor < editor outstream tab ;
163 : <irc-editor> ( tab pane -- tab editor )
164 irc-editor new-editor
165 swap <pane-stream> >>outstream ;
167 : editor-send ( irc-editor -- )
169 [ [ irc-tab? ] find-parent ]
171 [ "" swap set-editor-string ] } cleave
172 '[ _ irc-tab set _ parse-message ] with-output-stream ;
174 irc-editor "general" f {
175 { T{ key-down f f "RET" } editor-send }
176 { T{ key-down f f "ENTER" } editor-send }
179 : new-irc-tab ( chat ui-window class -- irc-tab )
183 <irc-pane> [ <scroller> @center grid-add ] keep
184 <irc-editor> <scroller> @bottom grid-add ;
187 [ chat>> ] [ window>> client>> ] bi attach-chat ;
192 TUPLE: irc-channel-tab < irc-tab userlist ;
194 : <irc-channel-tab> ( chat ui-window -- irc-tab )
195 irc-channel-tab new-irc-tab
196 <pile> [ <scroller> @right grid-add ] keep >>userlist ;
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 ;
205 M: participant-changed handle-inbox
206 drop update-participants ;
208 TUPLE: irc-server-tab < irc-tab ;
210 : <irc-server-tab> ( chat -- irc-tab )
211 f irc-server-tab new-irc-tab ;
213 : <irc-nick-tab> ( chat ui-window -- irc-tab )
214 irc-tab new-irc-tab ;
219 : join-channel ( name ui-window -- )
220 [ dup <irc-channel-chat> ] dip
221 [ <irc-channel-tab> swap ] keep
224 : query-nick ( nick ui-window -- )
225 [ dup <irc-nick-chat> ] dip
226 [ <irc-nick-tab> swap ] keep
229 : irc-window ( ui-window -- )
231 [ client>> profile>> server>> ] bi
234 : ui-connect ( profile -- ui-window )
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 ]
240 [ connect-irc ] } cleave ;
242 : server-open ( server port nick password channels -- )
243 [ <irc-profile> ui-connect [ irc-window ] keep ] dip
244 [ over join-channel ] each drop ;
246 : main-run ( -- ) run-ircui ;
250 "irc.ui.commands" require