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 3249 - (view) (download)

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

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