summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml7
-rw-r--r--src/css.sig43
-rw-r--r--src/css.sml305
-rw-r--r--src/main.mlton.sml22
-rw-r--r--src/sources3
6 files changed, 379 insertions, 3 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-25 17:49:53 +0000