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 596 - (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 : monnier 289 (* combine two styles into one *)
13 :     val combineStyle : (style * style) -> style
14 :    
15 :     (* unstyled text *)
16 :     val styleNONE : style
17 :    
18 :     (* standard HTML text styles *)
19 : monnier 7 val styleTT : style
20 :     val styleI : style
21 :     val styleB : style
22 :     val styleU : style
23 :     val styleSTRIKE : style
24 :     val styleEM : style
25 :     val styleSTRONG : style
26 :     val styleDFN : style
27 :     val styleCODE : style
28 :     val styleSAMP : style
29 :     val styleKBD : style
30 :     val styleVAR : style
31 :     val styleCITE : style
32 :    
33 : monnier 289 (* color text (using FONT element) *)
34 : monnier 7 val color : string -> style
35 :    
36 : monnier 289 (* hyper-text links and anchors *)
37 :     val link : string -> style
38 :     val anchor : string -> style
39 : jhr 596 val linkAnchor : {name : string, href : string} -> style
40 : monnier 289
41 : monnier 7 val openDev : {wid : int, textWid : int option} -> device
42 :     val done : device -> HTML.text
43 :    
44 :     end = struct
45 :    
46 :     datatype style
47 :     = NOEMPH
48 :     | TT | I | B | U | STRIKE | EM
49 :     | STRONG | DFN | CODE | SAMP | KBD
50 :     | VAR | CITE
51 :     | COLOR of string
52 : jhr 596 | A of {href : string option, name : string option}
53 : monnier 289 | STYS of style list
54 : monnier 7
55 :     datatype device = DEV of {
56 :     lineWid : int,
57 :     textWid : int option,
58 :     emphStk : (HTML.text list * style) list ref,
59 :     txt : HTML.text list ref
60 :     }
61 :    
62 :     (* return the current emphasis *)
63 :     fun curEmph (DEV{emphStk, ...}) = (case !emphStk
64 :     of [] => NOEMPH
65 :     | ((_, em)::r) => em
66 :     (* end case *))
67 :    
68 :     (* add PCDATA to the text list *)
69 :     fun pcdata (DEV{txt, ...}, s) = txt := HTML.PCDATA s :: !txt
70 :    
71 :     (* replace the sequence of PCDATA elements at the head of the
72 :     * txt list with its concatenation.
73 :     *)
74 :     fun concatTxt (DEV{txt, ...}) = let
75 :     fun f ([], []) = []
76 :     | f (HTML.PCDATA s :: r, l) = f (r, s::l)
77 :     | f (r, l) = HTML.PCDATA(String.concat l) :: r
78 :     in
79 :     f (!txt, [])
80 :     end
81 :    
82 :     (* are two styles the same? *)
83 :     fun sameStyle (s1 : style, s2) = (s1 = s2)
84 :    
85 :     fun wrapStyle (sty, [], tl') = tl'
86 :     | wrapStyle (sty, tl, tl') = let
87 : monnier 289 fun wrap (NOEMPH, t) = t
88 :     | wrap (TT, t) = HTML.TT t
89 :     | wrap (I, t) = HTML.I t
90 :     | wrap (B, t) = HTML.B t
91 :     | wrap (U, t) = HTML.U t
92 :     | wrap (STRIKE, t) = HTML.STRIKE t
93 :     | wrap (EM, t) = HTML.EM t
94 :     | wrap (STRONG, t) = HTML.STRONG t
95 :     | wrap (DFN, t) = HTML.DFN t
96 :     | wrap (CODE, t) = HTML.CODE t
97 :     | wrap (SAMP, t) = HTML.SAMP t
98 :     | wrap (KBD, t) = HTML.KBD t
99 :     | wrap (VAR, t) = HTML.VAR t
100 :     | wrap (CITE, t) = HTML.CITE t
101 :     | wrap (COLOR c, t) = HTML.FONT{color=SOME c, size=NONE, content=t}
102 : jhr 596 | wrap (A{name, href}, t) = HTML.A{
103 :     name = name, href = href,
104 : monnier 289 rel = NONE, rev = NONE, title = NONE,
105 :     content = t
106 :     }
107 :     | wrap (STYS l, t) = List.foldr wrap t l
108 : monnier 7 val t = (case tl of [t] => t | _ => HTML.TextList(List.rev tl))
109 :     in
110 : monnier 289 wrap(sty, t) :: tl'
111 : monnier 7 end
112 :    
113 :     (* push/pop a style from the devices style stack. A pop on an
114 :     * empty style stack is a nop.
115 :     *)
116 :     fun pushStyle (dev as DEV{emphStk, txt, ...}, sty) = (
117 :     emphStk := (concatTxt dev, sty) :: !emphStk;
118 :     txt := [])
119 :     fun popStyle (dev as DEV{emphStk, txt, ...}) = let
120 :     val (tl, sty)::r = !emphStk
121 :     in
122 :     txt := wrapStyle (sty, concatTxt dev, tl);
123 :     emphStk := r
124 :     end
125 :    
126 :     (* the default style for the device (this is the current style,
127 :     * if the style stack is empty).
128 :     *)
129 :     fun defaultStyle _ = NOEMPH
130 :    
131 :     (* maximum printing depth (in terms of boxes) *)
132 :     fun depth _ = NONE
133 :     (* the width of the device *)
134 :     fun lineWidth (DEV{lineWid, ...}) = SOME lineWid
135 :     (* the suggested maximum width of text on a line *)
136 :     fun textWidth (DEV{textWid, ...}) = textWid
137 :    
138 :     (* output some number of spaces to the device *)
139 :     fun space (dev, n) =
140 :     pcdata(dev, concat(List.tabulate (n, fn _ => " ")))
141 :    
142 :     (* output a new-line to the device *)
143 :     fun newline (dev as DEV{txt, ...}) =
144 :     txt := HTML.BR{clear=NONE} :: (concatTxt dev)
145 :    
146 :     (* output a string/character in the current style to the device *)
147 :     val string = pcdata
148 :     fun char (dev, c) = pcdata(dev, str c)
149 :    
150 :     (* flush is a nop for us *)
151 :     fun flush _ = ()
152 :    
153 : monnier 289 fun combineStyle (NOEMPH, sty) = sty
154 :     | combineStyle (sty, NOEMPH) = sty
155 :     | combineStyle (STYS l1, STYS l2) = STYS(l1 @ l2)
156 :     | combineStyle (sty, STYS l) = STYS(sty::l)
157 :     | combineStyle (sty1, sty2) = STYS[sty1, sty2]
158 :    
159 :     val styleNONE = NOEMPH
160 : monnier 7 val styleTT = TT
161 :     val styleI = I
162 :     val styleB = B
163 :     val styleU = U
164 :     val styleSTRIKE = STRIKE
165 :     val styleEM = EM
166 :     val styleSTRONG = STRONG
167 :     val styleDFN = DFN
168 :     val styleCODE = CODE
169 :     val styleSAMP = SAMP
170 :     val styleKBD = KBD
171 :     val styleVAR = VAR
172 :     val styleCITE = CITE
173 :     val color = COLOR
174 : jhr 596 fun link s = A{href=SOME s, name=NONE}
175 :     fun anchor s = A{href=NONE, name=SOME s}
176 :     fun linkAnchor {name, href} = A{href=SOME href, name = SOME name}
177 : monnier 7
178 :     fun openDev {wid, textWid} = DEV{
179 :     txt = ref [],
180 :     emphStk = ref [],
181 :     lineWid = wid,
182 :     textWid = textWid
183 :     }
184 :    
185 :     fun done (dev as DEV{emphStk = ref [], txt, ...}) = (case (concatTxt dev)
186 :     of [t] => (txt := []; t)
187 :     | l => (txt := []; HTML.TextList(List.rev l))
188 :     (* end case *))
189 :     | done _ = raise Fail "device is not done yet"
190 :    
191 :     end; (* HTMLDev *)
192 :    

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