Mercurial > urweb

annotate src/css.sml @ 1688:8c2e8d41a8f2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Correct an SQL grammar omission (thanks to Alexei Golovko for spotting the problem)
author Adam Chlipala <adam@chlipala.net>
date Sat, 25 Feb 2012 15:34:44 -0500
parents 0577be31a435
children a1380fc15cb5
rev   line source
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)
adam@1663 141 | EFfiApp (_, _, es) => expList (map #1 es, classes)
adamc@1170 142
adamc@1170 143 | EApp (
adamc@1170 144 (EApp (
adamc@1170 145 (EApp (
adamc@1170 146 (EApp (
adam@1646 147 (EApp (
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 (
adam@1646 155 (ECApp (
adam@1646 156 (EFfi ("Basis", "tag"),
adam@1646 157 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adam@1646 158 (ECon (_, _, _, SOME (ENamed class, _)), _)), _),
adam@1646 159 _), _),
adamc@1170 160 attrs), _),
adamc@1170 161 tag), _),
adamc@1170 162 xml) =>
adamc@1170 163 let
adamc@1170 164 val (sm, classes) = exp (xml, classes)
adamc@1170 165 val (sm', classes) = exp (attrs, classes)
adamc@1170 166 val sm = merge' (sm, sm')
adamc@1170 167 in
adamc@1170 168 case getTag tag of
adamc@1170 169 NONE => (sm, classes)
adamc@1170 170 | SOME tag =>
adamc@1170 171 case SM.find (tags, tag) of
adamc@1170 172 NONE => (sm, classes)
adamc@1170 173 | SOME sm' =>
adamc@1170 174 let
adamc@1170 175 val sm'' = mergePC {parent = sm', child = sm}
adamc@1170 176 val old = Option.getOpt (IM.find (classes, class), nada)
adamc@1170 177 val classes = IM.insert (classes, class, merge (old, sm''))
adamc@1170 178 in
adamc@1170 179 (merge' (#1 sm', sm), classes)
adamc@1170 180 end
adamc@1170 181 end
adamc@1170 182
adamc@1170 183 | EApp (
adamc@1170 184 (EApp (
adamc@1170 185 (EApp (
adamc@1170 186 (EApp (
adam@1646 187 (EApp (
adamc@1170 188 (ECApp (
adamc@1170 189 (ECApp (
adamc@1170 190 (ECApp (
adamc@1170 191 (ECApp (
adamc@1170 192 (ECApp (
adamc@1170 193 (ECApp (
adamc@1170 194 (ECApp (
adam@1646 195 (ECApp (
adam@1646 196 (EFfi ("Basis", "tag"),
adam@1646 197 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adam@1646 198 _), _),
adamc@1170 199 _), _),
adamc@1170 200 attrs), _),
adamc@1170 201 tag), _),
adamc@1170 202 xml) =>
adamc@1170 203 let
adamc@1170 204 val (sm, classes) = exp (xml, classes)
adamc@1170 205 val (sm', classes) = exp (attrs, classes)
adamc@1170 206 val sm = merge' (sm, sm')
adamc@1170 207 in
adamc@1170 208 case getTag tag of
adamc@1170 209 NONE => (sm, classes)
adamc@1170 210 | SOME tag =>
adamc@1170 211 case SM.find (tags, tag) of
adamc@1170 212 NONE => (sm, classes)
adamc@1170 213 | SOME sm' => (merge' (#1 sm', sm), classes)
adamc@1170 214 end
adamc@1170 215
adamc@1170 216 | EApp (e1, e2) =>
adamc@1170 217 let
adamc@1170 218 val (sm1, classes) = exp (e1, classes)
adamc@1170 219 val (sm2, classes) = exp (e2, classes)
adamc@1170 220 in
adamc@1170 221 (merge' (sm1, sm2), classes)
adamc@1170 222 end
adamc@1170 223 | EAbs (_, _, _, e) => exp (e, classes)
adamc@1170 224 | ECApp (e, _) => exp (e, classes)
adamc@1170 225 | ECAbs (_, _, e) => exp (e, classes)
adamc@1170 226 | EKAbs (_, e) => exp (e, classes)
adamc@1170 227 | EKApp (e, _) => exp (e, classes)
adamc@1170 228 | ERecord xets => expList (map #2 xets, classes)
adamc@1170 229 | EField (e, _, _) => exp (e, classes)
adamc@1170 230 | EConcat (e1, _, e2, _) =>
adamc@1170 231 let
adamc@1170 232 val (sm1, classes) = exp (e1, classes)
adamc@1170 233 val (sm2, classes) = exp (e2, classes)
adamc@1170 234 in
adamc@1170 235 (merge' (sm1, sm2), classes)
adamc@1170 236 end
adamc@1170 237 | ECut (e, _, _) => exp (e, classes)
adamc@1170 238 | ECutMulti (e, _, _) => exp (e, classes)
adamc@1170 239 | ECase (e, pes, _) =>
adamc@1170 240 let
adamc@1170 241 val (sm, classes) = exp (e, classes)
adamc@1170 242 val (sms, classes) = expList (map #2 pes, classes)
adamc@1170 243 in
adamc@1170 244 (merge' (sm, sms), classes)
adamc@1170 245 end
adamc@1170 246 | EWrite e => exp (e, classes)
adamc@1170 247 | EClosure (_, es) => expList (es, classes)
adamc@1170 248 | ELet (_, _, e1, e2) =>
adamc@1170 249 let
adamc@1170 250 val (sm1, classes) = exp (e1, classes)
adamc@1170 251 val (sm2, classes) = exp (e2, classes)
adamc@1170 252 in
adamc@1170 253 (merge' (sm1, sm2), classes)
adamc@1170 254 end
adamc@1170 255 | EServerCall (_, es, _) => expList (es, classes)
adamc@1170 256
adamc@1170 257 and expList (es, classes) = foldl (fn (e, (sm, classes)) =>
adamc@1170 258 let
adamc@1170 259 val (sm', classes) = exp (e, classes)
adamc@1170 260 in
adamc@1170 261 (merge' (sm, sm'), classes)
adamc@1170 262 end) ([], classes) es
adamc@1170 263 in
adamc@1170 264 case d of
adamc@1170 265 DCon _ => st
adamc@1170 266 | DDatatype _ => st
adamc@1170 267 | DVal (_, n, _, e, _) =>
adamc@1170 268 let
adamc@1170 269 val (sm, classes) = exp (e, classes)
adamc@1170 270 in
adamc@1170 271 (IM.insert (globals, n, (NONE, sm)), classes)
adamc@1170 272 end
adamc@1170 273 | DValRec vis =>
adamc@1170 274 let
adamc@1170 275 val (sm, classes) = foldl (fn ((_, _, _, e, _),
adamc@1170 276 (sm, classes)) =>
adamc@1170 277 let
adamc@1170 278 val (sm', classes) = exp (e, classes)
adamc@1170 279 in
adamc@1170 280 (merge' (sm', sm), classes)
adamc@1170 281 end) ([], classes) vis
adamc@1170 282 in
adamc@1170 283 (foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, (NONE, sm))) globals vis,
adamc@1170 284 classes)
adamc@1170 285 end
adamc@1170 286 | DExport _ => st
adamc@1170 287 | DTable _ => st
adamc@1170 288 | DSequence _ => st
adamc@1170 289 | DView _ => st
adamc@1170 290 | DDatabase _ => st
adamc@1170 291 | DCookie _ => st
adamc@1170 292 | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes)
adamc@1170 293 | DTask _ => st
adamc@1199 294 | DPolicy _ => st
adam@1294 295 | DOnError _ => st
adamc@1170 296 end
adamc@1170 297
adamc@1170 298 val (globals, classes) = foldl decl (IM.empty, IM.empty) file
adamc@1170 299 in
adamc@1170 300 {Overall = IM.foldl (fn ((_, sm), sm') => merge' (sm, sm')) [] globals,
adamc@1170 301 Classes = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER)
adamc@1170 302 (List.mapPartial (fn (i, sm) =>
adamc@1170 303 case IM.find (globals, i) of
adamc@1170 304 SOME (SOME s, _) => SOME (s, sm)
adamc@1170 305 | _ => NONE) (IM.listItemsi classes))}
adamc@1170 306 end
adamc@1170 307
adamc@1170 308 type report = {Overall : inheritable list,
adamc@1170 309 Classes : (string * summary) list}
adamc@1170 310
adamc@1170 311 end