Mercurial > urweb

comparison src/css.sml @ 1170:52c6ac6a59f1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Basic analysis of tag and CSS class usage
author Adam Chlipala <adamc@hcoop.net>
date Sat, 27 Feb 2010 14:57:57 -0500
parents
children c316ca3c9ec6
comparison
equal deleted inserted replaced
1169:420e38516dc2 1170:52c6ac6a59f1
1 (* Copyright (c) 2010, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 structure Css :> CSS = struct
29
30 structure IM = IntBinaryMap
31
32 structure SM = BinaryMapFn(struct
33 type ord_key = string
34 val compare = String.compare
35 end)
36
37 datatype inheritable = Block | List | Table | Caption | Td
38 datatype others = OBlock | OTable | OTd | Tr | NonReplacedInline | ReplacedInline | Width | Height
39
40 fun inheritableToString x =
41 case x of
42 Block => "B"
43 | List => "L"
44 | Table => "T"
45 | Caption => "C"
46 | Td => "D"
47
48 fun othersToString x =
49 case x of
50 OBlock => "b"
51 | OTable => "t"
52 | OTd => "d"
53 | Tr => "-"
54 | NonReplacedInline => "N"
55 | ReplacedInline => "R"
56 | Width => "W"
57 | Height => "H"
58
59 type summary = inheritable list * others list
60
61 fun merge' (ls1, ls2) = foldl (fn (x, ls) => if List.exists (fn y => y = x) ls then ls else x :: ls) ls2 ls1
62 fun merge ((in1, ot1), (in2, ot2)) = (merge' (in1, in2), merge' (ot1, ot2))
63 fun mergePC {parent = (in1, ot1), child = in2} = (merge' (in1, in2), ot1)
64
65 val nada = ([], [])
66 val block = ([Block], [OBlock, Width, Height])
67 val inline = ([], [NonReplacedInline])
68 val list = ([Block, List], [OBlock, Width, Height])
69 val replaced = ([], [ ReplacedInline, Width, Height])
70 val table = ([Block, Table], [OBlock, OTable, Width, Height])
71 val tr = ([Block], [OBlock, Tr, Width])
72 val td = ([Block, Td], [OBlock, OTd, Height])
73
74 val tags = [("span", inline),
75 ("div", block),
76 ("p", block),
77 ("b", inline),
78 ("i", inline),
79 ("tt", inline),
80 ("h1", block),
81 ("h2", block),
82 ("h3", block),
83 ("h4", block),
84 ("h5", block),
85 ("h6", block),
86 ("li", list),
87 ("ol", list),
88 ("ul", list),
89 ("hr", block),
90 ("a", inline),
91 ("img", replaced),
92 ("form", block),
93 ("hidden", replaced),
94 ("textbox", replaced),
95 ("password", replaced),
96 ("textarea", replaced),
97 ("checkbox", replaced),
98 ("upload", replaced),
99 ("radio", replaced),
100 ("select", replaced),
101 ("submit", replaced),
102 ("label", inline),
103 ("ctextbox", replaced),
104 ("button", replaced),
105 ("ccheckbox", replaced),
106 ("cselect", replaced),
107 ("ctextarea", replaced),
108 ("tabl", table),
109 ("tr", tr),
110 ("th", td),
111 ("td", td)]
112
113 val tags = foldl (fn ((tag, css), tags) =>
114 SM.insert (tags, tag, css)) SM.empty tags
115
116 open Core
117
118 fun summarize file =
119 let
120 fun decl ((d, _), st as (globals, classes)) =
121 let
122 fun getTag (e, _) =
123 case e of
124 EFfi ("Basis", tag) => SOME tag
125 | ECApp (e, _) => getTag e
126 | EApp (e, _) => getTag e
127 | _ => NONE
128
129 fun exp ((e, _), classes) =
130 case e of
131 EPrim _ => ([], classes)
132 | ERel _ => ([], classes)
133 | ENamed n =>
134 (case IM.find (globals, n) of
135 NONE => []
136 | SOME (_, sm) => sm,
137 classes)
138 | ECon (_, _, _, NONE) => ([], classes)
139 | ECon (_, _, _, SOME e) => exp (e, classes)
140 | EFfi _ => ([], classes)
141 | EFfiApp (_, _, es) => expList (es, classes)
142
143 | EApp (
144 (EApp (
145 (EApp (
146 (EApp (
147 (ECApp (
148 (ECApp (
149 (ECApp (
150 (ECApp (
151 (ECApp (
152 (ECApp (
153 (ECApp (
154 (ECApp (
155 (EFfi ("Basis", "tag"),
156 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
157 (ECon (_, _, _, SOME (ENamed class, _)), _)), _),
158 attrs), _),
159 tag), _),
160 xml) =>
161 let
162 val (sm, classes) = exp (xml, classes)
163 val (sm', classes) = exp (attrs, classes)
164 val sm = merge' (sm, sm')
165 in
166 case getTag tag of
167 NONE => (sm, classes)
168 | SOME tag =>
169 case SM.find (tags, tag) of
170 NONE => (sm, classes)
171 | SOME sm' =>
172 let
173 val sm'' = mergePC {parent = sm', child = sm}
174 val old = Option.getOpt (IM.find (classes, class), nada)
175 val classes = IM.insert (classes, class, merge (old, sm''))
176 in
177 (merge' (#1 sm', sm), classes)
178 end
179 end
180
181 | EApp (
182 (EApp (
183 (EApp (
184 (EApp (
185 (ECApp (
186 (ECApp (
187 (ECApp (
188 (ECApp (
189 (ECApp (
190 (ECApp (
191 (ECApp (
192 (ECApp (
193 (EFfi ("Basis", "tag"),
194 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
195 _), _),
196 attrs), _),
197 tag), _),
198 xml) =>
199 let
200 val (sm, classes) = exp (xml, classes)
201 val (sm', classes) = exp (attrs, classes)
202 val sm = merge' (sm, sm')
203 in
204 case getTag tag of
205 NONE => (sm, classes)
206 | SOME tag =>
207 case SM.find (tags, tag) of
208 NONE => (sm, classes)
209 | SOME sm' => (merge' (#1 sm', sm), classes)
210 end
211
212 | EApp (e1, e2) =>
213 let
214 val (sm1, classes) = exp (e1, classes)
215 val (sm2, classes) = exp (e2, classes)
216 in
217 (merge' (sm1, sm2), classes)
218 end
219 | EAbs (_, _, _, e) => exp (e, classes)
220 | ECApp (e, _) => exp (e, classes)
221 | ECAbs (_, _, e) => exp (e, classes)
222 | EKAbs (_, e) => exp (e, classes)
223 | EKApp (e, _) => exp (e, classes)
224 | ERecord xets => expList (map #2 xets, classes)
225 | EField (e, _, _) => exp (e, classes)
226 | EConcat (e1, _, e2, _) =>
227 let
228 val (sm1, classes) = exp (e1, classes)
229 val (sm2, classes) = exp (e2, classes)
230 in
231 (merge' (sm1, sm2), classes)
232 end
233 | ECut (e, _, _) => exp (e, classes)
234 | ECutMulti (e, _, _) => exp (e, classes)
235 | ECase (e, pes, _) =>
236 let
237 val (sm, classes) = exp (e, classes)
238 val (sms, classes) = expList (map #2 pes, classes)
239 in
240 (merge' (sm, sms), classes)
241 end
242 | EWrite e => exp (e, classes)
243 | EClosure (_, es) => expList (es, classes)
244 | ELet (_, _, e1, e2) =>
245 let
246 val (sm1, classes) = exp (e1, classes)
247 val (sm2, classes) = exp (e2, classes)
248 in
249 (merge' (sm1, sm2), classes)
250 end
251 | EServerCall (_, es, _) => expList (es, classes)
252
253 and expList (es, classes) = foldl (fn (e, (sm, classes)) =>
254 let
255 val (sm', classes) = exp (e, classes)
256 in
257 (merge' (sm, sm'), classes)
258 end) ([], classes) es
259 in
260 case d of
261 DCon _ => st
262 | DDatatype _ => st
263 | DVal (_, n, _, e, _) =>
264 let
265 val (sm, classes) = exp (e, classes)
266 in
267 (IM.insert (globals, n, (NONE, sm)), classes)
268 end
269 | DValRec vis =>
270 let
271 val (sm, classes) = foldl (fn ((_, _, _, e, _),
272 (sm, classes)) =>
273 let
274 val (sm', classes) = exp (e, classes)
275 in
276 (merge' (sm', sm), classes)
277 end) ([], classes) vis
278 in
279 (foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, (NONE, sm))) globals vis,
280 classes)
281 end
282 | DExport _ => st
283 | DTable _ => st
284 | DSequence _ => st
285 | DView _ => st
286 | DDatabase _ => st
287 | DCookie _ => st
288 | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes)
289 | DTask _ => st
290 end
291
292 val (globals, classes) = foldl decl (IM.empty, IM.empty) file
293 in
294 {Overall = IM.foldl (fn ((_, sm), sm') => merge' (sm, sm')) [] globals,
295 Classes = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER)
296 (List.mapPartial (fn (i, sm) =>
297 case IM.find (globals, i) of
298 SOME (SOME s, _) => SOME (s, sm)
299 | _ => NONE) (IM.listItemsi classes))}
300 end
301
302 type report = {Overall : inheritable list,
303 Classes : (string * summary) list}
304
305 end