'style' attributes

3 files changed, 158 insertions, 13 deletions

diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 199c807b..af9e9a9c 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -118,6 +118,26 @@ fun unAs s =
     end
 
 fun checkUrl s = CharVector.all Char.isGraph s andalso Settings.checkUrl s
+val checkAtom = CharVector.all (fn ch => Char.isAlphaNum ch
+                                         orelse ch = #"+"
+                                         orelse ch = #"-"
+                                         orelse ch = #"."
+                                         orelse ch = #"%"
+                                         orelse ch = #"#")
+val checkCssUrl = CharVector.all (fn ch => Char.isAlphaNum ch
+                                           orelse ch = #":"
+                                           orelse ch = #"/"
+                                           orelse ch = #"."
+                                           orelse ch = #"_"
+                                           orelse ch = #"-"
+                                           orelse ch = #"%"
+                                           orelse ch = #"?"
+                                           orelse ch = #"&"
+                                           orelse ch = #"="
+                                           orelse ch = #"#")
+fun checkProperty s = size s > 0
+                      andalso (Char.isLower (String.sub (s, 0)) orelse String.sub (s, 0) = #"_")
+                      andalso CharVector.all (fn ch => Char.isLower ch orelse Char.isDigit ch orelse ch = #"_" orelse ch = #"-") s
 
 fun exp e =
     case e of
@@ -440,6 +460,24 @@ fun exp e =
              ESome ((TFfi ("Basis", "string"), loc), (se, loc))
          else
              ENone (TFfi ("Basis", "string"), loc))
+      | EFfiApp ("Basis", "atom", [((se as EPrim (Prim.String s), loc), _)]) =>
+        (if checkAtom s then
+             ()
+         else
+             ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'atom'");
+         se)
+      | EFfiApp ("Basis", "css_url", [((se as EPrim (Prim.String s), loc), _)]) =>
+        (if checkCssUrl s then
+             ()
+         else
+             ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'css_url'");
+         se)
+      | EFfiApp ("Basis", "property", [((se as EPrim (Prim.String s), loc), _)]) =>
+        (if checkProperty s then
+             ()
+         else
+             ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'property'");
+         se)
       | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
         (if Settings.checkRequestHeader s then
              ()
diff --git a/src/monoize.sml b/src/monoize.sml
index 1b7018de..fe2d67bd 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -221,6 +221,9 @@ fun monoType env =
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CFfi ("Basis", "css_class") => (L'.TFfi ("Basis", "string"), loc)
+                  | L.CFfi ("Basis", "css_value") => (L'.TFfi ("Basis", "string"), loc)
+                  | L.CFfi ("Basis", "css_property") => (L'.TFfi ("Basis", "string"), loc)
+                  | L.CFfi ("Basis", "css_style") => (L'.TFfi ("Basis", "string"), loc)
                   | L.CFfi ("Basis", "id") => (L'.TFfi ("Basis", "string"), loc)
 
                   | L.CApp ((L.CFfi ("Basis", "serialized"), _), _) =>
@@ -2951,6 +2954,43 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | L.EFfiApp ("Basis", "css_url", [(s, _)]) =>
+            let
+                val (s, fm) = monoExp (env, st, fm) s
+            in
+                ((L'.EStrcat ((L'.EPrim (Prim.String "url("), loc),
+                              (L'.EStrcat ((L'.EFfiApp ("Basis", "css_url", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc),
+                                           (L'.EPrim (Prim.String ")"), loc)), loc)), loc),
+                 fm)
+            end
+
+          | L.EFfiApp ("Basis", "property", [(s, _)]) =>
+            let
+                val (s, fm) = monoExp (env, st, fm) s
+            in
+                ((L'.EStrcat ((L'.EFfiApp ("Basis", "property", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc),
+                              (L'.EPrim (Prim.String ":"), loc)), loc),
+                 fm)
+            end
+          | L.EFfiApp ("Basis", "value", [(s1, _), (s2, _)]) =>
+            let
+                val (s1, fm) = monoExp (env, st, fm) s1
+                val (s2, fm) = monoExp (env, st, fm) s2
+            in
+                ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
+                 fm)
+            end
+
+          | L.EFfi ("Basis", "noStyle") => ((L'.EPrim (Prim.String ""), loc), fm)
+          | L.EFfiApp ("Basis", "oneProperty", [(s1, _), (s2, _)]) =>
+            let
+                val (s1, fm) = monoExp (env, st, fm) s1
+                val (s2, fm) = monoExp (env, st, fm) s2
+            in
+                ((L'.EStrcat (s1, (L'.EStrcat (s2, (L'.EPrim (Prim.String ";"), loc)), loc)), loc),
+                 fm)
+            end
+
           | L.EApp (
             (L.ECApp (
              (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
@@ -2992,18 +3032,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
              (L.EApp (
               (L.EApp (
                (L.EApp (
-		(L.ECApp (
-                 (L.ECApp (
+                (L.EApp (
+		 (L.ECApp (
                   (L.ECApp (
                    (L.ECApp (
                     (L.ECApp (
                      (L.ECApp (
                       (L.ECApp (
                        (L.ECApp (
-			(L.EFfi ("Basis", "tag"),
-                         _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
-		class), _),
-	       dynClass), _),
+                        (L.ECApp (
+			 (L.EFfi ("Basis", "tag"),
+                          _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
+		 class), _),
+	        dynClass), _),
+               style), _),
               attrs), _),
              tag), _),
             xml) =>
@@ -3061,6 +3103,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 
                 val (class, fm) = monoExp (env, st, fm) class
                 val (dynClass, fm) = monoExp (env, st, fm) dynClass
+                val (style, fm) = monoExp (env, st, fm) style
 
                 val dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea"]
 
@@ -3088,6 +3131,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                            {disc = t,
                                             result = t}), loc)
 
+                        val s = (L'.ECase (style,
+                                           [((L'.PPrim (Prim.String ""), loc),
+                                             s),
+                                            ((L'.PVar ("x", t), loc),
+                                             (L'.EStrcat (s,
+                                                         (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc),
+                                                                      (L'.EStrcat ((L'.ERel 0, loc),
+                                                                                   (L'.EPrim (Prim.String "\""), loc)),
+                                                                       loc)), loc)), loc))],
+                                           {disc = t,
+                                            result = t}), loc)
+
                         val (s, fm) = foldl (fn (("Action", _, _), acc) => acc
                                               | (("Source", _, _), acc) => acc
                                               | ((x, e, t), (s, fm)) =>
diff --git a/src/urweb.grm b/src/urweb.grm
index 6d175c48..4605becf 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -219,7 +219,7 @@ fun tagIn bt =
 
 datatype prop_kind = Delete | Update
 
-datatype attr = Class of exp | DynClass of exp | Normal of con * exp
+datatype attr = Class of exp | DynClass of exp | Style of exp | Normal of con * exp
 
 fun patType loc (p : pat) =
     case #1 p of
@@ -255,6 +255,47 @@ fun parseClass s pos =
         foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "classes", Infer), pos), e), pos), classOut (s, pos)), pos))
                 (classOut (class, pos)) classes
 
+fun parseValue s pos =
+    if String.isPrefix "url(" s andalso String.isSuffix ")" s then
+        let
+            val s = String.substring (s, 4, size s - 5)
+
+            val s = if size s >= 2
+                       andalso ((String.isPrefix "\"" s andalso String.isSuffix "\"" s)
+                                orelse (String.isPrefix "'" s andalso String.isSuffix "'" s)) then
+                        String.substring (s, 1, size s - 2)
+                    else
+                        s
+        in
+            (EApp ((EVar (["Basis"], "css_url", Infer), pos),
+                   (EApp ((EVar (["Basis"], "bless", Infer), pos),
+                          (EPrim (Prim.String s), pos)), pos)), pos)
+        end
+    else
+        (EApp ((EVar (["Basis"], "atom", Infer), pos),
+               (EPrim (Prim.String s), pos)), pos)
+
+fun parseProperty s pos =
+    let
+        val (befor, after) = Substring.splitl (fn ch => ch <> #":") (Substring.full s)
+    in
+        if Substring.isEmpty after then
+            (ErrorMsg.errorAt pos ("Invalid CSS property syntax: " ^ s);
+             (EPrim (Prim.String ""), pos))
+        else
+            foldl (fn (value, e) => (EApp ((EApp ((EVar (["Basis"], "value", Infer), pos), e), pos), parseValue value pos), pos))
+                (EApp ((EVar (["Basis"], "property", Infer), pos),
+                       (EPrim (Prim.String (Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos)
+                (String.tokens Char.isSpace (Substring.string (Substring.slice (after, 1, NONE))))
+    end
+
+fun parseStyle s pos =
+    case String.tokens (fn ch => ch = #";") s of
+        [] => (EVar (["Basis"], "noStyle", Infer), pos)
+      | props =>
+        foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "oneProperty", Infer), pos), e), pos), parseProperty s pos), pos))
+                (EVar (["Basis"], "noStyle", Infer), pos) props
+
 %%
 %header (functor UrwebLrValsFn(structure Token : TOKEN))
 
@@ -386,7 +427,7 @@ fun parseClass s pos =
  | rpat of (string * pat) list * bool
  | ptuple of pat list
 
- | attrs of exp option * exp option * (con * exp) list
+ | attrs of exp option * exp option * exp option * (con * exp) list
  | attr of attr
  | attrv of exp
 
@@ -1539,7 +1580,12 @@ tag    : tagHead attrs                  (let
                                                         | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
                                                                            e), pos)
                                              val e = (EApp (e, eo), pos)
-                                             val e = (EApp (e, (ERecord (#3 attrs), pos)), pos)
+                                             val eo = case #3 attrs of
+                                                          NONE => (EVar (["Basis"], "noStyle", Infer), pos)
+                                                        | SOME (EPrim (Prim.String s), pos) => parseStyle s pos
+                                                        | SOME e => e
+                                             val e = (EApp (e, eo), pos)
+                                             val e = (EApp (e, (ERecord (#4 attrs), pos)), pos)
                                              val e = (EApp (e, (EApp (#2 tagHead,
                                                                       (ERecord [], pos)), pos)), pos)
                                          in
@@ -1555,7 +1601,7 @@ tagHead: BEGIN_TAG                      (let
                                          end)
        | tagHead LBRACE cexp RBRACE     (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
                                           
-attrs  :                                (NONE, NONE, [])
+attrs  :                                (NONE, NONE, NONE, [])
        | attr attrs                     (let
                                              val loc = s (attrleft, attrsright)
                                          in
@@ -1564,19 +1610,25 @@ attrs  :                                (NONE, NONE, [])
                                                  (case #1 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
-                                                  (SOME e, #2 attrs, #3 attrs))
+                                                  (SOME e, #2 attrs, #3 attrs, #4 attrs))
                                                | DynClass e =>
                                                  (case #2 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
-                                                  (#1 attrs, SOME e, #3 attrs))
+                                                  (#1 attrs, SOME e, #3 attrs, #4 attrs))
+                                               | Style e =>
+                                                 (case #3 attrs of
+                                                      NONE => ()
+                                                    | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag";
+                                                  (#1 attrs, #2 attrs, SOME e, #4 attrs))
                                                | Normal xe =>
-                                                 (#1 attrs, #2 attrs, xe :: #3 attrs)
+                                                 (#1 attrs, #2 attrs, #3 attrs, xe :: #4 attrs)
                                          end)
 
 attr   : SYMBOL EQ attrv                (case SYMBOL of
 					     "class" => Class attrv
 					   | "dynClass" => DynClass attrv
+                                           | "style" => Style attrv
 					   | _ =>
                                              let
                                                  val sym =