Basic analysis of tag and CSS class usage

7 files changed, 385 insertions, 3 deletions

diff --git a/doc/manual.tex b/doc/manual.tex
index b6dddad6..6ac5a8d5 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -176,6 +176,12 @@ To stop the compilation process after type-checking, run
 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.
diff --git a/src/compiler.sig b/src/compiler.sig
index 78e82ba8..3d77a4cd 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -91,6 +91,7 @@ signature COMPILER = sig
     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 @@ signature COMPILER = sig
     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
diff --git a/src/compiler.sml b/src/compiler.sml
index 99c730f1..c74a0915 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1001,6 +1001,13 @@ val effectize = {
 
 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
diff --git a/src/css.sig b/src/css.sig
new file mode 100644
index 00000000..c7243cf7
--- /dev/null
+++ b/src/css.sig
@@ -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
diff --git a/src/css.sml b/src/css.sml
new file mode 100644
index 00000000..7189904f
--- /dev/null
+++ b/src/css.sml
@@ -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
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index fc1ba7e5..5676cd9c 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -29,10 +29,14 @@ val timing = ref false
 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 @@ val job =
       | _ => 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
diff --git a/src/sources b/src/sources
index ddc7deff..67c2e45a 100644
--- a/src/sources
+++ b/src/sources
@@ -140,6 +140,9 @@ effectize.sml
 marshalcheck.sig
 marshalcheck.sml
 
+css.sig
+css.sml
+
 mono.sml
 
 mono_util.sig