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