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 290 - (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 :    
40 : monnier 7 val openDev : {wid : int, textWid : int option} -> device
41 :     val done : device -> HTML.text
42 :    
43 :     end = struct
44 :    
45 :     datatype style
46 :     = NOEMPH
47 :     | TT | I | B | U | STRIKE | EM
48 :     | STRONG | DFN | CODE | SAMP | KBD
49 :     | VAR | CITE
50 :     | COLOR of string
51 : monnier 289 | LINK of string
52 :     | ANCHOR of string
53 :     | 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 :     | wrap (LINK s, t) = HTML.A{
103 :     name = NONE, href = SOME s,
104 :     rel = NONE, rev = NONE, title = NONE,
105 :     content = t
106 :     }
107 :     | wrap (ANCHOR s, t) = HTML.A{
108 :     name = SOME s, href = NONE,
109 :     rel = NONE, rev = NONE, title = NONE,
110 :     content = t
111 :     }
112 :     | wrap (STYS l, t) = List.foldr wrap t l
113 : monnier 7 val t = (case tl of [t] => t | _ => HTML.TextList(List.rev tl))
114 :     in
115 : monnier 289 wrap(sty, t) :: tl'
116 : monnier 7 end
117 :    
118 :     (* push/pop a style from the devices style stack. A pop on an
119 :     * empty style stack is a nop.
120 :     *)
121 :     fun pushStyle (dev as DEV{emphStk, txt, ...}, sty) = (
122 :     emphStk := (concatTxt dev, sty) :: !emphStk;
123 :     txt := [])
124 :     fun popStyle (dev as DEV{emphStk, txt, ...}) = let
125 :     val (tl, sty)::r = !emphStk
126 :     in
127 :     txt := wrapStyle (sty, concatTxt dev, tl);
128 :     emphStk := r
129 :     end
130 :    
131 :     (* the default style for the device (this is the current style,
132 :     * if the style stack is empty).
133 :     *)
134 :     fun defaultStyle _ = NOEMPH
135 :    
136 :     (* maximum printing depth (in terms of boxes) *)
137 :     fun depth _ = NONE
138 :     (* the width of the device *)
139 :     fun lineWidth (DEV{lineWid, ...}) = SOME lineWid
140 :     (* the suggested maximum width of text on a line *)
141 :     fun textWidth (DEV{textWid, ...}) = textWid
142 :    
143 :     (* output some number of spaces to the device *)
144 :     fun space (dev, n) =
145 :     pcdata(dev, concat(List.tabulate (n, fn _ => " ")))
146 :    
147 :     (* output a new-line to the device *)
148 :     fun newline (dev as DEV{txt, ...}) =
149 :     txt := HTML.BR{clear=NONE} :: (concatTxt dev)
150 :    
151 :     (* output a string/character in the current style to the device *)
152 :     val string = pcdata
153 :     fun char (dev, c) = pcdata(dev, str c)
154 :    
155 :     (* flush is a nop for us *)
156 :     fun flush _ = ()
157 :    
158 : monnier 289 fun combineStyle (NOEMPH, sty) = sty
159 :     | combineStyle (sty, NOEMPH) = sty
160 :     | combineStyle (STYS l1, STYS l2) = STYS(l1 @ l2)
161 :     | combineStyle (sty, STYS l) = STYS(sty::l)
162 :     | combineStyle (sty1, sty2) = STYS[sty1, sty2]
163 :    
164 :     val styleNONE = NOEMPH
165 : monnier 7 val styleTT = TT
166 :     val styleI = I
167 :     val styleB = B
168 :     val styleU = U
169 :     val styleSTRIKE = STRIKE
170 :     val styleEM = EM
171 :     val styleSTRONG = STRONG
172 :     val styleDFN = DFN
173 :     val styleCODE = CODE
174 :     val styleSAMP = SAMP
175 :     val styleKBD = KBD
176 :     val styleVAR = VAR
177 :     val styleCITE = CITE
178 :     val color = COLOR
179 : monnier 289 val link = LINK
180 :     val anchor = ANCHOR
181 : monnier 7
182 :     fun openDev {wid, textWid} = DEV{
183 :     txt = ref [],
184 :     emphStk = ref [],
185 :     lineWid = wid,
186 :     textWid = textWid
187 :     }
188 :    
189 :     fun done (dev as DEV{emphStk = ref [], txt, ...}) = (case (concatTxt dev)
190 :     of [t] => (txt := []; t)
191 :     | l => (txt := []; HTML.TextList(List.rev l))
192 :     (* end case *))
193 :     | done _ = raise Fail "device is not done yet"
194 :    
195 :     end; (* HTMLDev *)
196 :    

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