'style' attributes

7 files changed, 182 insertions, 15 deletions

diff --git a/doc/manual.tex b/doc/manual.tex
index 532e0ea9..0fdf9d2e 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -1956,14 +1956,17 @@ $$\begin{array}{l}
   \hspace{.1in} \to [\mt{attrsGiven} \sim \mt{attrsAbsent}] \Rightarrow [\mt{useOuter} \sim \mt{useInner}] \Rightarrow [\mt{bindOuter} \sim \mt{bindInner}] \\
   \hspace{.1in} \Rightarrow \mt{css\_class} \\
   \hspace{.1in} \to \mt{option} \; (\mt{signal} \; \mt{css\_class}) \\
+  \hspace{.1in} \to \mt{css\_style} \\
   \hspace{.1in} \to \$\mt{attrsGiven} \\
   \hspace{.1in} \to \mt{tag} \; (\mt{attrsGiven} \rc \mt{attrsAbsent}) \; \mt{ctxOuter} \; \mt{ctxInner} \; \mt{useOuter} \; \mt{bindOuter} \\
   \hspace{.1in} \to \mt{xml} \; \mt{ctxInner} \; \mt{useInner} \; \mt{bindInner} \to \mt{xml} \; \mt{ctxOuter} \; (\mt{useOuter} \rc \mt{useInner}) \; (\mt{bindOuter} \rc \mt{bindInner})
 \end{array}$$
-Note that any tag may be assigned a CSS class, or left without a class by passing $\mt{Basis.null}$ as the first value-level argument.  This is the sole way of making use of the values produced by $\mt{style}$ declarations.  Ur/Web itself doesn't deal with the syntax or semantics of style sheets; they can be linked via URLs with \texttt{link} tags.  However, Ur/Web does make it easy to calculate upper bounds on usage of CSS classes through program analysis.  The function $\mt{Basis.classes}$ can be used to specify a list of CSS classes for a single tag.
+Note that any tag may be assigned a CSS class, or left without a class by passing $\mt{Basis.null}$ as the first value-level argument.  This is the sole way of making use of the values produced by $\mt{style}$ declarations.  The function $\mt{Basis.classes}$ can be used to specify a list of CSS classes for a single tag.  Stylesheets to assign properties to the classes can be linked via URL's with \texttt{link} tags.  Ur/Web makes it easy to calculate upper bounds on usage of CSS classes through program analysis, with the \cd{-css} command-line flag.
 
 Also note that two different arguments are available for setting CSS classes: the first, associated with the \texttt{class} pseudo-attribute syntactic sugar, fixes the class of a tag for the duration of the tag's life; while the second, associated with the \texttt{dynClass} pseudo-attribute, allows the class to vary over the tag's life.  See Section \ref{signals} for an introduction to the $\mt{signal}$ type family.
 
+The third value-level argument makes it possible to generate an HTML \cd{style} attribute.
+
 Two XML fragments may be concatenated.
 $$\begin{array}{l}
   \mt{val} \; \mt{join} : \mt{ctx} ::: \{\mt{Unit}\} \to \mt{use_1} ::: \{\mt{Type}\} \to \mt{bind_1} ::: \{\mt{Type}\} \to \mt{bind_2} ::: \{\mt{Type}\} \\
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index ef2b9156..1c9de4b9 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -636,6 +636,17 @@ val classes : css_class -> css_class -> css_class
 (* The equivalent of writing one class after the other, separated by a space, in
  * an HTML 'class' attribute *)
 
+type css_value
+val atom : string -> css_value
+type url
+val css_url : url -> css_value
+type css_property
+val property : string -> css_property
+val value : css_property -> css_value -> css_property
+type css_style
+val noStyle : css_style
+val oneProperty : css_style -> css_property -> css_style
+
 con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type
 
 con xml :: {Unit} -> {Type} -> {Type} -> Type
@@ -650,6 +661,7 @@ val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type}
              [bindOuter ~ bindInner] =>
            css_class
 	   -> option (signal css_class)
+           -> css_style
            -> $attrsGiven
            -> tag (attrsGiven ++ attrsAbsent)
                   ctxOuter ctxInner useOuter bindOuter
@@ -695,7 +707,6 @@ con xform = xml form [] []
 type queryString
 val show_queryString : show queryString
 
-type url
 val show_url : show url
 val bless : string -> url
 val checkUrl : string -> option url
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 =
diff --git a/tests/css.ur b/tests/css.ur
index 04d3a701..6806c84d 100644
--- a/tests/css.ur
+++ b/tests/css.ur
@@ -7,4 +7,10 @@ fun main () = return <xml><body>
   <span class="st-3 st2">Bye!</span>
   <span class="st1">Appendix!</span>
   <span class="">Sequel!</span>
+
+  <span style="width: 30%">A</span>
+  <span class="st-3" style="color: blue red">B</span>
+  <span style="background: url(http://www.google.com/image.png)">C</span>
+  <span style="background: url('http://www.google.com/image.png') red 10% 66px">D</span>
+  <span style="color: red; width: 90 green; background: url(http://www.google.com/foo.jpg);">C</span>
 </body></xml>
diff --git a/tests/css.urp b/tests/css.urp
index 08a48817..38d47f29 100644
--- a/tests/css.urp
+++ b/tests/css.urp
@@ -1,3 +1,5 @@
+allow url http://www.google.com/*
+
 # Comment here
 css # Comment at end of line!
 # Comments everywhere!