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/devices/html-dev.sml
ViewVC logotype

Annotation of /sml/trunk/src/smlnj-lib/PP/devices/html-dev.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 7 - (view) (download)

1 : monnier 7 (* html-device.sml
2 :     *
3 :     * COPYRIGHT (c) 1997 Bell Labs, Lucent Technologies.
4 :     *
5 :     * A pretty printing device that uses HTML markup to control layout.
6 :     *)
7 :    
8 :     structure HTMLDev : sig
9 :    
10 :     include PP_DEVICE
11 :    
12 :     val styleTT : style
13 :     val styleI : style
14 :     val styleB : style
15 :     val styleU : style
16 :     val styleSTRIKE : style
17 :     val styleEM : style
18 :     val styleSTRONG : style
19 :     val styleDFN : style
20 :     val styleCODE : style
21 :     val styleSAMP : style
22 :     val styleKBD : style
23 :     val styleVAR : style
24 :     val styleCITE : style
25 :    
26 :     val color : string -> style
27 :    
28 :     val openDev : {wid : int, textWid : int option} -> device
29 :     val done : device -> HTML.text
30 :    
31 :     end = struct
32 :    
33 :     datatype style
34 :     = NOEMPH
35 :     | TT | I | B | U | STRIKE | EM
36 :     | STRONG | DFN | CODE | SAMP | KBD
37 :     | VAR | CITE
38 :     | COLOR of string
39 :    
40 :     datatype device = DEV of {
41 :     lineWid : int,
42 :     textWid : int option,
43 :     emphStk : (HTML.text list * style) list ref,
44 :     txt : HTML.text list ref
45 :     }
46 :    
47 :     (* return the current emphasis *)
48 :     fun curEmph (DEV{emphStk, ...}) = (case !emphStk
49 :     of [] => NOEMPH
50 :     | ((_, em)::r) => em
51 :     (* end case *))
52 :    
53 :     (* add PCDATA to the text list *)
54 :     fun pcdata (DEV{txt, ...}, s) = txt := HTML.PCDATA s :: !txt
55 :    
56 :     (* replace the sequence of PCDATA elements at the head of the
57 :     * txt list with its concatenation.
58 :     *)
59 :     fun concatTxt (DEV{txt, ...}) = let
60 :     fun f ([], []) = []
61 :     | f (HTML.PCDATA s :: r, l) = f (r, s::l)
62 :     | f (r, l) = HTML.PCDATA(String.concat l) :: r
63 :     in
64 :     f (!txt, [])
65 :     end
66 :    
67 :     (* are two styles the same? *)
68 :     fun sameStyle (s1 : style, s2) = (s1 = s2)
69 :    
70 :     fun wrapStyle (sty, [], tl') = tl'
71 :     | wrapStyle (sty, tl, tl') = let
72 :     val t = (case tl of [t] => t | _ => HTML.TextList(List.rev tl))
73 :     val t = (case sty
74 :     of NOEMPH => t
75 :     | TT => HTML.TT t
76 :     | I => HTML.I t
77 :     | B => HTML.B t
78 :     | U => HTML.U t
79 :     | STRIKE => HTML.STRIKE t
80 :     | EM => HTML.EM t
81 :     | STRONG => HTML.STRONG t
82 :     | DFN => HTML.DFN t
83 :     | CODE => HTML.CODE t
84 :     | SAMP => HTML.SAMP t
85 :     | KBD => HTML.KBD t
86 :     | VAR => HTML.VAR t
87 :     | CITE => HTML.CITE t
88 :     | (COLOR c) => HTML.FONT{color=SOME c, size=NONE, content=t}
89 :     (* end case *))
90 :     in
91 :     t :: tl'
92 :     end
93 :    
94 :     (* push/pop a style from the devices style stack. A pop on an
95 :     * empty style stack is a nop.
96 :     *)
97 :     fun pushStyle (dev as DEV{emphStk, txt, ...}, sty) = (
98 :     emphStk := (concatTxt dev, sty) :: !emphStk;
99 :     txt := [])
100 :     fun popStyle (dev as DEV{emphStk, txt, ...}) = let
101 :     val (tl, sty)::r = !emphStk
102 :     in
103 :     txt := wrapStyle (sty, concatTxt dev, tl);
104 :     emphStk := r
105 :     end
106 :    
107 :     (* the default style for the device (this is the current style,
108 :     * if the style stack is empty).
109 :     *)
110 :     fun defaultStyle _ = NOEMPH
111 :    
112 :     (* maximum printing depth (in terms of boxes) *)
113 :     fun depth _ = NONE
114 :     (* the width of the device *)
115 :     fun lineWidth (DEV{lineWid, ...}) = SOME lineWid
116 :     (* the suggested maximum width of text on a line *)
117 :     fun textWidth (DEV{textWid, ...}) = textWid
118 :    
119 :     (* output some number of spaces to the device *)
120 :     fun space (dev, n) =
121 :     pcdata(dev, concat(List.tabulate (n, fn _ => " ")))
122 :    
123 :     (* output a new-line to the device *)
124 :     fun newline (dev as DEV{txt, ...}) =
125 :     txt := HTML.BR{clear=NONE} :: (concatTxt dev)
126 :    
127 :     (* output a string/character in the current style to the device *)
128 :     val string = pcdata
129 :     fun char (dev, c) = pcdata(dev, str c)
130 :    
131 :     (* flush is a nop for us *)
132 :     fun flush _ = ()
133 :    
134 :     val styleTT = TT
135 :     val styleI = I
136 :     val styleB = B
137 :     val styleU = U
138 :     val styleSTRIKE = STRIKE
139 :     val styleEM = EM
140 :     val styleSTRONG = STRONG
141 :     val styleDFN = DFN
142 :     val styleCODE = CODE
143 :     val styleSAMP = SAMP
144 :     val styleKBD = KBD
145 :     val styleVAR = VAR
146 :     val styleCITE = CITE
147 :     val color = COLOR
148 :    
149 :     fun openDev {wid, textWid} = DEV{
150 :     txt = ref [],
151 :     emphStk = ref [],
152 :     lineWid = wid,
153 :     textWid = textWid
154 :     }
155 :    
156 :     fun done (dev as DEV{emphStk = ref [], txt, ...}) = (case (concatTxt dev)
157 :     of [t] => (txt := []; t)
158 :     | l => (txt := []; HTML.TextList(List.rev l))
159 :     (* end case *))
160 :     | done _ = raise Fail "device is not done yet"
161 :    
162 :     end; (* HTMLDev *)
163 :    

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