changeset 1170:52c6ac6a59f1

Basic analysis of tag and CSS class usage
author Adam Chlipala <adamc@hcoop.net>
date Sat, 27 Feb 2010 14:57:57 -0500
parents 420e38516dc2
children 7a2a7a8f9cab
files doc/manual.tex src/compiler.sig src/compiler.sml src/css.sig src/css.sml src/main.mlton.sml src/sources
diffstat 7 files changed, 385 insertions(+), 3 deletions(-) [+]
line wrap: on
line diff
--- a/doc/manual.tex	Thu Feb 25 15:08:52 2010 -0500
+++ b/doc/manual.tex	Sat Feb 27 14:57:57 2010 -0500
@@ -176,6 +176,12 @@
 urweb -tc P
 \end{verbatim}
 
+To output information relevant to CSS stylesheets (and not finish regular compilation), run
+\begin{verbatim}
+urweb -css P
+\end{verbatim}
+The first output line is a list of categories of CSS properties that would be worth setting on the document body.  The remaining lines are space-separated pairs of CSS class names and categories of properties that would be worth setting for that class.  The category codes are divided into two varieties.  Codes that reveal properties of a tag or its (recursive) children are \cd{B} for block-level elements, \cd{C} for table captions, \cd{D} for table cells, \cd{L} for lists, and \cd{T} for tables.  Codes that reveal properties of the precise tag that uses a class are \cd{b} for block-level elements, \cd{t} for tables, \cd{d} for table cells, \cd{-} for table rows, \cd{H} for the possibility to set a height, \cd{N} for non-replaced inline-level elements, \cd{R} for replaced inline elements, and \cd{W} for the possibility to set a width.
+
 Some other command-line parameters are accepted:
 \begin{itemize}
 \item \texttt{-db <DBSTRING>}: Set database connection information, using the format expected by Postgres's \texttt{PQconnectdb()}, which is \texttt{name1=value1 ... nameN=valueN}.  The same format is also parsed and used to discover connection parameters for MySQL and SQLite.  The only significant settings for MySQL are \texttt{host}, \texttt{hostaddr}, \texttt{port}, \texttt{dbname}, \texttt{user}, and \texttt{password}.  The only significant setting for SQLite is \texttt{dbname}, which is interpreted as the filesystem path to the database.  Additionally, when using SQLite, a database string may be just a file path.
--- a/src/compiler.sig	Thu Feb 25 15:08:52 2010 -0500
+++ b/src/compiler.sig	Sat Feb 27 14:57:57 2010 -0500
@@ -91,6 +91,7 @@
     val specialize : (Core.file, Core.file) phase
     val marshalcheck : (Core.file, Core.file) phase
     val effectize : (Core.file, Core.file) phase
+    val css : (Core.file, Css.report) phase
     val monoize : (Core.file, Mono.file) phase
     val mono_opt : (Mono.file, Mono.file) phase
     val untangle : (Mono.file, Mono.file) phase
@@ -131,6 +132,7 @@
     val toShake5 : (string, Core.file) transform
     val toMarshalcheck : (string, Core.file) transform
     val toEffectize : (string, Core.file) transform
+    val toCss : (string, Css.report) transform
     val toMonoize : (string, Mono.file) transform
     val toMono_opt1 : (string, Mono.file) transform
     val toUntangle : (string, Mono.file) transform
--- a/src/compiler.sml	Thu Feb 25 15:08:52 2010 -0500
+++ b/src/compiler.sml	Sat Feb 27 14:57:57 2010 -0500
@@ -1001,6 +1001,13 @@
 
 val toEffectize = transform effectize "effectize" o toMarshalcheck
 
+val css = {
+    func = Css.summarize,
+    print = fn _ => Print.box []
+}
+
+val toCss = transform css "css" o toShake5
+
 val monoize = {
     func = Monoize.monoize CoreEnv.empty,
     print = MonoPrint.p_file MonoEnv.empty
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/css.sig	Sat Feb 27 14:57:57 2010 -0500
@@ -0,0 +1,43 @@
+(* Copyright (c) 2010, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature CSS = sig
+
+    datatype inheritable = Block | List | Table | Caption | Td
+    datatype others = OBlock | OTable | OTd | Tr | NonReplacedInline | ReplacedInline | Width | Height
+
+    val inheritableToString : inheritable -> string
+    val othersToString : others -> string
+
+    type summary = inheritable list * others list
+
+    type report = {Overall : inheritable list,
+                   Classes : (string * summary) list}
+
+    val summarize : Core.file -> report
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/css.sml	Sat Feb 27 14:57:57 2010 -0500
@@ -0,0 +1,305 @@
+(* Copyright (c) 2010, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure Css :> CSS = struct
+
+structure IM = IntBinaryMap
+
+structure SM = BinaryMapFn(struct
+                           type ord_key = string
+                           val compare = String.compare
+                           end)
+
+datatype inheritable = Block | List | Table | Caption | Td
+datatype others = OBlock | OTable | OTd | Tr | NonReplacedInline | ReplacedInline | Width | Height
+
+fun inheritableToString x =
+    case x of
+        Block => "B"
+      | List => "L"
+      | Table => "T"
+      | Caption => "C"
+      | Td => "D"
+
+fun othersToString x =
+    case x of
+        OBlock => "b"
+      | OTable => "t"
+      | OTd => "d"
+      | Tr => "-"
+      | NonReplacedInline => "N"
+      | ReplacedInline => "R"
+      | Width => "W"
+      | Height => "H"
+
+type summary = inheritable list * others list
+
+fun merge' (ls1, ls2) = foldl (fn (x, ls) => if List.exists (fn y => y = x) ls then ls else x :: ls) ls2 ls1
+fun merge ((in1, ot1), (in2, ot2)) = (merge' (in1, in2), merge' (ot1, ot2))
+fun mergePC {parent = (in1, ot1), child = in2} = (merge' (in1, in2), ot1)
+
+val nada = ([], [])
+val block = ([Block], [OBlock, Width, Height])
+val inline = ([], [NonReplacedInline])
+val list = ([Block, List], [OBlock, Width, Height])
+val replaced = ([], [ ReplacedInline, Width, Height])
+val table = ([Block, Table], [OBlock, OTable, Width, Height])
+val tr = ([Block], [OBlock, Tr, Width])
+val td = ([Block, Td], [OBlock, OTd, Height])
+
+val tags = [("span", inline),
+            ("div", block),
+            ("p", block),
+            ("b", inline),
+            ("i", inline),
+            ("tt", inline),
+            ("h1", block),
+            ("h2", block),
+            ("h3", block),
+            ("h4", block),
+            ("h5", block),
+            ("h6", block),
+            ("li", list),
+            ("ol", list),
+            ("ul", list),
+            ("hr", block),
+            ("a", inline),
+            ("img", replaced),
+            ("form", block),
+            ("hidden", replaced),
+            ("textbox", replaced),
+            ("password", replaced),
+            ("textarea", replaced),
+            ("checkbox", replaced),
+            ("upload", replaced),
+            ("radio", replaced),
+            ("select", replaced),
+            ("submit", replaced),
+            ("label", inline),
+            ("ctextbox", replaced),
+            ("button", replaced),
+            ("ccheckbox", replaced),
+            ("cselect", replaced),
+            ("ctextarea", replaced),
+            ("tabl", table),
+            ("tr", tr),
+            ("th", td),
+            ("td", td)]
+
+val tags = foldl (fn ((tag, css), tags) =>
+                     SM.insert (tags, tag, css)) SM.empty tags
+
+open Core
+
+fun summarize file =
+    let
+        fun decl ((d, _), st as (globals, classes)) =
+            let
+                fun getTag (e, _) =
+                    case e of
+                        EFfi ("Basis", tag) => SOME tag
+                      | ECApp (e, _) => getTag e
+                      | EApp (e, _) => getTag e
+                      | _ => NONE
+
+                fun exp ((e, _), classes) =
+                    case e of
+                        EPrim _ => ([], classes)
+                      | ERel _ => ([], classes)
+                      | ENamed n =>
+                        (case IM.find (globals, n) of
+                             NONE => []
+                           | SOME (_, sm) => sm,
+                         classes)
+                      | ECon (_, _, _, NONE) => ([], classes)
+                      | ECon (_, _, _, SOME e) => exp (e, classes)
+                      | EFfi _ => ([], classes)
+                      | EFfiApp (_, _, es) => expList (es, classes)
+
+                      | EApp (
+                        (EApp (
+                         (EApp (
+                          (EApp (
+                           (ECApp (
+                            (ECApp (
+                             (ECApp (
+                              (ECApp (
+                               (ECApp (
+                                (ECApp (
+                                 (ECApp (
+                                  (ECApp (
+                                   (EFfi ("Basis", "tag"),
+                                    _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
+                           (ECon (_, _, _, SOME (ENamed class, _)), _)), _),
+                          attrs), _),
+                         tag), _),
+                        xml) =>
+                        let
+                            val (sm, classes) = exp (xml, classes)
+                            val (sm', classes) = exp (attrs, classes)
+                            val sm = merge' (sm, sm')
+                        in
+                            case getTag tag of
+                                NONE => (sm, classes)
+                              | SOME tag =>
+                                case SM.find (tags, tag) of
+                                    NONE => (sm, classes)
+                                  | SOME sm' =>
+                                    let
+                                        val sm'' = mergePC {parent = sm', child = sm}
+                                        val old = Option.getOpt (IM.find (classes, class), nada)
+                                        val classes = IM.insert (classes, class, merge (old, sm''))
+                                    in
+                                        (merge' (#1 sm', sm), classes)
+                                    end
+                        end
+
+                      | EApp (
+                        (EApp (
+                         (EApp (
+                          (EApp (
+                           (ECApp (
+                            (ECApp (
+                             (ECApp (
+                              (ECApp (
+                               (ECApp (
+                                (ECApp (
+                                 (ECApp (
+                                  (ECApp (
+                                   (EFfi ("Basis", "tag"),
+                                    _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
+                           _), _),
+                          attrs), _),
+                         tag), _),
+                        xml) =>
+                        let
+                            val (sm, classes) = exp (xml, classes)
+                            val (sm', classes) = exp (attrs, classes)
+                            val sm = merge' (sm, sm')
+                        in
+                            case getTag tag of
+                                NONE => (sm, classes)
+                              | SOME tag =>
+                                case SM.find (tags, tag) of
+                                    NONE => (sm, classes)
+                                  | SOME sm' => (merge' (#1 sm', sm), classes)
+                        end
+
+                      | EApp (e1, e2) =>
+                        let
+                            val (sm1, classes) = exp (e1, classes)
+                            val (sm2, classes) = exp (e2, classes)
+                        in
+                            (merge' (sm1, sm2), classes)
+                        end
+                      | EAbs (_, _, _, e) => exp (e, classes)
+                      | ECApp (e, _) => exp (e, classes)
+                      | ECAbs (_, _, e) => exp (e, classes)
+                      | EKAbs (_, e) => exp (e, classes)
+                      | EKApp (e, _) => exp (e, classes)
+                      | ERecord xets => expList (map #2 xets, classes)
+                      | EField (e, _, _) => exp (e, classes)
+                      | EConcat (e1, _, e2, _) =>
+                        let
+                            val (sm1, classes) = exp (e1, classes)
+                            val (sm2, classes) = exp (e2, classes)
+                        in
+                            (merge' (sm1, sm2), classes)
+                        end
+                      | ECut (e, _, _) => exp (e, classes)
+                      | ECutMulti (e, _, _) => exp (e, classes)
+                      | ECase (e, pes, _) =>
+                        let
+                            val (sm, classes) = exp (e, classes)
+                            val (sms, classes) = expList (map #2 pes, classes)
+                        in
+                            (merge' (sm, sms), classes)
+                        end
+                      | EWrite e => exp (e, classes)
+                      | EClosure (_, es) => expList (es, classes)
+                      | ELet (_, _, e1, e2) =>
+                        let
+                            val (sm1, classes) = exp (e1, classes)
+                            val (sm2, classes) = exp (e2, classes)
+                        in
+                            (merge' (sm1, sm2), classes)
+                        end
+                      | EServerCall (_, es, _) => expList (es, classes)
+
+                and expList (es, classes) = foldl (fn (e, (sm, classes)) =>
+                                                      let
+                                                          val (sm', classes) = exp (e, classes)
+                                                      in
+                                                          (merge' (sm, sm'), classes)
+                                                      end) ([], classes) es
+            in
+                case d of
+                    DCon _ => st
+                  | DDatatype _ => st
+                  | DVal (_, n, _, e, _) =>
+                    let
+                        val (sm, classes) = exp (e, classes)
+                    in
+                        (IM.insert (globals, n, (NONE, sm)), classes)
+                    end
+                  | DValRec vis =>
+                    let
+                        val (sm, classes) = foldl (fn ((_, _, _, e, _),
+                                                       (sm, classes)) =>
+                                                      let
+                                                          val (sm', classes) = exp (e, classes)
+                                                      in
+                                                          (merge' (sm', sm), classes)
+                                                      end) ([], classes) vis
+                    in
+                        (foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, (NONE, sm))) globals vis,
+                         classes)
+                    end
+                  | DExport _ => st
+                  | DTable _ => st
+                  | DSequence _ => st
+                  | DView _ => st
+                  | DDatabase _ => st
+                  | DCookie _ => st
+                  | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes)
+                  | DTask _ => st
+            end
+
+        val (globals, classes) = foldl decl (IM.empty, IM.empty) file
+    in
+        {Overall = IM.foldl (fn ((_, sm), sm') => merge' (sm, sm')) [] globals,
+         Classes = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER)
+                                      (List.mapPartial (fn (i, sm) =>
+                                                           case IM.find (globals, i) of
+                                                               SOME (SOME s, _) => SOME (s, sm)
+                                                             | _ => NONE) (IM.listItemsi classes))}
+    end
+
+type report = {Overall : inheritable list,
+               Classes : (string * summary) list}
+
+end
--- a/src/main.mlton.sml	Thu Feb 25 15:08:52 2010 -0500
+++ b/src/main.mlton.sml	Sat Feb 27 14:57:57 2010 -0500
@@ -29,10 +29,14 @@
 val tc = ref false
 val sources = ref ([] : string list)
 val demo = ref (NONE : (string * bool) option)
+val css = ref false
 
 fun doArgs args =
     case args of
         [] => ()
+      | "-css" :: rest =>
+        (css := true;
+         doArgs rest)
       | "-demo" :: prefix :: rest =>
         (demo := SOME (prefix, false);
          doArgs rest)
@@ -90,10 +94,22 @@
       | _ => raise Fail "Zero or multiple job files specified"
 
 val () =
-    case !demo of
-        SOME (prefix, guided) =>
+    case (!css, !demo) of
+        (true, _) =>
+        (case Compiler.run Compiler.toCss job of
+             NONE => OS.Process.exit OS.Process.failure
+           | SOME {Overall = ov, Classes = cl} =>
+             (app (print o Css.inheritableToString) ov;
+              print "\n";
+              app (fn (x, (ins, ots)) =>
+                      (print x;
+                       print " ";
+                       app (print o Css.inheritableToString) ins;
+                       app (print o Css.othersToString) ots;
+                       print "\n")) cl))
+      | (_, SOME (prefix, guided)) =>
         Demo.make {prefix = prefix, dirname = job, guided = guided}
-      | NONE =>
+      | _ =>
         if !tc then
             (Compiler.check Compiler.toElaborate job;
              if ErrorMsg.anyErrors () then
--- a/src/sources	Thu Feb 25 15:08:52 2010 -0500
+++ b/src/sources	Sat Feb 27 14:57:57 2010 -0500
@@ -140,6 +140,9 @@
 marshalcheck.sig
 marshalcheck.sml
 
+css.sig
+css.sml
+
 mono.sml
 
 mono_util.sig