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/smlnj-lib/PP/src/pp-stream-fn.sml
ViewVC logotype

Annotation of /sml/trunk/src/smlnj-lib/PP/src/pp-stream-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 651 - (view) (download)

1 : monnier 7 (* pp-stream-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 1997 Bell Labs, Lucent Technologies.
4 :     *
5 :     * The implementation of PP streams, where all the action is.
6 :     *)
7 :    
8 :     functor PPStreamFn (
9 :     structure Token : PP_TOKEN
10 :     structure Device : PP_DEVICE
11 :     sharing type Token.style = Device.style
12 :     (**
13 :     ) : PP_STREAM =
14 :     **)
15 :     ) : sig include PP_STREAM val dump : (TextIO.outstream * stream) -> unit end =
16 :     struct
17 :    
18 :     structure D = Device
19 :     structure T = Token
20 :     structure Q = Queue
21 : monnier 411 structure PPD = PPDesc
22 : monnier 7
23 :     type device = D.device
24 :     type token = T.token
25 :     type style = T.style
26 :    
27 : monnier 411 datatype indent = datatype PPD.indent
28 : monnier 7
29 :     (**** DATA STRUCTURES ****)
30 :     datatype pp_token
31 :     = TEXT of string (* raw text. This includes tokens. The *)
32 :     (* width and style information is taken *)
33 :     (* care of when they are inserted in *)
34 :     (* queue. *)
35 :     | NBSP of int (* some number of non-breakable spaces *)
36 :     | BREAK of {nsp : int, offset : int}
37 :     | BEGIN of (indent * box_type)
38 :     | END
39 :     | PUSH_STYLE of style
40 :     | POP_STYLE
41 :     | NL
42 :     | IF_NL
43 : monnier 289 | CTL of (device -> unit) (* device control operation *)
44 : monnier 7
45 :     and box_type = HBOX | VBOX | HVBOX | HOVBOX | BOX | FITS
46 :    
47 :     type pp_queue_elem = { (* elements of the PP queue *)
48 :     tok : pp_token,
49 :     sz : int ref, (* size of blok (set when known) *)
50 :     len : int (* length of token *)
51 :     }
52 :    
53 :     datatype stream = PP of {
54 :     dev : device, (* the underlying device *)
55 :     closed : bool ref, (* set to true, when the stream is *)
56 :     (* closed *)
57 :     width : int, (* the width of the device *)
58 :     spaceLeft : int ref, (* space left on current line *)
59 :     curIndent : int ref, (* current indentation *)
60 :     curDepth : int ref, (* current nesting level of boxes. *)
61 :     leftTot : int ref, (* total width of tokens already printed *)
62 :     rightTot : int ref, (* total width of tokens ever inserted *)
63 :     (* into the queue. *)
64 :     queue : pp_queue_elem Q.queue, (* the queue of pending tokens *)
65 :     fmtStk (* stack of information about currently *)
66 :     : (box_type * int) list ref, (* active blocks *)
67 :     scanStk
68 :     : (int * pp_queue_elem) list ref,
69 :     styleStk : style list ref
70 :     }
71 :    
72 :     (**** DEBUGGING FUNCTIONS ****)
73 :     structure F = Format
74 :     fun boxTypeToString HBOX = "HBOX"
75 :     | boxTypeToString VBOX = "VBOX"
76 :     | boxTypeToString HVBOX = "HVBOX"
77 :     | boxTypeToString HOVBOX = "HOVBOX"
78 :     | boxTypeToString BOX = "BOX"
79 :     | boxTypeToString FITS = "FITS"
80 :     fun indentToString (Abs n) = concat["Abs ", Int.toString n]
81 :     | indentToString (Rel n) = concat["Rel ", Int.toString n]
82 :     fun tokToString (TEXT s) = concat["TEXT \"", String.toString s, "\""]
83 : monnier 289 | tokToString (NBSP n) = concat["NBSP ", Int.toString n]
84 : monnier 7 | tokToString (BREAK{nsp, offset}) =
85 :     F.format "BREAK{nsp=%d, offset=%d}" [F.INT nsp, F.INT offset]
86 :     | tokToString (BEGIN(indent, ty)) = F.format "BEGIN(%s, %s)" [
87 :     F.STR(indentToString indent), F.STR(boxTypeToString ty)
88 :     ]
89 :     | tokToString END = "END"
90 :     | tokToString (PUSH_STYLE _) = "PUSH_STYLE _"
91 :     | tokToString POP_STYLE = "POP_STYLE"
92 :     | tokToString NL = "NL"
93 :     | tokToString IF_NL = "IF_NL"
94 : monnier 289 | tokToString (CTL f) = "CTL _"
95 : monnier 7 fun qelemToString {tok, sz, len} = F.format "{tok=%s, sz=%d, len=%d}" [
96 :     F.STR(tokToString tok), F.INT(!sz), F.INT len
97 :     ]
98 :     fun scanElemToString (n, elem) =
99 :     F.format "(%d, %s)" [F.INT n, F.STR(qelemToString elem)]
100 :     fun dump (outStrm, PP pp) = let
101 :     fun pr s = TextIO.output(outStrm, s)
102 :     fun prf (fmt, items) = pr(F.format fmt items)
103 :     fun fmtElemToString (ty, n) =
104 :     F.format "(%s, %d)" [F.STR(boxTypeToString ty), F.INT n]
105 : monnier 289 fun prl fmtElem [] = pr "[]"
106 :     | prl fmtElem l = pr(ListFormat.fmt {
107 : monnier 7 init = "[\n ", final = "]", sep = "\n ", fmt = fmtElem
108 :     } l)
109 :     in
110 :     pr ("BEGIN\n");
111 :     prf (" width = %3d\n", [F.INT(#width pp)]);
112 :     prf (" curIndent = %3d, curDepth = %3d\n", [
113 :     F.INT(!(#curIndent pp)), F.INT(!(#curDepth pp))
114 :     ]);
115 :     prf (" leftTot = %3d, rightTot = %3d\n", [
116 :     F.INT(!(#leftTot pp)), F.INT(!(#rightTot pp))
117 :     ]);
118 :     prf (" spaceLeft = %3d\n", [F.INT(!(#spaceLeft pp))]);
119 :     pr " queue = "; prl qelemToString (Q.contents(#queue pp)); pr "\n";
120 :     pr " fmtStk = "; prl fmtElemToString (!(#fmtStk pp)); pr "\n";
121 :     pr " scanStk = "; prl scanElemToString (!(#scanStk pp)); pr "\n";
122 :     pr ("END\n")
123 :     end
124 :    
125 :     (**** UTILITY FUNCTIONS ****)
126 :    
127 :     val infinity = Option.getOpt(Int.maxInt, 1000000000)
128 :    
129 :     (* output functions *)
130 :     fun output (PP{dev, ...}, s) = D.string(dev, s)
131 :     fun outputNL (PP{dev, ...}) = D.newline dev
132 :     fun blanks (_, 0) = ()
133 :     | blanks (PP{dev, ...}, n) = D.space (dev, n)
134 :    
135 :     (* add a token to the pretty-printer queue *)
136 :     fun enqueueTok (PP{rightTot, queue, ...}, tok) = (
137 :     rightTot := !rightTot + #len tok;
138 :     Q.enqueue(queue, tok))
139 :    
140 : monnier 289 (* format a break as a newline; indenting the new line.
141 :     * strm -- PP stream
142 :     * offset -- the extra indent amount supplied by the break
143 :     * wid -- the remaining line width at the opening of the
144 :     * innermost enclosing box.
145 :     *)
146 :     fun breakNewLine (strm, offset, wid) = let
147 : monnier 7 val PP{width, curIndent, spaceLeft, ...} = strm
148 : monnier 289 val indent = (width - wid) + offset
149 : monnier 7 (***** CAML version does the following: *****
150 :     val indent = min(maxIndent, indent)
151 :     *****)
152 :     in
153 :     curIndent := indent;
154 :     spaceLeft := width - indent;
155 :     outputNL strm;
156 :     blanks (strm, indent)
157 :     end
158 :    
159 : monnier 289 (* format a break as spaces.
160 :     * strm -- PP stream
161 :     * nsp -- number of spaces to output.
162 :     *)
163 : monnier 7 fun breakSameLine (strm as PP{spaceLeft, ...}, nsp) = (
164 :     spaceLeft := !spaceLeft - nsp;
165 :     blanks (strm, nsp))
166 :    
167 : monnier 289 (***** this function is in the CAML version, but is currently not used.
168 : monnier 7 fun forceLineBreak (strm as PP{fmtStk, spaceLeft, ...}) = (case !fmtStk
169 :     of ((ty, wid)::r) => if (wid > !spaceLeft)
170 :     then (case ty
171 :     of (FITS | HBOX) => ()
172 : monnier 289 | _ => breakNewLine (strm, 0, wid)
173 : monnier 7 (* end case *))
174 :     else ()
175 :     | _ => outputNL strm
176 :     (* end case *))
177 : monnier 289 *****)
178 : monnier 7
179 : monnier 289 (* return the current style of the PP stream *)
180 : monnier 7 fun currentStyle (PP{styleStk = ref [], dev, ...}) = D.defaultStyle dev
181 :     | currentStyle (PP{styleStk = ref(sty::_), ...}) = sty
182 :    
183 :     (**** FORMATTING ****)
184 :    
185 :     fun format (strm, sz, tok) = (case tok
186 :     of (TEXT s) => let
187 :     val PP{spaceLeft, ...} = strm
188 :     in
189 :     spaceLeft := !spaceLeft - sz;
190 :     output(strm, s)
191 :     end
192 :     | (NBSP n) => let
193 :     val PP{spaceLeft, ...} = strm
194 :     in
195 :     spaceLeft := !spaceLeft - sz;
196 :     blanks (strm, n)
197 :     end
198 :     | (BREAK{nsp, offset}) => let
199 :     val PP{fmtStk, spaceLeft, width, curIndent, ...} = strm
200 :     in
201 :     case !fmtStk
202 :     of ((HBOX, wid)::_) => breakSameLine (strm, nsp)
203 :     | ((VBOX, wid)::_) => breakNewLine (strm, offset, wid)
204 :     | ((HVBOX, wid)::_) => breakNewLine (strm, offset, wid)
205 :     | ((HOVBOX, wid)::_) => if (sz > !spaceLeft)
206 :     then breakNewLine (strm, offset, wid)
207 :     else breakSameLine (strm, nsp)
208 :     | ((BOX, wid)::_) =>
209 :     if ((sz > !spaceLeft)
210 :     orelse (!curIndent > (width - wid)+offset))
211 :     then breakNewLine (strm, offset, wid)
212 :     else breakSameLine (strm, nsp)
213 :     | ((FITS, wid)::_) => breakSameLine (strm, nsp)
214 :     | _ => () (* no open box *)
215 :     end
216 :     | (BEGIN(indent, ty)) => let
217 :     val PP{curIndent, spaceLeft, width, fmtStk, ...} = strm
218 :     val spaceLeft' = !spaceLeft
219 :     val insPt = width - spaceLeft'
220 : monnier 289 (* compute offset from right margin of this block's indent *)
221 : monnier 7 val offset = (case indent
222 :     of (Rel off) => spaceLeft' - off
223 : monnier 289 | (Abs off) => (case !fmtStk
224 :     of ((_, wid)::_) => wid - off
225 :     | _ => width - (!curIndent + off)
226 : monnier 411 (* maybe this can be
227 :     | _ => width - off
228 :     ??? *)
229 : monnier 289 (* end case *))
230 : monnier 7 (* end case *))
231 :     (***** CAML version does the following: ****
232 :     val _ = if (insPt > maxIndent)
233 :     then forceLineBreak strm
234 :     else ()
235 :     *****)
236 :     val ty' = (case ty
237 :     of VBOX => VBOX
238 :     | _ => if (sz > spaceLeft') then ty else FITS
239 :     (* end case *))
240 :     in
241 :     fmtStk := (ty', offset) :: !fmtStk
242 :     end
243 :     | END => let
244 :     val PP{fmtStk, ...} = strm
245 :     in
246 :     case !fmtStk
247 :     of (_ :: (l as _::_)) => fmtStk := l
248 :     | _ => () (* error: no open blocks *)
249 :     end
250 :     | (PUSH_STYLE sty) => let
251 :     val PP{dev, ...} = strm
252 :     in
253 :     D.pushStyle (dev, sty)
254 :     end
255 :     | POP_STYLE => let
256 :     val PP{dev, ...} = strm
257 :     in
258 :     D.popStyle dev
259 :     end
260 :     | NL => let
261 :     val PP{fmtStk, ...} = strm
262 :     in
263 :     case !fmtStk
264 : monnier 289 of ((_, wid)::r) => breakNewLine (strm, 0, wid)
265 : monnier 7 | _ => outputNL strm
266 :     (* end case *)
267 :     end
268 :     | IF_NL => raise Fail "IF_NL"
269 : monnier 289 | (CTL ctlFn) => let
270 :     val PP{dev, ...} = strm
271 :     in
272 :     ctlFn dev
273 :     end
274 : monnier 7 (* end case *))
275 :    
276 :     fun advanceLeft strm = let
277 :     val PP{spaceLeft, leftTot, rightTot, queue, ...} = strm
278 :     fun advance () = (case Q.peek queue
279 :     of (SOME{tok, sz=ref sz, len}) =>
280 :     if ((sz >= 0) orelse (!rightTot - !leftTot >= !spaceLeft))
281 :     then (
282 :     ignore(Q.dequeue queue);
283 :     format (strm, if sz < 0 then infinity else sz, tok);
284 :     leftTot := len + !leftTot;
285 :     advance())
286 :     else ()
287 :     | NONE => ()
288 :     (* end case *))
289 :     in
290 :     advance ()
291 :     end
292 :    
293 :     fun enqueueAndAdvance (strm, tok) = (
294 :     enqueueTok (strm, tok);
295 :     advanceLeft strm)
296 :    
297 :     fun enqueueTokenWithLen (strm, tok, len) =
298 :     enqueueAndAdvance (strm, {sz = ref len, len = len, tok = tok})
299 :    
300 :     fun enqueueStringWithLen (strm, s, len) =
301 :     enqueueTokenWithLen (strm, TEXT s, len)
302 :    
303 :     fun enqueueToken (strm, tok) = enqueueTokenWithLen (strm, tok, 0)
304 :    
305 :     (* the scan stack always has this element on its bottom *)
306 :     val scanStkBot = (~1, {sz = ref ~1, tok = TEXT "", len = 0})
307 :    
308 :     (* clear the scan stack *)
309 :     fun clearScanStk (PP{scanStk, ...}) = scanStk := [scanStkBot]
310 :    
311 :     (* Set the size of the element on the top of the scan stack. The isBreak
312 :     * flag is set to true for breaks and false for boxes.
313 :     *)
314 :     fun setSize (strm, isBreak) = let
315 :     (* NOTE: scanStk should never be empty *)
316 :     val PP{leftTot, rightTot, scanStk as ref((leftTot', elem)::r), ...} = strm
317 :     in
318 :     (* check for obsolete elements *)
319 :     if (leftTot' < !leftTot)
320 :     then clearScanStk strm
321 :     else (case (elem, isBreak)
322 :     of ({sz, tok=BREAK _, ...}, true) => (
323 :     sz := !sz + !rightTot;
324 :     scanStk := r)
325 :     | ({sz, tok=BEGIN _, ...}, false) => (
326 :     sz := !sz + !rightTot;
327 :     scanStk := r)
328 :     | _ => ()
329 :     (* end case *))
330 :     end
331 :    
332 :     fun pushScanElem (strm as PP{scanStk, rightTot, ...}, setSz, tok) = (
333 :     enqueueTok (strm, tok);
334 :     if setSz then setSize (strm, true) else ();
335 :     scanStk := (!rightTot, tok) :: !scanStk)
336 :    
337 :     (* Open a new box *)
338 :     fun ppOpenBox (strm, indent, brType) = let
339 :     val PP{rightTot, curDepth, ...} = strm
340 :     in
341 :     curDepth := !curDepth + 1;
342 :     (**** CAML code
343 :     (* check that !curDepth < maxDepth *)
344 :     ****)
345 :     pushScanElem (strm, false, {
346 :     sz = ref(~(!rightTot)),
347 :     tok = BEGIN(indent, brType),
348 :     len = 0
349 :     })
350 :     end
351 :    
352 :     (* the root box, which is always open *)
353 :     fun openSysBox (strm as PP{rightTot, curDepth, ...}) = (
354 :     curDepth := !curDepth + 1;
355 :     pushScanElem (strm, false, {
356 :     sz = ref(~(!rightTot)), tok = BEGIN(Rel 0, HOVBOX), len = 0
357 :     }))
358 :    
359 :     (* close a box *)
360 :     fun ppCloseBox (strm as PP{curDepth as ref depth, ...}) =
361 :     if (depth > 1)
362 :     then (
363 :     (**** CAML code
364 :     (* check that depth < maxDepth *)
365 :     ****)
366 :     enqueueTok (strm, {sz = ref 0, tok = END, len = 0});
367 : monnier 411 setSize (strm, true);
368 : monnier 7 setSize (strm, false);
369 :     curDepth := depth-1)
370 :     else raise Fail "unmatched close box"
371 :    
372 :     fun ppBreak (strm as PP{rightTot, ...}, arg) = (
373 :     (**** CAML code
374 :     ****)
375 :     pushScanElem (strm, true, {
376 :     sz = ref(~(!rightTot)), tok = BREAK arg, len = #nsp arg
377 :     }))
378 :    
379 :     fun ppInit (strm as PP pp) = (
380 :     #leftTot pp := 1;
381 :     #rightTot pp := 1;
382 :     Q.clear(#queue pp);
383 :     clearScanStk strm;
384 :     #curIndent pp := 0;
385 :     #curDepth pp := 0;
386 :     #spaceLeft pp := #width pp;
387 :     #fmtStk pp := [];
388 :     #styleStk pp := [];
389 :     openSysBox strm)
390 :    
391 :     fun ppNewline strm =
392 :     enqueueAndAdvance (strm, {sz = ref 0, tok = NL, len = 0})
393 :    
394 :     fun ppFlush (strm as PP{dev, curDepth, rightTot, ...}, withNL) = let
395 :     fun closeBoxes () = if (!curDepth > 1)
396 :     then (ppCloseBox strm; closeBoxes())
397 :     else ()
398 :     in
399 :     closeBoxes ();
400 :     rightTot := infinity;
401 :     advanceLeft strm;
402 :     if withNL then outputNL strm else ();
403 :     D.flush dev;
404 :     ppInit strm
405 :     end
406 :    
407 :     (**** USER FUNCTIONS ****)
408 :     fun openStream d = let
409 :     val strm = PP{
410 :     dev = d,
411 :     closed = ref false,
412 :     width = Option.getOpt(D.lineWidth d, infinity),
413 :     spaceLeft = ref 0,
414 :     curIndent = ref 0,
415 :     curDepth = ref 0,
416 :     leftTot = ref 1, (* why 1 ? *)
417 :     rightTot = ref 1, (* why 1 ? *)
418 :     queue = Q.mkQueue(),
419 :     fmtStk = ref [],
420 :     scanStk = ref [],
421 :     styleStk = ref []
422 :     }
423 :     in
424 :     ppInit strm;
425 :     strm
426 :     end
427 :    
428 :     fun flushStream strm = ppFlush(strm, false)
429 :     fun closeStream (strm as PP{closed, ...}) = (flushStream strm; closed := true)
430 :    
431 :     fun openHBox strm = ppOpenBox (strm, Abs 0, HBOX)
432 :     fun openVBox strm indent = ppOpenBox (strm, indent, VBOX)
433 :     fun openHVBox strm indent = ppOpenBox (strm, indent, HVBOX)
434 :     fun openHOVBox strm indent = ppOpenBox (strm, indent, HOVBOX)
435 :     fun openBox strm indent = ppOpenBox (strm, indent, BOX)
436 :     fun closeBox strm = ppCloseBox strm
437 :    
438 :     fun token (strm as PP{dev, ...}) t = let
439 :     val tokStyle = T.style t
440 :     in
441 :     if (D.sameStyle(currentStyle strm, tokStyle))
442 :     then enqueueStringWithLen (strm, T.string t, T.size t)
443 :     else (
444 :     enqueueToken (strm, PUSH_STYLE tokStyle);
445 :     enqueueStringWithLen (strm, T.string t, T.size t);
446 :     enqueueToken (strm, POP_STYLE))
447 :     end
448 :     fun string strm s = enqueueStringWithLen(strm, s, size s)
449 :    
450 :     fun pushStyle (strm as PP{styleStk, ...}, sty) = (
451 :     if (D.sameStyle(currentStyle strm, sty))
452 :     then ()
453 :     else enqueueToken (strm, PUSH_STYLE sty);
454 :     styleStk := sty :: !styleStk)
455 :     fun popStyle (strm as PP{styleStk, ...}) = (case !styleStk
456 :     of [] => raise Fail "PP: unmatched popStyle"
457 :     | (sty::r) => (
458 :     styleStk := r;
459 :     if (D.sameStyle(currentStyle strm, sty))
460 :     then ()
461 :     else enqueueToken (strm, POP_STYLE))
462 :     (* end case *))
463 :    
464 :     fun break strm arg = ppBreak (strm, arg)
465 :     fun space strm n = break strm {nsp=n, offset=0}
466 :     fun cut strm = break strm {nsp=0, offset=0}
467 :     fun newline strm = ppNewline strm
468 :     fun nbSpace strm n = enqueueTokenWithLen (strm, NBSP n, n)
469 :    
470 :     fun onNewline strm () = raise Fail "onNewline"
471 :    
472 : monnier 289 fun control strm ctlFn = enqueueToken (strm, CTL ctlFn)
473 :    
474 : monnier 411 (* pretty print a description *)
475 :     type pp_desc = (token, style, device) PPD.pp_desc
476 :    
477 :     fun description strm = let
478 :     fun pp (PPD.HBox l) = (openHBox strm; ppList l; closeBox strm)
479 :     | pp (PPD.VBox(i, l)) = (openVBox strm i; ppList l; closeBox strm)
480 :     | pp (PPD.HVBox(i, l)) = (openHVBox strm i; ppList l; closeBox strm)
481 :     | pp (PPD.HOVBox(i, l)) = (openHOVBox strm i; ppList l; closeBox strm)
482 :     | pp (PPD.Box(i, l)) = (openBox strm i; ppList l; closeBox strm)
483 :     | pp (PPD.Token tok) = token strm tok
484 :     | pp (PPD.String s) = string strm s
485 :     | pp (PPD.Style(sty, l)) = (
486 :     pushStyle(strm, sty); ppList l; popStyle strm)
487 :     | pp (PPD.Break brk) = break strm brk
488 :     | pp PPD.NewLine = newline strm
489 :     | pp (PPD.NBSpace n) = nbSpace strm n
490 :     | pp (PPD.Control ctlFn) = control strm ctlFn
491 :     and ppList [] = ()
492 :     | ppList (item::r) = (pp item; ppList r)
493 :     in
494 :     pp
495 :     end
496 :    
497 :     (* PP description constructors *)
498 :     structure Desc =
499 :     struct
500 :     val hBox = PPD.HBox
501 :     val vBox = PPD.VBox
502 :     val hvBox = PPD.HVBox
503 :     val hovBox = PPD.HOVBox
504 :     val box = PPD.Box
505 :     val token = PPD.Token
506 :     val string = PPD.String
507 :     val style = PPD.Style
508 :     val break = PPD.Break
509 :     fun space n = PPD.Break{nsp = n, offset = 0}
510 :     val cut = PPD.Break{nsp = 0, offset = 0}
511 :     val newline = PPD.NewLine
512 :     val control = PPD.Control
513 :     end
514 :    
515 : monnier 7 end
516 : monnier 289

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