adamc@1170: (* Copyright (c) 2010, Adam Chlipala adamc@1170: * All rights reserved. adamc@1170: * adamc@1170: * Redistribution and use in source and binary forms, with or without adamc@1170: * modification, are permitted provided that the following conditions are met: adamc@1170: * adamc@1170: * - Redistributions of source code must retain the above copyright notice, adamc@1170: * this list of conditions and the following disclaimer. adamc@1170: * - Redistributions in binary form must reproduce the above copyright notice, adamc@1170: * this list of conditions and the following disclaimer in the documentation adamc@1170: * and/or other materials provided with the distribution. adamc@1170: * - The names of contributors may not be used to endorse or promote products adamc@1170: * derived from this software without specific prior written permission. adamc@1170: * adamc@1170: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@1170: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@1170: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@1170: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@1170: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@1170: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@1170: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@1170: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@1170: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@1170: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@1170: * POSSIBILITY OF SUCH DAMAGE. adamc@1170: *) adamc@1170: adamc@1170: structure Css :> CSS = struct adamc@1170: adamc@1170: structure IM = IntBinaryMap adamc@1170: adamc@1170: structure SM = BinaryMapFn(struct adamc@1170: type ord_key = string adamc@1170: val compare = String.compare adamc@1170: end) adamc@1170: adamc@1170: datatype inheritable = Block | List | Table | Caption | Td adamc@1170: datatype others = OBlock | OTable | OTd | Tr | NonReplacedInline | ReplacedInline | Width | Height adamc@1170: adamc@1170: fun inheritableToString x = adamc@1170: case x of adamc@1170: Block => "B" adamc@1170: | List => "L" adamc@1170: | Table => "T" adamc@1170: | Caption => "C" adamc@1170: | Td => "D" adamc@1170: adamc@1170: fun othersToString x = adamc@1170: case x of adamc@1170: OBlock => "b" adamc@1170: | OTable => "t" adamc@1170: | OTd => "d" adamc@1170: | Tr => "-" adamc@1170: | NonReplacedInline => "N" adamc@1170: | ReplacedInline => "R" adamc@1170: | Width => "W" adamc@1170: | Height => "H" adamc@1170: adamc@1170: type summary = inheritable list * others list adamc@1170: adamc@1170: 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: fun merge ((in1, ot1), (in2, ot2)) = (merge' (in1, in2), merge' (ot1, ot2)) adamc@1170: fun mergePC {parent = (in1, ot1), child = in2} = (merge' (in1, in2), ot1) adamc@1170: adamc@1170: val nada = ([], []) adamc@1170: val block = ([Block], [OBlock, Width, Height]) adamc@1170: val inline = ([], [NonReplacedInline]) adamc@1170: val list = ([Block, List], [OBlock, Width, Height]) adamc@1170: val replaced = ([], [ ReplacedInline, Width, Height]) adamc@1170: val table = ([Block, Table], [OBlock, OTable, Width, Height]) adamc@1170: val tr = ([Block], [OBlock, Tr, Width]) adamc@1170: val td = ([Block, Td], [OBlock, OTd, Height]) adamc@1170: adamc@1170: val tags = [("span", inline), adamc@1170: ("div", block), adamc@1170: ("p", block), adamc@1170: ("b", inline), adamc@1170: ("i", inline), adamc@1170: ("tt", inline), adamc@1170: ("h1", block), adamc@1170: ("h2", block), adamc@1170: ("h3", block), adamc@1170: ("h4", block), adamc@1170: ("h5", block), adamc@1170: ("h6", block), adamc@1170: ("li", list), adamc@1170: ("ol", list), adamc@1170: ("ul", list), adamc@1170: ("hr", block), adamc@1170: ("a", inline), adamc@1170: ("img", replaced), adamc@1170: ("form", block), adamc@1170: ("hidden", replaced), adamc@1170: ("textbox", replaced), adamc@1170: ("password", replaced), adamc@1170: ("textarea", replaced), adamc@1170: ("checkbox", replaced), adamc@1170: ("upload", replaced), adamc@1170: ("radio", replaced), adamc@1170: ("select", replaced), adamc@1170: ("submit", replaced), adamc@1170: ("label", inline), adamc@1170: ("ctextbox", replaced), adamc@1170: ("button", replaced), adamc@1170: ("ccheckbox", replaced), adamc@1170: ("cselect", replaced), adamc@1170: ("ctextarea", replaced), adamc@1170: ("tabl", table), adamc@1170: ("tr", tr), adamc@1170: ("th", td), adamc@1170: ("td", td)] adamc@1170: adamc@1170: val tags = foldl (fn ((tag, css), tags) => adamc@1170: SM.insert (tags, tag, css)) SM.empty tags adamc@1170: adamc@1170: open Core adamc@1170: adamc@1170: fun summarize file = adamc@1170: let adamc@1170: fun decl ((d, _), st as (globals, classes)) = adamc@1170: let adamc@1170: fun getTag (e, _) = adamc@1170: case e of adamc@1170: EFfi ("Basis", tag) => SOME tag adamc@1170: | ECApp (e, _) => getTag e adamc@1170: | EApp (e, _) => getTag e adamc@1170: | _ => NONE adamc@1170: adamc@1170: fun exp ((e, _), classes) = adamc@1170: case e of adamc@1170: EPrim _ => ([], classes) adamc@1170: | ERel _ => ([], classes) adamc@1170: | ENamed n => adamc@1170: (case IM.find (globals, n) of adamc@1170: NONE => [] adamc@1170: | SOME (_, sm) => sm, adamc@1170: classes) adamc@1170: | ECon (_, _, _, NONE) => ([], classes) adamc@1170: | ECon (_, _, _, SOME e) => exp (e, classes) adamc@1170: | EFfi _ => ([], classes) adamc@1170: | EFfiApp (_, _, es) => expList (es, classes) adamc@1170: adamc@1170: | EApp ( adamc@1170: (EApp ( adamc@1170: (EApp ( adamc@1170: (EApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (EFfi ("Basis", "tag"), adamc@1170: _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), adamc@1170: (ECon (_, _, _, SOME (ENamed class, _)), _)), _), adamc@1170: attrs), _), adamc@1170: tag), _), adamc@1170: xml) => adamc@1170: let adamc@1170: val (sm, classes) = exp (xml, classes) adamc@1170: val (sm', classes) = exp (attrs, classes) adamc@1170: val sm = merge' (sm, sm') adamc@1170: in adamc@1170: case getTag tag of adamc@1170: NONE => (sm, classes) adamc@1170: | SOME tag => adamc@1170: case SM.find (tags, tag) of adamc@1170: NONE => (sm, classes) adamc@1170: | SOME sm' => adamc@1170: let adamc@1170: val sm'' = mergePC {parent = sm', child = sm} adamc@1170: val old = Option.getOpt (IM.find (classes, class), nada) adamc@1170: val classes = IM.insert (classes, class, merge (old, sm'')) adamc@1170: in adamc@1170: (merge' (#1 sm', sm), classes) adamc@1170: end adamc@1170: end adamc@1170: adamc@1170: | EApp ( adamc@1170: (EApp ( adamc@1170: (EApp ( adamc@1170: (EApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (ECApp ( adamc@1170: (EFfi ("Basis", "tag"), adamc@1170: _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), adamc@1170: _), _), adamc@1170: attrs), _), adamc@1170: tag), _), adamc@1170: xml) => adamc@1170: let adamc@1170: val (sm, classes) = exp (xml, classes) adamc@1170: val (sm', classes) = exp (attrs, classes) adamc@1170: val sm = merge' (sm, sm') adamc@1170: in adamc@1170: case getTag tag of adamc@1170: NONE => (sm, classes) adamc@1170: | SOME tag => adamc@1170: case SM.find (tags, tag) of adamc@1170: NONE => (sm, classes) adamc@1170: | SOME sm' => (merge' (#1 sm', sm), classes) adamc@1170: end adamc@1170: adamc@1170: | EApp (e1, e2) => adamc@1170: let adamc@1170: val (sm1, classes) = exp (e1, classes) adamc@1170: val (sm2, classes) = exp (e2, classes) adamc@1170: in adamc@1170: (merge' (sm1, sm2), classes) adamc@1170: end adamc@1170: | EAbs (_, _, _, e) => exp (e, classes) adamc@1170: | ECApp (e, _) => exp (e, classes) adamc@1170: | ECAbs (_, _, e) => exp (e, classes) adamc@1170: | EKAbs (_, e) => exp (e, classes) adamc@1170: | EKApp (e, _) => exp (e, classes) adamc@1170: | ERecord xets => expList (map #2 xets, classes) adamc@1170: | EField (e, _, _) => exp (e, classes) adamc@1170: | EConcat (e1, _, e2, _) => adamc@1170: let adamc@1170: val (sm1, classes) = exp (e1, classes) adamc@1170: val (sm2, classes) = exp (e2, classes) adamc@1170: in adamc@1170: (merge' (sm1, sm2), classes) adamc@1170: end adamc@1170: | ECut (e, _, _) => exp (e, classes) adamc@1170: | ECutMulti (e, _, _) => exp (e, classes) adamc@1170: | ECase (e, pes, _) => adamc@1170: let adamc@1170: val (sm, classes) = exp (e, classes) adamc@1170: val (sms, classes) = expList (map #2 pes, classes) adamc@1170: in adamc@1170: (merge' (sm, sms), classes) adamc@1170: end adamc@1170: | EWrite e => exp (e, classes) adamc@1170: | EClosure (_, es) => expList (es, classes) adamc@1170: | ELet (_, _, e1, e2) => adamc@1170: let adamc@1170: val (sm1, classes) = exp (e1, classes) adamc@1170: val (sm2, classes) = exp (e2, classes) adamc@1170: in adamc@1170: (merge' (sm1, sm2), classes) adamc@1170: end adamc@1170: | EServerCall (_, es, _) => expList (es, classes) adamc@1170: adamc@1170: and expList (es, classes) = foldl (fn (e, (sm, classes)) => adamc@1170: let adamc@1170: val (sm', classes) = exp (e, classes) adamc@1170: in adamc@1170: (merge' (sm, sm'), classes) adamc@1170: end) ([], classes) es adamc@1170: in adamc@1170: case d of adamc@1170: DCon _ => st adamc@1170: | DDatatype _ => st adamc@1170: | DVal (_, n, _, e, _) => adamc@1170: let adamc@1170: val (sm, classes) = exp (e, classes) adamc@1170: in adamc@1170: (IM.insert (globals, n, (NONE, sm)), classes) adamc@1170: end adamc@1170: | DValRec vis => adamc@1170: let adamc@1170: val (sm, classes) = foldl (fn ((_, _, _, e, _), adamc@1170: (sm, classes)) => adamc@1170: let adamc@1170: val (sm', classes) = exp (e, classes) adamc@1170: in adamc@1170: (merge' (sm', sm), classes) adamc@1170: end) ([], classes) vis adamc@1170: in adamc@1170: (foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, (NONE, sm))) globals vis, adamc@1170: classes) adamc@1170: end adamc@1170: | DExport _ => st adamc@1170: | DTable _ => st adamc@1170: | DSequence _ => st adamc@1170: | DView _ => st adamc@1170: | DDatabase _ => st adamc@1170: | DCookie _ => st adamc@1170: | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes) adamc@1170: | DTask _ => st adamc@1170: end adamc@1170: adamc@1170: val (globals, classes) = foldl decl (IM.empty, IM.empty) file adamc@1170: in adamc@1170: {Overall = IM.foldl (fn ((_, sm), sm') => merge' (sm, sm')) [] globals, adamc@1170: Classes = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER) adamc@1170: (List.mapPartial (fn (i, sm) => adamc@1170: case IM.find (globals, i) of adamc@1170: SOME (SOME s, _) => SOME (s, sm) adamc@1170: | _ => NONE) (IM.listItemsi classes))} adamc@1170: end adamc@1170: adamc@1170: type report = {Overall : inheritable list, adamc@1170: Classes : (string * summary) list} adamc@1170: adamc@1170: end