'dynStyle' pseudo-attribute

7 files changed, 142 insertions, 60 deletions

diff --git a/doc/manual.tex b/doc/manual.tex
index 0fdf9d2e..fa321c69 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -1957,6 +1957,7 @@ $$\begin{array}{l}
   \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{option} \; (\mt{signal} \; \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})
@@ -1965,7 +1966,7 @@ Note that any tag may be assigned a CSS class, or left without a class by passin
 
 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.
+The third and fourth value-level arguments makes it possible to generate HTML \cd{style} attributes, either with fixed content (\cd{style} attribute) or dynamic content (\cd{dynStyle} pseudo-attribute).
 
 Two XML fragments may be concatenated.
 $$\begin{array}{l}
@@ -2237,7 +2238,9 @@ $$\begin{array}{rrcll}
   &&& \{e\} & \textrm{computed value} \\
 \end{array}$$
 
-Further, there is a special convenience and compatibility form for setting CSS classes of tags.  If a \cd{class} attribute has a value that is a string literal, the literal is parsed in the usual HTML way and replaced with calls to appropriate Ur/Web combinators.  Any dashes in the text are replaced with underscores to determine Ur identifiers.
+Further, there is a special convenience and compatibility form for setting CSS classes of tags.  If a \cd{class} attribute has a value that is a string literal, the literal is parsed in the usual HTML way and replaced with calls to appropriate Ur/Web combinators.  Any dashes in the text are replaced with underscores to determine Ur identifiers.  The same desugaring can be accessed in a normal expression context by calling the pseudo-function \cd{CLASS} on a string literal.
+
+Similar support is provided for \cd{style} attributes.  Normal CSS syntax may be used in string literals that are \cd{style} attribute values, and the desugaring may be accessed elsewhere with the pseudo-function \cd{STYLE}.
 
 \section{\label{structure}The Structure of Web Applications}
 
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 74badd36..4f6a5f22 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -944,7 +944,7 @@ function tbx(s) {
     return x;
 }
 
-function dynClass(html, s) {
+function dynClass(html, s_class, s_style) {
     var htmlCls = {v : null};
     html = flatten(htmlCls, html);
     htmlCls = htmlCls.v;
@@ -956,23 +956,45 @@ function dynClass(html, s) {
     dummy.removeChild(html);
     addNode(html);
 
-    var x = document.createElement("script");
-    x.dead = false;
-    x.signal = s;
-    x.sources = null;
-    x.closures = htmlCls;
-    
-    x.recreate = function(v) {
-        for (var ls = x.closures; ls != htmlCls; ls = ls.next)
-            freeClosure(ls.data);
+    if (s_class) {
+        var x = document.createElement("script");
+        x.dead = false;
+        x.signal = s_class;
+        x.sources = null;
+        x.closures = htmlCls;
+        
+        x.recreate = function(v) {
+            for (var ls = x.closures; ls != htmlCls; ls = ls.next)
+                freeClosure(ls.data);
+
+            var cls = {v : null};
+            html.className = flatten(cls, v);
+	    x.closures = concat(cls.v, htmlCls);
+        }
 
-        var cls = {v : null};
-        html.className = flatten(cls, v);
-	x.closures = concat(cls.v, htmlCls);
-    };
+        addNode(x);
+        populate(x);
+    }
 
-    addNode(x);
-    populate(x);
+    if (s_style) {
+        var x = document.createElement("script");
+        x.dead = false;
+        x.signal = s_style;
+        x.sources = null;
+        x.closures = htmlCls;
+        
+        x.recreate = function(v) {
+            for (var ls = x.closures; ls != htmlCls; ls = ls.next)
+                freeClosure(ls.data);
+
+            var cls = {v : null};
+            html.style.cssText = flatten(cls, v);
+	    x.closures = concat(cls.v, htmlCls);
+        }
+
+        addNode(x);
+        populate(x);
+    }
 }
 
 function addOnChange(x, f) {
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 1c9de4b9..760cc4d2 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -662,6 +662,7 @@ val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type}
            css_class
 	   -> option (signal css_class)
            -> css_style
+	   -> option (signal css_style)
            -> $attrsGiven
            -> tag (attrsGiven ++ attrsAbsent)
                   ctxOuter ctxInner useOuter bindOuter
diff --git a/src/monoize.sml b/src/monoize.sml
index fe2d67bd..564be889 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3033,19 +3033,21 @@ 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), _),
-               style), _),
+                         (L.ECApp (
+			  (L.EFfi ("Basis", "tag"),
+                           _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
+		  class), _),
+	         dynClass), _),
+                style), _),
+               dynStyle), _),
               attrs), _),
              tag), _),
             xml) =>
@@ -3104,15 +3106,22 @@ 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 (dynStyle, fm) = monoExp (env, st, fm) dynStyle
 
                 val dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea"]
 
-                val () = case #1 dynClass of
-                             L'.ENone _ => ()
-                           | _ => if List.exists (fn x => x = tag) dynamics then
-                                      E.errorAt loc ("Dynamic tag <" ^ tag ^ "> cannot be combined with 'dynClass' attribute; an additional <span> may be useful")
-                                  else
-                                      ()
+                fun isSome (e, _) =
+                    case e of
+                        L'.ESome _ => true
+                      | _ => false
+
+                val () = if isSome dynClass orelse isSome dynStyle then
+                             if List.exists (fn x => x = tag) dynamics then
+                                 E.errorAt loc ("Dynamic tag <" ^ tag ^ "> cannot be combined with 'dynClass' or 'dynStyle' attribute; an additional <span> may be useful")
+                             else
+                                 ()
+                         else
+                             ()
 
                 fun tagStart tag' =
                     let
@@ -3587,13 +3596,36 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                       | _ => normal (tag, NONE)
 	    in
 		case #1 dynClass of
-		    L'.ENone _ => baseAll
-		  | L'.ESome (_, dc) => (strcat [str "<script type=\"text/javascript\">dynClass(execD(",
-				                 (L'.EJavaScript (L'.Script, base), loc),
-				                 str "),execD(",
-				                 (L'.EJavaScript (L'.Script, dc), loc),
-				                 str "))</script>"],
-			                 fm)
+		    L'.ENone _ =>
+		    (case #1 dynStyle of
+		         L'.ENone _ => baseAll
+		       | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(execD(",
+				                      (L'.EJavaScript (L'.Script, base), loc),
+				                      str "),null,execD(",
+				                      (L'.EJavaScript (L'.Script, ds), loc),
+				                      str "))</script>"],
+			                      fm)
+                       | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
+                               baseAll))
+		  | L'.ESome (_, dc) =>
+                    let
+                        val e = case #1 dynStyle of
+                                    L'.ENone _ => str "null"
+                                  | L'.ESome (_, ds) => strcat [str "execD(",
+                                                                (L'.EJavaScript (L'.Script, ds), loc),
+                                                                str ")"]
+                                  | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
+                                          str "null")
+                    in
+                        (strcat [str "<script type=\"text/javascript\">dynClass(execD(",
+				 (L'.EJavaScript (L'.Script, base), loc),
+				 str "),execD(",
+				 (L'.EJavaScript (L'.Script, dc), loc),
+				 str "),",
+                                 e,
+                                 str ")</script>"],
+			 fm)
+                    end
                   | _ => (E.errorAt loc "Absence/presence of 'dynClass' unknown";
                           baseAll)
             end
diff --git a/src/urweb.grm b/src/urweb.grm
index 4605becf..c6545f47 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2011, Adam Chlipala
+(* Copyright (c) 2008-2012, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -219,7 +219,7 @@ fun tagIn bt =
 
 datatype prop_kind = Delete | Update
 
-datatype attr = Class of exp | DynClass of exp | Style of exp | Normal of con * exp
+datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp
 
 fun patType loc (p : pat) =
     case #1 p of
@@ -427,7 +427,7 @@ fun parseStyle s pos =
  | rpat of (string * pat) list * bool
  | ptuple of pat list
 
- | attrs of exp option * exp option * exp option * (con * exp) list
+ | attrs of exp option * exp option * exp option * exp option * (con * exp) list
  | attr of attr
  | attrv of exp
 
@@ -1105,7 +1105,10 @@ eapps  : eterm                          (eterm)
        | eapps LBRACK cexp RBRACK       (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
        | eapps BANG                     (EDisjointApp eapps, s (eappsleft, BANGright))
 
-eexp   : eapps                          (eapps)
+eexp   : eapps                          (case #1 eapps of
+                                             EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String s), loc)) => parseClass s loc
+                                           | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String s), loc)) => parseStyle s loc
+                                           | _ => eapps)
        | FN eargs DARROW eexp           (let
                                              val loc = s (FNleft, eexpright)
                                          in
@@ -1585,7 +1588,12 @@ tag    : tagHead attrs                  (let
                                                         | 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 eo = case #4 attrs of
+                                                          NONE => (EVar (["Basis"], "None", Infer), pos)
+                                                        | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
+                                                                           e), pos)
+                                             val e = (EApp (e, eo), pos)
+                                             val e = (EApp (e, (ERecord (#5 attrs), pos)), pos)
                                              val e = (EApp (e, (EApp (#2 tagHead,
                                                                       (ERecord [], pos)), pos)), pos)
                                          in
@@ -1601,7 +1609,7 @@ tagHead: BEGIN_TAG                      (let
                                          end)
        | tagHead LBRACE cexp RBRACE     (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
                                           
-attrs  :                                (NONE, NONE, NONE, [])
+attrs  :                                (NONE, NONE, NONE, NONE, [])
        | attr attrs                     (let
                                              val loc = s (attrleft, attrsright)
                                          in
@@ -1610,25 +1618,31 @@ attrs  :                                (NONE, NONE, NONE, [])
                                                  (case #1 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
-                                                  (SOME e, #2 attrs, #3 attrs, #4 attrs))
+                                                  (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs))
                                                | DynClass e =>
                                                  (case #2 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
-                                                  (#1 attrs, SOME e, #3 attrs, #4 attrs))
+                                                  (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 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))
+                                                  (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs))
+                                               | DynStyle e =>
+                                                 (case #4 attrs of
+                                                      NONE => ()
+                                                    | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
+                                                  (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs))
                                                | Normal xe =>
-                                                 (#1 attrs, #2 attrs, #3 attrs, xe :: #4 attrs)
+                                                 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs)
                                          end)
 
 attr   : SYMBOL EQ attrv                (case SYMBOL of
 					     "class" => Class attrv
 					   | "dynClass" => DynClass attrv
                                            | "style" => Style attrv
+					   | "dynStyle" => DynStyle attrv
 					   | _ =>
                                              let
                                                  val sym =
diff --git a/tests/dynClass.ur b/tests/dynClass.ur
index 2c7068c8..37f931a2 100644
--- a/tests/dynClass.ur
+++ b/tests/dynClass.ur
@@ -1,21 +1,31 @@
-style s1
-style s2
+style date
+style topic
 
 fun main () : transaction page =
-    src <- source s1;
-    s <- source "";
     toggle <- source False;
     return <xml>
       <head>
-	<link rel="stylesheet" type="text/css" href="http://localhost/test.css"/>
+	<link rel="stylesheet" type="text/css" href="http://adam.chlipala.net/style.css"/>
       </head>
       <body>
-	<button dynClass={signal src} onclick={set src s2}/>
+	<button dynClass={b <- signal toggle;
+                          return (if b then date else topic)}
+                dynStyle={b <- signal toggle;
+                          return (if b then
+                                      STYLE "width: 500px"
+                                  else
+                                      STYLE "width: 200px")}
+                onclick={b <- get toggle; set toggle (not b)}/>
 
-	<hr/>
-
-	<ctextbox source={s} dynClass={t <- signal toggle;
-				       return (if t then s1 else s2)}
-        	  onkeyup={fn _ => t <- get toggle; set toggle (not t)}/>
+        <button dynStyle={b <- signal toggle;
+                          return (if b then
+                                      STYLE "width: 200px"
+                                  else
+                                      STYLE "width: 100px")}/>
+        <button dynClass={b <- signal toggle;
+                          return (if b then
+                                      topic
+                                  else
+                                      date)}/>
       </body>
     </xml>
diff --git a/tests/dynClass.urp b/tests/dynClass.urp
index 4358782b..0818a3b2 100644
--- a/tests/dynClass.urp
+++ b/tests/dynClass.urp
@@ -1,4 +1,4 @@
 rewrite all DynClass/*
-allow url http://localhost/*
+allow url http://adam.chlipala.net/*
 
 dynClass