Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/eXene/widgets/text/vtty.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/widgets/text/vtty.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download)

1 : monnier 2 (* vtty.sml
2 :     *
3 :     * COPYRIGHT (c) 1991 by AT&T Bell Laboratories. See COPYRIGHT file for details.
4 :     *
5 :     * A simple virtual terminal built on top of the text widget. This supports
6 :     * an interface that is compatible with the TextIO structure in CML.
7 :     *
8 :     * TODO:
9 :     * Flow control (^S/^Q)
10 :     * User-defined erase, kill, etc.
11 :     *)
12 :    
13 :     structure Vtty : VTTY =
14 :     struct
15 :    
16 :     structure TextIO = TextIO
17 :     structure W = Widget
18 :    
19 :     open CML Widget
20 :    
21 :     datatype vtty = VTTY of {
22 :     widget : widget,
23 :     instrm : TextIO.instream,
24 :     outstrm : TextIO.outstream
25 :     }
26 :    
27 :     local
28 :     val tabStop = 8
29 :     fun expandTab col = let
30 :     val s = " "
31 :     val lenS = String.size s
32 :     fun expand i = if (i <= lenS)
33 :     then substring(s, 0, i)
34 :     else s ^ (expand (i - lenS))
35 :     in
36 :     expand (tabStop - Int.rem(col, tabStop))
37 :     end
38 :    
39 :     datatype draw_cmd = Erase | Draw of string
40 :    
41 :     (** the echo server **
42 :     * The echo server monitors the stream of keyboard events and echos
43 :     * keystrokes on the terminal and forwards completed lines to the
44 :     * instream buffer.
45 :     *)
46 :     fun mkEchoServer (keyEvt, trans, drawCh, putData) = let
47 :     open Interact
48 :     fun beep () = () (** NOP for now **)
49 :     val look = lookupString trans
50 :     fun loop curLine = (case (msgBodyOf (sync keyEvt))
51 :     of (KEY_Press arg) => let
52 :     fun tab () = (
53 :     send (drawCh, Draw "\t");
54 :     loop (#"\t" :: curLine))
55 :     fun newLine () = (
56 :     send (drawCh, Draw "\n");
57 :     putData (implode (rev (#"\n"::curLine)));
58 :     loop [])
59 :     fun erase () = loop (case curLine
60 :     of [] => (beep(); [])
61 :     | (c::r) => (send (drawCh, Erase); r))
62 :     fun flowOn () = loop curLine (** NOP for now **)
63 :     fun flowOff () = loop curLine (** NOP for now **)
64 :     in
65 :     case ((look arg) handle _ => "")
66 :     of "" => loop curLine
67 :     | "\t" => tab()
68 :     | "\^M" => newLine() (* <cr> mapped to newline *)
69 :     | "\n" => newLine()
70 :     | "\127" => erase() (* <del> mapped to backspace *)
71 :     | "\008" => erase()
72 :     | "\^Q" => flowOn()
73 :     | "\^S" => flowOff()
74 :     | s => (
75 :     send (drawCh, Draw s);
76 :     loop ((explode s) @ curLine))
77 :     end
78 :     | _ => loop curLine)
79 :     in
80 :     spawn (fn () => loop []);
81 :     ()
82 :     end (* mkEchoServer *)
83 :    
84 :    
85 :     (** the text history buffer **
86 :     * this buffers complete lines of text for redisplay when the widget is resized.
87 :     *)
88 :     datatype history_req
89 :     = SetLen of int
90 :     | PushLn of string
91 :     | MapText of {nlines : int, ln_wid : int}
92 :    
93 :     datatype history_buf = HB of {
94 :     req_ch : history_req chan,
95 :     reply_ch : string list chan
96 :     }
97 :    
98 :     fun mkHistoryBuf len = let
99 :     val reqCh = channel() and replyCh = channel()
100 :     fun config (maxLen, initRear) = let
101 :     fun prefix (0, l) = []
102 :     | prefix (_, []) = []
103 :     | prefix (n, x::r) = x :: prefix(n-1, r)
104 :     fun shift ([], []) = ([], [])
105 :     | shift ([], rear) = shift(rev rear, [])
106 :     | shift (_::front, rear) = (front, rear)
107 :     fun server (n, front, rear) = (case (recv reqCh)
108 :     of (SetLen len) => config (len, prefix (len, rear@(rev front)))
109 :     | (PushLn s) => if (n < maxLen)
110 :     then server (n+1, front, s::rear)
111 :     else let
112 :     val (front, rear) = shift (front, rear)
113 :     in
114 :     server (n, front, s::rear)
115 :     end
116 :     | (MapText{nlines, ln_wid}) => let
117 :     fun getLines (_, [], lines) = lines
118 :     | getLines (0, _, lines) = lines
119 :     | getLines (n, s::r, lines) = let
120 :     val len = size s
121 :     fun getLn (0, _, lines) = lines
122 :     | getLn (n, 0, lines) = getLines(n, r, lines)
123 :     | getLn (n, i, lines) =
124 :     getLn (n-1, i-ln_wid,
125 :     substring(s, i-ln_wid, ln_wid)::lines)
126 :     in
127 :     if (len > ln_wid)
128 :     then let
129 :     val tailLen = Int.rem(len, ln_wid)
130 :     val i = (len - tailLen)
131 :     in
132 :     getLn (n-1, i,
133 :     substring(s, i, tailLen)::lines)
134 :     end
135 :     else getLines (n-1, r, s::lines)
136 :     end
137 :     in
138 :     send(replyCh, getLines(nlines, rear@(rev front), []));
139 :     server (n, front, rear)
140 :     end
141 :     (* end case *))
142 :     in
143 :     server (List.length initRear, [], initRear)
144 :     end
145 :     in
146 :     spawn (fn () => config(len, []));
147 :     HB{req_ch = reqCh, reply_ch = replyCh}
148 :     end (* mkHistoryBuf *)
149 :    
150 :     (* push a line into a history buffer *)
151 :     fun pushLine (HB{req_ch, ...}, ln) = send(req_ch, PushLn ln)
152 :    
153 :     (* set the length of a history buffer *)
154 :     fun setLength (HB{req_ch, ...}, len) =
155 :     if (len <= 0) then send(req_ch, SetLen 1) else send(req_ch, SetLen len)
156 :    
157 :     (* map the maximum suffix (that will fit) of a history buffer onto a
158 :     * rectangular array of characters. The suffix is returned as a list
159 :     * of at most "numLines" strings, each string being at most "lineWid"
160 :     * characters. The strings are in top-down order.
161 :     *)
162 :     fun mapText (HB{req_ch, reply_ch}, numLines, lineWid) = (
163 :     send(req_ch, MapText{nlines=numLines, ln_wid=lineWid});
164 :     recv reply_ch)
165 :    
166 :    
167 :     (** the draw server **
168 :     * The draw server receives strings from the output stream and the echo
169 :     * server. It draws the text for these strings and merges them into
170 :     * complete lines of text, which are buffered in a text history buffer.
171 :     *)
172 :     fun mkDrawServer (tw, getDataEvt, echoCh, cmdInEvt, twCmdCh) = let
173 :     val setCursor = TextWidget.moveCursor tw
174 :     fun write (r,c,s)= TextWidget.writeText tw
175 :     {at=TextWidget.ChrCrd{col=c,row=r},text=s}
176 :     val scrollUp = TextWidget.scrollUp tw
177 :     fun clearToEOL (r,c) = TextWidget.clearToEOL tw (TextWidget.ChrCrd{col=c,row=r})
178 :     fun clear() = TextWidget.clearToEOS tw (TextWidget.ChrCrd{col=0,row=0})
179 :     val hb = mkHistoryBuf 0
180 :     val echoEvt = recvEvt echoCh
181 :     fun fillText l = let val row = ref 0
182 :     val _ = clear()
183 :     in app (fn s => (write(!row,0,s); row := !row+1)) l
184 :     end
185 :     fun config (curLnLen, curLn) = let
186 :     val {rows, cols} = TextWidget.charSizeOf tw
187 :     val _ = setLength (hb, rows-1)
188 :     val text = mapText (hb, rows-1, cols)
189 :     val row = length text
190 :     val col = length curLn
191 :     fun redrawCurLn l = let
192 :     fun f (_, []) = ()
193 :     | f (i, ln::r) = write (row, i, String.str ln)
194 :     in
195 :     f (0, l)
196 :     end
197 :     (*** TYAN CODE:
198 :     fun redrawCurLn l = app (fn i => write (row, i, nth (l, i)))
199 :     (0 thru col)
200 :     ***)
201 :     (*** I moved the following into the body of the let
202 :     val _ = fillText text;
203 :     val _ = redrawCurLn (rev curLn);
204 :     ***)
205 :     (* keep track if there is any user input on the line. We allow
206 :     * user input to follow output on the same line.
207 :     *)
208 :     fun server (arg as (cursorR, cursorC, curLnLen, curLn)) = let
209 :     open Interact
210 :     fun handleOutput s = server (List.foldl
211 :     (fn (c, (row,col,len,ln)) => case c
212 :     of #"\^M" => (pushLine(hb, implode (rev ln));
213 :     (row+1,0,len,[]))
214 :     | #"\n" => (pushLine(hb, implode (rev ln));
215 :     (row+1,0,len,[]))
216 :     | _ => (write (row,col,String.str c);
217 :     (row,col+1,len,c::ln)))
218 :     arg (explode s))
219 :     fun handleEcho Erase =
220 :     if (cursorC > 0)
221 :     then (
222 :     write (cursorR,cursorC-1," ");
223 :     server (cursorR,cursorC-1,curLnLen,tl curLn))
224 :     else server arg
225 :     | handleEcho (Draw s) = handleOutput s
226 :     fun handleCmd msg = (send (twCmdCh,msg);
227 :     case (msgBodyOf msg)
228 :     of (CI_Resize _) => config(curLnLen, curLn)
229 :     | _ => server arg
230 :     (* end case *))
231 :     in
232 :     if (cursorR >= rows)
233 :     then (
234 :     scrollUp {from=rows-1,nlines=1};
235 :     server (cursorR-1,cursorC,curLnLen,curLn))
236 :     else select [
237 :     wrap (getDataEvt, handleOutput),
238 :     wrap (echoEvt, handleEcho),
239 :     wrap (cmdInEvt, handleCmd)
240 :     ]
241 :     end (* server *)
242 :     in
243 :     fillText text;
244 :     redrawCurLn (rev curLn);
245 :     server (row, col, curLnLen, curLn)
246 :     end (* config *)
247 :     in
248 :     spawn (fn () => config (0, []));
249 :     ()
250 :     end (* mkDrawServer *)
251 :     in
252 :    
253 :     fun mkVtty root size = let
254 :     val textWidget = TextWidget.mkTextWidget root size
255 :     val twidget = TextWidget.widgetOf textWidget
256 :     (* tky thinks these might need to be here *)
257 :     val (putData, instrm) = let
258 :     val ch = CML.channel()
259 :     in
260 :     (fn s => CML.send(ch, s), TextIO.openChanIn ch)
261 :     end
262 :     val (getDataEvt, outstrm) = let
263 :     val ch = CML.channel()
264 :     in
265 :     (CML.recvEvt ch, TextIO.openChanOut ch)
266 :     end
267 :     (* realize the vtty. *)
268 :     fun realizeVtty {env, win, sz} = let
269 :     open Interact
270 :     val InEnv{k=keyEvt, ci=ciEvt, ...} = env
271 :     val echoCh = channel ()
272 :     val twCmdInCh = channel ()
273 :     val inEnv = replaceCI(
274 :     replaceKey(ignoreMouse env, nullStream),
275 :     recvEvt twCmdInCh)
276 :     in
277 :     realizeFn twidget {env=inEnv, win=win, sz=sz};
278 :     mkDrawServer (textWidget, getDataEvt, echoCh, ciEvt, twCmdInCh);
279 :     mkEchoServer (keyEvt, defaultTranslation, echoCh, putData)
280 :     end (* realizeVtty *)
281 :     in
282 :     VTTY{
283 :     widget = mkWidget{
284 :     root = root,
285 :     args= fn () => {background = NONE},
286 :     boundsOf = boundsFn twidget,
287 :     realize = realizeVtty
288 :     },
289 :     instrm = instrm,
290 :     outstrm = outstrm
291 :     }
292 :     end (* mkVtty *)
293 :    
294 :     end (* local *)
295 :    
296 :     fun widgetOf (VTTY{widget, ...}) = widget
297 :    
298 :     fun openVtty (VTTY{instrm, outstrm, ...}) = (instrm,outstrm)
299 :    
300 :     end (* Vtty *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0