changeset 2012:2b2d07946e65

Fix dynClass for non-<body> contexts
author Adam Chlipala <adam@chlipala.net>
date Sun, 04 May 2014 12:33:44 -0400
parents cfd604842006
children 77cc9169d6e0
files lib/js/urweb.js src/monoize.sml tests/dynClass.ur tests/dynList.ur tests/dynList.urp tests/dynList.urs
diffstat 6 files changed, 61 insertions(+), 29 deletions(-) [+]
line wrap: on
line diff
--- a/lib/js/urweb.js	Sat May 03 07:59:45 2014 -0400
+++ b/lib/js/urweb.js	Sun May 04 12:33:44 2014 -0400
@@ -1113,7 +1113,7 @@
     return x;
 }
 
-function dynClass(html, s_class, s_style) {
+function dynClass(pnode, html, s_class, s_style) {
     if (suspendScripts)
         return;
 
@@ -1121,7 +1121,7 @@
     html = flatten(htmlCls, html);
     htmlCls = htmlCls.v;
 
-    var dummy = document.createElement("body");
+    var dummy = document.createElement(pnode);
     suspendScripts = true;
     dummy.innerHTML = html;
     suspendScripts = false;
@@ -1152,23 +1152,23 @@
 
     if (s_style) {
         var htmlCls2 = s_class ? null : htmlCls;
-        var x = document.createElement("script");
-        x.dead = false;
-        x.signal = s_style;
-        x.sources = null;
-        x.closures = htmlCls2;
+        var y = document.createElement("script");
+        y.dead = false;
+        y.signal = s_style;
+        y.sources = null;
+        y.closures = htmlCls2;
 
-        x.recreate = function(v) {
-            for (var ls = x.closures; ls != htmlCls2; ls = ls.next)
+        y.recreate = function(v) {
+            for (var ls = y.closures; ls != htmlCls2; ls = ls.next)
                 freeClosure(ls.data);
 
             var cls = {v : null};
             html.style.cssText = flatten(cls, v);
-	    x.closures = concat(cls.v, htmlCls2);
+	    y.closures = concat(cls.v, htmlCls2);
         }
 
-        html.appendChild(x);
-        populate(x);
+        html.appendChild(y);
+        populate(y);
     }
 }
 
--- a/src/monoize.sml	Sat May 03 07:59:45 2014 -0400
+++ b/src/monoize.sml	Sun May 04 12:33:44 2014 -0400
@@ -3230,7 +3230,7 @@
                         (L.ECApp (
                          (L.ECApp (
 			  (L.EFfi ("Basis", "tag"),
-                           _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
+                           _), (L.CRecord (_, attrsGiven), _)), _), _), _), ctxOuter), _), _), _), _), _), _), _), _), _), _), _),
 		  class), _),
 	         dynClass), _),
                 style), _),
@@ -3581,6 +3581,19 @@
                                                       (L'.EPrim (Prim.String ")"), loc)), loc)), loc)
                         end
 
+                fun inTag tag' = case ctxOuter of
+				     (L.CRecord (_, ctx), _) =>
+				     List.exists (fn ((L.CName tag'', _), _) => tag'' = tag'
+                                                   | _ => false) ctx
+                                  | _ => false
+
+                fun pnode () = if inTag "Tr" then
+			           "tr"
+                               else if inTag "Table" then
+			           "table"
+                               else
+			           "span"
+
 		val baseAll as (base, fm) =
                     case tag of
 			"body" => let
@@ -3603,24 +3616,12 @@
 
                       | "dyn" =>
 			let
-                            fun inTag tag = case targs of
-						(L.CRecord (_, ctx), _) :: _ =>
-						List.exists (fn ((L.CName tag', _), _) => tag' = tag
-                                                              | _ => false) ctx
-                                              | _ => false
-
-                            val tag = if inTag "Tr" then
-					  "tr"
-                                      else if inTag "Table" then
-					  "table"
-                                      else
-					  "span"
 			in
                             case attrs of
 				[("Signal", e, _)] =>
 				((L'.EStrcat
                                       ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\""
-                                                               ^ tag ^ "\", execD(")), loc),
+                                                               ^ pnode () ^ "\", execD(")), loc),
                                        (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
                                                     (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
 				 fm)
@@ -3834,7 +3835,9 @@
 		    L'.ENone _ =>
 		    (case #1 dynStyle of
 		         L'.ENone _ => baseAll
-		       | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(execD(",
+		       | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(\"",
+                                                      str (pnode ()),
+                                                      str "\",execD(",
 				                      (L'.EJavaScript (L'.Script, base), loc),
 				                      str "),null,execD(",
 				                      (L'.EJavaScript (L'.Script, ds), loc),
@@ -3852,7 +3855,9 @@
                                   | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
                                           str "null")
                     in
-                        (strcat [str "<script type=\"text/javascript\">dynClass(execD(",
+                        (strcat [str "<script type=\"text/javascript\">dynClass(\"",
+                                 str (pnode ()),
+                                 str "\",execD(",
 				 (L'.EJavaScript (L'.Script, base), loc),
 				 str "),execD(",
 				 (L'.EJavaScript (L'.Script, dc), loc),
--- a/tests/dynClass.ur	Sat May 03 07:59:45 2014 -0400
+++ b/tests/dynClass.ur	Sun May 04 12:33:44 2014 -0400
@@ -15,7 +15,7 @@
                                       STYLE "width: 500px"
                                   else
                                       STYLE "width: 200px")}
-                onclick={b <- get toggle; set toggle (not b)}/>
+                onclick={fn _ => b <- get toggle; set toggle (not b)}/>
 
         <button dynStyle={b <- signal toggle;
                           return (if b then
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/dynList.ur	Sun May 04 12:33:44 2014 -0400
@@ -0,0 +1,22 @@
+fun main () =
+    b <- source True;
+    let
+        fun textboxList xs = <xml>
+          <table>
+            {List.mapX (fn src => <xml><tr>
+              <td dynClass={return null} dynStyle={b <- signal b;
+                                                   if b then
+                                                       return (STYLE "width: 500px")
+                                                   else
+                                                       return (STYLE "width: 100px")}>
+                <ctextbox source={src}/>
+            </td></tr></xml>) xs}
+          </table>
+        </xml>
+    in
+        s <- source "foo";
+        return <xml><body>
+          <ccheckbox source={b}/>
+          {textboxList (s :: s :: [])}
+        </body></xml>
+    end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/dynList.urp	Sun May 04 12:33:44 2014 -0400
@@ -0,0 +1,4 @@
+rewrite all DynList/*
+
+$/list
+dynList
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/dynList.urs	Sun May 04 12:33:44 2014 -0400
@@ -0,0 +1,1 @@
+val main : unit -> transaction page