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 /smlnj-lib/releases/release-110.69/HTML/pr-html.sml
ViewVC logotype

Annotation of /smlnj-lib/releases/release-110.69/HTML/pr-html.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download)
Original Path: sml/trunk/src/smlnj-lib/HTML/pr-html.sml

1 : monnier 2 (* pr-html.sml
2 :     *
3 :     * COPYRIGHT (c) 1996 AT&T REsearch.
4 :     *
5 :     * Pretty-print an HTML tree. The print routine accepts optional header
6 :     * and footer strings that are included at the beginning and end of the
7 :     * page's body.
8 :     *)
9 :    
10 :     structure PrHTML : sig
11 :    
12 :     val prHTML : {
13 :     putc : char -> unit,
14 :     puts : string -> unit
15 :     } -> {
16 :     html : HTML.html,
17 :     optHead : string option,
18 :     optFoot : string option
19 :     } -> unit
20 :    
21 :     end = struct
22 :    
23 :     structure H = HTML
24 :     structure F = Format
25 :    
26 :     datatype outstream = OS of {
27 :     putc : char -> unit,
28 :     puts : string -> unit
29 :     }
30 :    
31 :     fun putc (OS{putc, ...}, c) = putc c
32 :     fun puts (OS{puts, ...}, s) = puts s
33 :    
34 :     datatype attr_data
35 :     = IMPLICIT of bool
36 :     | CDATA of string option
37 :     | NAME of string option
38 :     | NUMBER of int option
39 :    
40 :     local
41 :     fun name toString NONE = NAME NONE
42 :     | name toString (SOME x) = NAME(SOME(toString x))
43 :     in
44 :     val httpMethod = name HTML.HttpMethod.toString
45 :     val inputType = name HTML.InputType.toString
46 :     val iAlign = name HTML.IAlign.toString
47 :     val hAlign = name HTML.HAlign.toString
48 :     val cellVAlign = name HTML.CellVAlign.toString
49 :     val captionAlign = name HTML.CaptionAlign.toString
50 :     val ulStyle = name HTML.ULStyle.toString
51 :     val shape = name HTML.Shape.toString
52 :     val textFlowCtl = name HTML.TextFlowCtl.toString
53 :     end (* local *)
54 :    
55 :     fun fmtTag (tag, []) = concat["<", tag, ">"]
56 :     | fmtTag (tag, attrs) = let
57 :     fun fmtAttr (attrName, IMPLICIT true) = SOME attrName
58 :     | fmtAttr (attrName, CDATA(SOME s)) =
59 :     SOME(F.format "%s=\"%s\"" [F.STR attrName, F.STR s])
60 :     | fmtAttr (attrName, NAME(SOME s)) =
61 :     SOME(F.format "%s=%s" [F.STR attrName, F.STR s])
62 :     | fmtAttr (attrName, NUMBER(SOME n)) =
63 :     SOME(F.format "%s=%d" [F.STR attrName, F.INT n])
64 :     | fmtAttr _ = NONE
65 :     val attrs = List.mapPartial fmtAttr attrs
66 :     in
67 :     ListFormat.formatList {
68 :     init = "<",
69 :     sep = " ",
70 :     final = ">",
71 :     fmt = fn x => x
72 :     } (tag :: attrs)
73 :     end
74 :    
75 :     fun fmtEndTag tag = concat["</", tag, ">"]
76 :    
77 :     fun prTag (OS{puts, ...}, tag, attrs) = puts(fmtTag (tag, attrs))
78 :     fun prEndTag (OS{puts, ...}, tag) = puts(fmtEndTag tag)
79 :     fun newLine (OS{putc, ...}) = putc #"\n"
80 :     fun space (OS{putc, ...}) = putc #" "
81 :    
82 :     (** NOTE: once we are doing linebreaks for text, this becomes
83 :     ** important.
84 :     **)
85 :     fun setPre (_, _) = ()
86 :    
87 :     fun prBlock (strm, blk : HTML.block) = (case blk
88 :     of (HTML.BlockList bl) =>
89 :     List.app (fn b => prBlock (strm, b)) bl
90 :     | (HTML.TextBlock txt) => (prText (strm, txt); newLine strm)
91 :     | (HTML.Hn{n, align, content}) => let
92 :     val tag = "H" ^ Int.toString n
93 :     in
94 :     prTag (strm, tag, [("align", hAlign align)]);
95 :     prText (strm, content);
96 :     prEndTag (strm, tag);
97 :     newLine strm
98 :     end
99 :     | (HTML.ADDRESS blk) => (
100 :     prTag (strm, "ADDRESS", []);
101 :     newLine strm;
102 :     prBlock (strm, blk);
103 :     prEndTag (strm, "ADDRESS");
104 :     newLine strm)
105 :     | (HTML.P{align, content}) => (
106 :     prTag (strm, "P", [("ALIGN", hAlign align)]);
107 :     newLine strm;
108 :     prText (strm, content);
109 :     newLine strm)
110 :     | (HTML.UL{ty, compact, content}) => (
111 :     prTag (strm, "UL", [
112 :     ("TYPE", ulStyle ty),
113 :     ("COMPACT", IMPLICIT compact)
114 :     ]);
115 :     newLine strm;
116 :     prListItems (strm, content);
117 :     prEndTag (strm, "UL");
118 :     newLine strm)
119 :     | (HTML.OL{ty, start, compact, content}) => (
120 :     prTag (strm, "OL", [
121 :     ("TYPE", CDATA ty),
122 :     ("START", NUMBER start),
123 :     ("COMPACT", IMPLICIT compact)
124 :     ]);
125 :     newLine strm;
126 :     prListItems (strm, content);
127 :     prEndTag (strm, "OL");
128 :     newLine strm)
129 :     | (HTML.DIR{compact, content}) => (
130 :     prTag (strm, "DIR", [("COMPACT", IMPLICIT compact)]);
131 :     newLine strm;
132 :     prListItems (strm, content);
133 :     prEndTag (strm, "DIR");
134 :     newLine strm)
135 :     | (HTML.MENU{compact, content}) => (
136 :     prTag (strm, "MENU", [("COMPACT", IMPLICIT compact)]);
137 :     newLine strm;
138 :     prListItems (strm, content);
139 :     prEndTag (strm, "MENU");
140 :     newLine strm)
141 :     | (HTML.DL{compact, content}) => (
142 :     prTag (strm, "DL", [("COMPACT", IMPLICIT compact)]);
143 :     newLine strm;
144 :     prDLItems (strm, content);
145 :     prEndTag (strm, "DL");
146 :     newLine strm)
147 :     | (HTML.PRE{width, content}) => (
148 :     prTag (strm, "PRE", [("WIDTH", NUMBER width)]);
149 :     newLine strm;
150 :     setPre (strm, true);
151 :     prText (strm, content);
152 :     setPre (strm, false);
153 :     newLine strm;
154 :     prEndTag (strm, "PRE");
155 :     newLine strm)
156 :     | (HTML.DIV{align, content}) => (
157 :     prTag (strm, "DIV", [("ALIGN", hAlign(SOME align))]);
158 :     newLine strm;
159 :     prBlock (strm, content);
160 :     prEndTag (strm, "DIV");
161 :     newLine strm)
162 :     | (HTML.CENTER bl) => (
163 :     prTag (strm, "CENTER", []);
164 :     newLine strm;
165 :     prBlock (strm, bl);
166 :     prEndTag (strm, "CENTER");
167 :     newLine strm)
168 :     | (HTML.BLOCKQUOTE bl) => (
169 :     prTag (strm, "BLOCKQUOTE", []);
170 :     newLine strm;
171 :     prBlock (strm, bl);
172 :     prEndTag (strm, "BLOCKQUOTE");
173 :     newLine strm)
174 :     | (HTML.FORM{action, method, enctype, content}) => (
175 :     prTag (strm, "FORM", [
176 :     ("ACTION", CDATA action),
177 :     ("METHOD", httpMethod(SOME method)),
178 :     ("ENCTYPE", CDATA enctype)
179 :     ]);
180 :     newLine strm;
181 :     prBlock (strm, content);
182 :     prEndTag (strm, "FORM");
183 :     newLine strm)
184 :     | (HTML.ISINDEX{prompt}) => (
185 :     prTag (strm, "ISINDEX", [("PROMPT", CDATA prompt)]);
186 :     newLine strm)
187 :     | (HTML.HR{align, noshade, size, width}) => (
188 :     prTag (strm, "HR", [
189 :     ("ALIGN", hAlign align),
190 :     ("NOSHADE", IMPLICIT noshade),
191 :     ("SIZE", CDATA size),
192 :     ("WIDTH", CDATA width)
193 :     ]);
194 :     newLine strm)
195 :     | (HTML.TABLE{
196 :     align, width, border, cellspacing, cellpadding,
197 :     caption, content
198 :     }) => (
199 :     prTag (strm, "TABLE", [
200 :     ("ALIGN", hAlign align),
201 :     ("WIDTH", CDATA width),
202 :     ("BORDER", CDATA border),
203 :     ("CELLSPACING", CDATA cellspacing),
204 :     ("CELLPADDING", CDATA cellpadding)
205 :     ]);
206 :     newLine strm;
207 :     prCaption (strm, caption);
208 :     prTableRows (strm, content);
209 :     prEndTag (strm, "TABLE");
210 :     newLine strm)
211 :     (* end case *))
212 :    
213 :     and prListItems (strm, items) = let
214 :     fun prItem (HTML.LI{ty, value, content}) = (
215 :     prTag (strm, "LI", [("TYPE", CDATA ty), ("VALUE", NUMBER value)]);
216 :     newLine strm;
217 :     prBlock (strm, content))
218 :     in
219 :     List.app prItem items
220 :     end
221 :    
222 :     and prDLItems (strm, items) = let
223 :     fun prDT txt = (
224 :     prTag (strm, "DT", []);
225 :     space strm;
226 :     prText (strm, txt);
227 :     newLine strm)
228 :     fun prDD blk = (
229 :     prTag (strm, "DD", []);
230 :     newLine strm;
231 :     prBlock (strm, blk))
232 :     fun prItem ({dt, dd}) = (List.app prDT dt; prDD dd)
233 :     in
234 :     List.app prItem items
235 :     end
236 :    
237 :     and prCaption (strm, NONE) = ()
238 :     | prCaption (strm, SOME(HTML.CAPTION{align, content})) = (
239 :     prTag (strm, "CAPTION", [("ALIGN", captionAlign align)]);
240 :     newLine strm;
241 :     prText (strm, content);
242 :     prEndTag (strm, "CAPTION");
243 :     newLine strm)
244 :    
245 :     and prTableRows (strm, rows) = let
246 :     fun prTR (HTML.TR{align, valign, content}) = (
247 :     prTag (strm, "TR", [
248 :     ("ALIGN", hAlign align),
249 :     ("VALIGN", cellVAlign valign)
250 :     ]);
251 :     newLine strm;
252 :     List.app (prTableCell strm) content)
253 :     in
254 :     List.app prTR rows
255 :     end
256 :    
257 :     and prTableCell strm cell = let
258 :     fun prCell (tag, {
259 :     nowrap, rowspan, colspan , align, valign, width, height,
260 :     content
261 :     }) = (
262 :     prTag (strm, tag, [
263 :     ("NOWRAP", IMPLICIT nowrap),
264 :     ("ROWSPAN", NUMBER rowspan),
265 :     ("COLSPAN", NUMBER colspan),
266 :     ("ALIGN", hAlign align),
267 :     ("VALIGN", cellVAlign valign),
268 :     ("WIDTH", CDATA width),
269 :     ("HEIGHT", CDATA height)
270 :     ]);
271 :     newLine strm;
272 :     prBlock (strm, content))
273 :     in
274 :     case cell
275 :     of (HTML.TH stuff) => prCell ("TH", stuff)
276 :     | (HTML.TD stuff) => prCell ("TD", stuff)
277 :     (* end case *)
278 :     end
279 :    
280 :     and prEmph (strm, tag, text) = (
281 :     prTag (strm, tag, []);
282 :     prText (strm, text);
283 :     prEndTag (strm, tag))
284 :    
285 :     and prText (strm, text) = (case text
286 :     of (HTML.TextList tl) =>
287 :     List.app (fn txt => prText(strm, txt)) tl
288 :     | (HTML.PCDATA pcdata) => prPCData(strm, pcdata)
289 :     | (HTML.TT txt) => prEmph (strm, "TT", txt)
290 :     | (HTML.I txt) => prEmph (strm, "I", txt)
291 :     | (HTML.B txt) => prEmph (strm, "B", txt)
292 :     | (HTML.U txt) => prEmph (strm, "U", txt)
293 :     | (HTML.STRIKE txt) => prEmph (strm, "STRIKE", txt)
294 :     | (HTML.BIG txt) => prEmph (strm, "BIG", txt)
295 :     | (HTML.SMALL txt) => prEmph (strm, "SMALL", txt)
296 :     | (HTML.SUB txt) => prEmph (strm, "SUB", txt)
297 :     | (HTML.SUP txt) => prEmph (strm, "SUP", txt)
298 :     | (HTML.EM txt) => prEmph (strm, "EM", txt)
299 :     | (HTML.STRONG txt) => prEmph (strm, "STRONG", txt)
300 :     | (HTML.DFN txt) => prEmph (strm, "DFN", txt)
301 :     | (HTML.CODE txt) => prEmph (strm, "CODE", txt)
302 :     | (HTML.SAMP txt) => prEmph (strm, "SAMP", txt)
303 :     | (HTML.KBD txt) => prEmph (strm, "KBD", txt)
304 :     | (HTML.VAR txt) => prEmph (strm, "VAR", txt)
305 :     | (HTML.CITE txt) => prEmph (strm, "CITE", txt)
306 :     | (HTML.A{name, href, rel, rev, title, content}) => (
307 :     prTag (strm, "A", [
308 :     ("NAME", CDATA name),
309 :     ("HREF", CDATA href),
310 :     ("REL", CDATA rel),
311 :     ("REV", CDATA rev),
312 :     ("TITLE", CDATA title)
313 :     ]);
314 :     prText (strm, content);
315 :     prEndTag (strm, "A"))
316 :     | (HTML.IMG{
317 :     src, alt, align, height, width, border,
318 :     hspace, vspace, usemap, ismap
319 :     }) => prTag (strm, "IMG", [
320 :     ("SRC", CDATA(SOME src)),
321 :     ("ALT", CDATA alt),
322 :     ("ALIGN", iAlign align),
323 :     ("HEIGHT", CDATA height),
324 :     ("WIDTH", CDATA width),
325 :     ("BORDER", CDATA border),
326 :     ("HSPACE", CDATA hspace),
327 :     ("VSPACE", CDATA vspace),
328 :     ("USEMAP", CDATA usemap),
329 :     ("ISMAP", IMPLICIT ismap)
330 :     ])
331 :     | (HTML.APPLET{
332 :     codebase, code, name, alt, align, height, width,
333 :     hspace, vspace, content
334 :     }) => (
335 :     prTag (strm, "APPLET", [
336 :     ("CODEBASE", CDATA codebase),
337 :     ("CODE", CDATA(SOME code)),
338 :     ("NAME", CDATA name),
339 :     ("ALT", CDATA alt),
340 :     ("ALIGN", iAlign align),
341 :     ("HEIGHT", CDATA height),
342 :     ("WIDTH", CDATA width),
343 :     ("HSPACE", CDATA hspace),
344 :     ("VSPACE", CDATA vspace)
345 :     ]);
346 :     prText (strm, content);
347 :     prEndTag (strm, "APPLET"))
348 :     | (HTML.PARAM{name, value}) =>
349 :     prTag (strm, "PARAM", [
350 :     ("NAME", NAME(SOME name)),
351 :     ("VALUE", CDATA value)
352 :     ])
353 :     | (HTML.FONT{size, color, content}) => (
354 :     prTag (strm, "FONT", [
355 :     ("SIZE", CDATA size),
356 :     ("COLOR", CDATA color)
357 :     ]);
358 :     prText (strm, content);
359 :     prEndTag (strm, "FONT"))
360 :     | (HTML.BASEFONT{size, content}) => (
361 :     prTag (strm, "BASEFONT", [("SIZE", CDATA size)]);
362 :     prText (strm, content);
363 :     prEndTag (strm, "BASEFONT"))
364 :     | (HTML.BR{clear}) => (
365 :     prTag (strm, "BR", [("CLEAR", textFlowCtl clear)]);
366 :     newLine strm)
367 :     | (HTML.MAP{name, content}) => (
368 :     prTag (strm, "MAP", [("NAME", CDATA name)]);
369 :     List.app (prArea strm) content;
370 :     prEndTag (strm, "MAP"))
371 :     | (HTML.INPUT{
372 :     ty, name, value, checked, size, maxlength, src, align
373 :     }) => prTag (strm, "INPUT", [
374 :     ("TYPE", inputType ty),
375 :     ("NAME", NAME name),
376 :     ("VALUE", CDATA value),
377 :     ("CHECKED", IMPLICIT checked),
378 :     ("SIZE", CDATA size),
379 :     ("MAXLENGTH", NUMBER maxlength),
380 :     ("SRC", CDATA src),
381 :     ("ALIGN", iAlign align)
382 :     ])
383 :     | (HTML.SELECT{name, size, content}) => (
384 :     prTag (strm, "SELECT", [
385 :     ("NAME", NAME(SOME name)),
386 :     ("SIZE", NUMBER size)
387 :     ]);
388 :     List.app (prOption strm) content;
389 :     prEndTag (strm, "SELECT"))
390 :     | (HTML.TEXTAREA{name, rows, cols, content}) => (
391 :     prTag (strm, "TEXTAREA", [
392 :     ("NAME", NAME(SOME name)),
393 :     ("ROWS", NUMBER(SOME rows)),
394 :     ("COLS", NUMBER(SOME cols))
395 :     ]);
396 :     prPCData (strm, content);
397 :     prEndTag (strm, "TEXTAREA"))
398 :     (* SCRIPT elements are placeholders for the next version of HTML *)
399 :     | (HTML.SCRIPT pcdata) => ()
400 :     (* end case *))
401 :    
402 :     and prArea strm (HTML.AREA{shape=s, coords, href, nohref, alt}) =
403 :     prTag (strm, "AREA", [
404 :     ("SHAPE", shape s),
405 :     ("COORDS", CDATA coords),
406 :     ("HREF", CDATA href),
407 :     ("nohref", IMPLICIT nohref),
408 :     ("ALT", CDATA(SOME alt))
409 :     ])
410 :    
411 :     and prOption strm (HTML.OPTION{selected, value, content}) = (
412 :     prTag (strm, "OPTION", [
413 :     ("SELECTED", IMPLICIT selected),
414 :     ("VALUE", CDATA value)
415 :     ]);
416 :     prPCData (strm, content))
417 :    
418 :     and prPCData (strm, data) = puts (strm, data)
419 :    
420 :     fun prHeadElement strm elem = (case elem
421 :     of (HTML.Head_TITLE pcdata) => (
422 :     prTag (strm, "TITLE", []);
423 :     prPCData(strm, pcdata);
424 :     prEndTag (strm, "TITLE");
425 :     newLine strm)
426 :     | (HTML.Head_ISINDEX{prompt}) => (
427 :     prTag (strm, "ISINDEX", [("PROMPT", CDATA prompt)]);
428 :     newLine strm)
429 :     | (HTML.Head_BASE{href}) => (
430 :     prTag (strm, "BASE", [("HREF", CDATA(SOME href))]);
431 :     newLine strm)
432 :     | (HTML.Head_META{httpEquiv, name, content}) => (
433 :     prTag (strm, "META", [
434 :     ("HTTP-EQUIV", NAME httpEquiv),
435 :     ("NAME", NAME name),
436 :     ("CONTENT", CDATA(SOME content))
437 :     ]);
438 :     newLine strm)
439 :     | (HTML.Head_LINK{id, href, rel, rev, title}) => (
440 :     prTag (strm, "LINK", [
441 :     ("ID", NAME id),
442 :     ("HREF", CDATA href),
443 :     ("REL", CDATA rel),
444 :     ("REV", CDATA rev),
445 :     ("TITLE", CDATA title)
446 :     ]);
447 :     newLine strm)
448 :     (* SCRIPT/STYLE elements are placeholders for the next version of HTML *)
449 :     | (HTML.Head_SCRIPT pcdata) => ()
450 :     | (HTML.Head_STYLE pcdata) => ()
451 :     (* end case *))
452 :    
453 :     fun prHTML {putc, puts} {html, optHead, optFoot} = let
454 :     val strm = OS{putc=putc, puts=puts}
455 :     val HTML.HTML{head, body, version} = html
456 :     fun prOpt NONE = ()
457 :     | prOpt (SOME txt) = puts txt
458 :     in
459 :     case version
460 :     of NONE => ()
461 :     | (SOME v) => puts (F.format
462 :     "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML %s//EN\">\n"
463 :     [F.STR v])
464 :     (* end case *);
465 :     puts "<HTML>\n";
466 :     puts "<HEAD>\n";
467 :     List.app (prHeadElement strm) head;
468 :     puts "</HEAD>\n";
469 :     puts "<BODY>\n";
470 :     prOpt optHead;
471 :     prBlock (strm, body);
472 :     prOpt optFoot;
473 :     puts "</BODY>\n";
474 :     puts "</HTML>\n"
475 :     end
476 :    
477 :     end
478 :    

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