Mercurial > urweb

annotate src/css.sml @ 2084:0d48cfb59b29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
More aggressive inlining of 'let' with record literals, plus some changes to Monoization of queries, to make inlining more common
author Adam Chlipala <adam@chlipala.net>
date Thu, 04 Dec 2014 02:47:24 -0500
parents 7c2229aa22fc
children
rev   line source
adam@1848 1 (* Copyright (c) 2010, 2013, 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
ziv@2055 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),
ziv@2055 104 ("cpassword", replaced),
adamc@1170 105 ("button", replaced),
adamc@1170 106 ("ccheckbox", replaced),
adamc@1170 107 ("cselect", replaced),
adamc@1170 108 ("ctextarea", replaced),
adamc@1170 109 ("tabl", table),
adamc@1170 110 ("tr", tr),
adamc@1170 111 ("th", td),
adamc@1170 112 ("td", td)]
adamc@1170 113
adamc@1170 114 val tags = foldl (fn ((tag, css), tags) =>
adamc@1170 115 SM.insert (tags, tag, css)) SM.empty tags
adamc@1170 116
adamc@1170 117 open Core
adamc@1170 118
adamc@1170 119 fun summarize file =
adamc@1170 120 let
adamc@1170 121 fun decl ((d, _), st as (globals, classes)) =
adamc@1170 122 let
adamc@1170 123 fun getTag (e, _) =
adamc@1170 124 case e of
adamc@1170 125 EFfi ("Basis", tag) => SOME tag
adamc@1170 126 | ECApp (e, _) => getTag e
adamc@1170 127 | EApp (e, _) => getTag e
adamc@1170 128 | _ => NONE
adamc@1170 129
adamc@1170 130 fun exp ((e, _), classes) =
adamc@1170 131 case e of
adamc@1170 132 EPrim _ => ([], classes)
adamc@1170 133 | ERel _ => ([], classes)
adamc@1170 134 | ENamed n =>
adamc@1170 135 (case IM.find (globals, n) of
adamc@1170 136 NONE => []
adamc@1170 137 | SOME (_, sm) => sm,
adamc@1170 138 classes)
adamc@1170 139 | ECon (_, _, _, NONE) => ([], classes)
adamc@1170 140 | ECon (_, _, _, SOME e) => exp (e, classes)
adamc@1170 141 | EFfi _ => ([], classes)
adam@1663 142 | EFfiApp (_, _, es) => expList (map #1 es, classes)
adamc@1170 143
adamc@1170 144 | EApp (
adamc@1170 145 (EApp (
adamc@1170 146 (EApp (
adamc@1170 147 (EApp (
adam@1646 148 (EApp (
adam@1754 149 (EApp (
adam@1754 150 (EApp (
adamc@1170 151 (ECApp (
adamc@1170 152 (ECApp (
adamc@1170 153 (ECApp (
adamc@1170 154 (ECApp (
adamc@1170 155 (ECApp (
adam@1646 156 (ECApp (
adam@1754 157 (ECApp (
adam@1754 158 (ECApp (
adam@1754 159 (EFfi ("Basis", "tag"),
adam@1754 160 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adam@1849 161 (ENamed class, _)), _),
adam@1754 162 _), _),
adam@1754 163 _), _),
adam@1646 164 _), _),
adamc@1170 165 attrs), _),
adamc@1170 166 tag), _),
adamc@1170 167 xml) =>
adamc@1170 168 let
adamc@1170 169 val (sm, classes) = exp (xml, classes)
adamc@1170 170 val (sm', classes) = exp (attrs, classes)
adamc@1170 171 val sm = merge' (sm, sm')
adamc@1170 172 in
adamc@1170 173 case getTag tag of
adamc@1170 174 NONE => (sm, classes)
adamc@1170 175 | SOME tag =>
adamc@1170 176 case SM.find (tags, tag) of
adamc@1170 177 NONE => (sm, classes)
adamc@1170 178 | SOME sm' =>
adamc@1170 179 let
adamc@1170 180 val sm'' = mergePC {parent = sm', child = sm}
adamc@1170 181 val old = Option.getOpt (IM.find (classes, class), nada)
adamc@1170 182 val classes = IM.insert (classes, class, merge (old, sm''))
adamc@1170 183 in
adamc@1170 184 (merge' (#1 sm', sm), classes)
adamc@1170 185 end
adamc@1170 186 end
adamc@1170 187
adamc@1170 188 | EApp (
adamc@1170 189 (EApp (
adamc@1170 190 (EApp (
adamc@1170 191 (EApp (
adam@1646 192 (EApp (
adam@1754 193 (EApp (
adam@1754 194 (EApp (
adamc@1170 195 (ECApp (
adamc@1170 196 (ECApp (
adamc@1170 197 (ECApp (
adamc@1170 198 (ECApp (
adamc@1170 199 (ECApp (
adam@1646 200 (ECApp (
adam@1754 201 (ECApp (
adam@1754 202 (ECApp (
adam@1754 203 (EFfi ("Basis", "tag"),
adam@1754 204 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adam@1754 205 _), _),
adam@1754 206 _), _),
adam@1646 207 _), _),
adamc@1170 208 _), _),
adamc@1170 209 attrs), _),
adamc@1170 210 tag), _),
adamc@1170 211 xml) =>
adamc@1170 212 let
adamc@1170 213 val (sm, classes) = exp (xml, classes)
adamc@1170 214 val (sm', classes) = exp (attrs, classes)
adamc@1170 215 val sm = merge' (sm, sm')
adamc@1170 216 in
adamc@1170 217 case getTag tag of
adamc@1170 218 NONE => (sm, classes)
adamc@1170 219 | SOME tag =>
adamc@1170 220 case SM.find (tags, tag) of
adamc@1170 221 NONE => (sm, classes)
adamc@1170 222 | SOME sm' => (merge' (#1 sm', sm), classes)
adamc@1170 223 end
adamc@1170 224
adamc@1170 225 | EApp (e1, e2) =>
adamc@1170 226 let
adamc@1170 227 val (sm1, classes) = exp (e1, classes)
adamc@1170 228 val (sm2, classes) = exp (e2, classes)
adamc@1170 229 in
adamc@1170 230 (merge' (sm1, sm2), classes)
adamc@1170 231 end
adamc@1170 232 | EAbs (_, _, _, e) => exp (e, classes)
adamc@1170 233 | ECApp (e, _) => exp (e, classes)
adamc@1170 234 | ECAbs (_, _, e) => exp (e, classes)
adamc@1170 235 | EKAbs (_, e) => exp (e, classes)
adamc@1170 236 | EKApp (e, _) => exp (e, classes)
adamc@1170 237 | ERecord xets => expList (map #2 xets, classes)
adamc@1170 238 | EField (e, _, _) => exp (e, classes)
adamc@1170 239 | EConcat (e1, _, e2, _) =>
adamc@1170 240 let
adamc@1170 241 val (sm1, classes) = exp (e1, classes)
adamc@1170 242 val (sm2, classes) = exp (e2, classes)
adamc@1170 243 in
adamc@1170 244 (merge' (sm1, sm2), classes)
adamc@1170 245 end
adamc@1170 246 | ECut (e, _, _) => exp (e, classes)
adamc@1170 247 | ECutMulti (e, _, _) => exp (e, classes)
adamc@1170 248 | ECase (e, pes, _) =>
adamc@1170 249 let
adamc@1170 250 val (sm, classes) = exp (e, classes)
adamc@1170 251 val (sms, classes) = expList (map #2 pes, classes)
adamc@1170 252 in
adamc@1170 253 (merge' (sm, sms), classes)
adamc@1170 254 end
adamc@1170 255 | EWrite e => exp (e, classes)
adamc@1170 256 | EClosure (_, es) => expList (es, classes)
adamc@1170 257 | ELet (_, _, e1, e2) =>
adamc@1170 258 let
adamc@1170 259 val (sm1, classes) = exp (e1, classes)
adamc@1170 260 val (sm2, classes) = exp (e2, classes)
adamc@1170 261 in
adamc@1170 262 (merge' (sm1, sm2), classes)
adamc@1170 263 end
adam@1848 264 | EServerCall (_, es, _, _) => expList (es, classes)
adamc@1170 265
adamc@1170 266 and expList (es, classes) = foldl (fn (e, (sm, classes)) =>
adamc@1170 267 let
adamc@1170 268 val (sm', classes) = exp (e, classes)
adamc@1170 269 in
adamc@1170 270 (merge' (sm, sm'), classes)
adamc@1170 271 end) ([], classes) es
adamc@1170 272 in
adamc@1170 273 case d of
adamc@1170 274 DCon _ => st
adamc@1170 275 | DDatatype _ => st
adamc@1170 276 | DVal (_, n, _, e, _) =>
adamc@1170 277 let
adamc@1170 278 val (sm, classes) = exp (e, classes)
adamc@1170 279 in
adamc@1170 280 (IM.insert (globals, n, (NONE, sm)), classes)
adamc@1170 281 end
adamc@1170 282 | DValRec vis =>
adamc@1170 283 let
adamc@1170 284 val (sm, classes) = foldl (fn ((_, _, _, e, _),
adamc@1170 285 (sm, classes)) =>
adamc@1170 286 let
adamc@1170 287 val (sm', classes) = exp (e, classes)
adamc@1170 288 in
adamc@1170 289 (merge' (sm', sm), classes)
adamc@1170 290 end) ([], classes) vis
adamc@1170 291 in
adamc@1170 292 (foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, (NONE, sm))) globals vis,
adamc@1170 293 classes)
adamc@1170 294 end
adamc@1170 295 | DExport _ => st
adamc@1170 296 | DTable _ => st
adamc@1170 297 | DSequence _ => st
adamc@1170 298 | DView _ => st
adamc@1170 299 | DDatabase _ => st
adamc@1170 300 | DCookie _ => st
adamc@1170 301 | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes)
adamc@1170 302 | DTask _ => st
adamc@1199 303 | DPolicy _ => st
adam@1294 304 | DOnError _ => st
adamc@1170 305 end
adamc@1170 306
adamc@1170 307 val (globals, classes) = foldl decl (IM.empty, IM.empty) file
adamc@1170 308 in
adamc@1170 309 {Overall = IM.foldl (fn ((_, sm), sm') => merge' (sm, sm')) [] globals,
adamc@1170 310 Classes = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER)
adamc@1170 311 (List.mapPartial (fn (i, sm) =>
adamc@1170 312 case IM.find (globals, i) of
adamc@1170 313 SOME (SOME s, _) => SOME (s, sm)
adamc@1170 314 | _ => NONE) (IM.listItemsi classes))}
adamc@1170 315 end
adamc@1170 316
adamc@1170 317 type report = {Overall : inheritable list,
adamc@1170 318 Classes : (string * summary) list}
adamc@1170 319
adamc@1170 320 end