Mercurial > urweb

annotate src/css.sml @ 2159:9029e0e2c67c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Stray character in a comment
author Adam Chlipala <adam@chlipala.net>
date Sat, 04 Jul 2015 18:44:52 -0400
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