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