From ba3e01e524907d85f5cba6af62083fcdee606f33 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sat, 13 Jun 2009 14:29:36 -0400
Subject: <dyn> inside <table>; fix Specialize bug with datatype decls
 generating other mutually-recursive datatype decls

---
 lib/js/urweb.js    | 23 ++++++++++++++---------
 lib/ur/basis.urs   |  4 ++--
 src/jscomp.sml     | 16 +++++++++++++++-
 src/list_util.sig  |  2 ++
 src/list_util.sml  | 13 +++++++++++++
 src/monoize.sml    | 23 ++++++++++++++++++-----
 src/specialize.sml | 14 ++++++--------
 tests/tbody.ur     | 13 +++++++++++++
 tests/tbody.urp    |  4 ++++
 9 files changed, 87 insertions(+), 25 deletions(-)
 create mode 100644 tests/tbody.ur
 create mode 100644 tests/tbody.urp

diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index efd94bb9..60de8744 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -278,15 +278,20 @@ function dyn(s) {
     for (var ls = x.closures; ls; ls = ls.next)
       freeClosure(ls.data);
 
-    var spans = x.getElementsByTagName("span");
-    for (var i = 0; i < spans.length; ++i) {
-      var span = spans[i];
-      span.dead = true;
-      for (var ls = span.sources; ls; ls = ls.next)
-        ls.data.dyns = remove(span, ls.data.dyns);
-      for (var ls = span.closures; ls; ls = ls.next)
-        freeClosure(ls.data);
-    }
+    var doKind = function(kind) {
+      var arr = x.getElementsByTagName(kind);
+      for (var i = 0; i < arr.length; ++i) {
+        var span = arr[i];
+        span.dead = true;
+        for (var ls = span.sources; ls; ls = ls.next)
+          ls.data.dyns = remove(span, ls.data.dyns);
+        for (var ls = span.closures; ls; ls = ls.next)
+          freeClosure(ls.data);
+      }
+    };
+
+    doKind("span");
+    doKind("tbody");
 
     var cls = {v : null};
     x.innerHTML = flatten(cls, v);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 50909804..e4f4c28a 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -530,8 +530,8 @@ type url
 val bless : string -> url
 val checkUrl : string -> option url
 
-val dyn : use ::: {Type} -> bind ::: {Type} -> unit
-          -> tag [Signal = signal (xml body use bind)] body [] use bind
+val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [ctx ~ body] => unit
+          -> tag [Signal = signal (xml (body ++ ctx) use bind)] (body ++ ctx) [] use bind
 
 val head : unit -> tag [] html head [] []
 val title : unit -> tag [] head [] [] []
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 75cca425..9f0a7a1b 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -171,6 +171,13 @@ val compact =
 
 exception CantEmbed of typ
 
+fun inString {needle, haystack} =
+    let
+        val (_, suffix) = Substring.position needle (Substring.full haystack)
+    in
+        not (Substring.isEmpty suffix)
+    end
+
 fun process file =
     let
         val (someTs, nameds) =
@@ -1086,7 +1093,14 @@ fun process file =
         fun exp outer (e as (_, loc), st) =
             ((*Print.preface ("exp", MonoPrint.p_exp MonoEnv.empty e);*)
              case #1 e of
-                 EPrim _ => (e, st)
+                 EPrim p =>
+                 (case p of
+                      Prim.String s => if inString {needle = "<script", haystack = s} then
+                                           foundJavaScript := true
+                                       else
+                                           ()
+                    | _ => ();
+                  (e, st))
                | ERel _ => (e, st)
                | ENamed _ => (e, st)
                | ECon (_, _, NONE) => (e, st)
diff --git a/src/list_util.sig b/src/list_util.sig
index 8b6f49d8..a89998b2 100644
--- a/src/list_util.sig
+++ b/src/list_util.sig
@@ -37,6 +37,8 @@ signature LIST_UTIL = sig
     val foldlMap : ('data1 * 'state -> 'data2 * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state
     val foldlMapPartial : ('data1 * 'state -> 'data2 option * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state
     val foldlMapConcat : ('data1 * 'state -> 'data2 list * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state
+    val foldlMapAbort : ('data1 * 'state -> ('data2 * 'state) option)
+                        -> 'state -> 'data1 list -> ('data2 list * 'state) option
 
     val search : ('a -> 'b option) -> 'a list -> 'b option
     val searchi : (int * 'a -> 'b option) -> 'a list -> 'b option
diff --git a/src/list_util.sml b/src/list_util.sml
index bafac51b..1f6b24ee 100644
--- a/src/list_util.sml
+++ b/src/list_util.sml
@@ -123,6 +123,19 @@ fun foldlMapPartial f s =
         fm ([], s)
     end
 
+fun foldlMapAbort f s =
+    let
+        fun fm (ls', s) ls =
+            case ls of
+                nil => SOME (rev ls', s)
+              | h :: t =>
+                case f (h, s) of
+                    NONE => NONE
+                  | SOME (h', s') => fm (h' :: ls', s') t
+    in
+        fm ([], s)
+    end
+
 fun search f =
     let
         fun s ls =
diff --git a/src/monoize.sml b/src/monoize.sml
index d3eb4874..91160e02 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2595,11 +2595,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                   | "dyn" =>
                     (case attrs of
                          [("Signal", e, _)] =>
-                         ((L'.EStrcat
-                               ((L'.EPrim (Prim.String "<span><script type=\"text/javascript\">dyn("), loc),
-                                (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
-                                             (L'.EPrim (Prim.String ")</script></span>"), loc)), loc)), loc),
-                          fm)
+                         let
+                             val inTable = case targs of
+                                               (L.CRecord (_, ctx), _) :: _ =>
+                                               List.exists (fn ((L.CName "Table", _), _) => true
+                                                             | _ => false) ctx
+                                             | _ => false
+
+                             val tag = if inTable then
+                                           "tbody"
+                                       else
+                                           "span"
+                         in
+                             ((L'.EStrcat
+                                   ((L'.EPrim (Prim.String ("<" ^ tag ^ "><script type=\"text/javascript\">dyn(")), loc),
+                                    (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
+                                                 (L'.EPrim (Prim.String (")</script></" ^ tag ^ ">")), loc)), loc)), loc),
+                              fm)
+                         end
                        | _ => raise Fail "Monoize: Bad dyn attributes")
                     
                   | "submit" => normal ("input type=\"submit\"", NONE, NONE)
diff --git a/src/specialize.sml b/src/specialize.sml
index b740ec8c..43c634c7 100644
--- a/src/specialize.sml
+++ b/src/specialize.sml
@@ -246,15 +246,12 @@ fun specialize file =
             let
                 (*val () = Print.preface ("decl:", CorePrint.p_decl CoreEnv.empty all)*)
                 val (d, st) = specDecl st d
-
-                val ds =
-                    case #decls st of
-                        [] => []
-                      | dts => [(DDatatype dts, #2 d)]
             in
                 case #1 d of
                     DDatatype dts =>
-                    (rev (d :: ds),
+                    ((case #decls st of
+                          [] => [d]
+                        | dts' => [(DDatatype (dts' @ dts), #2 d)]),
                      {count = #count st,
                       datatypes = foldl (fn ((x, n, xs, xnts), dts) =>
                                             IM.insert (dts, n,
@@ -270,7 +267,9 @@ fun specialize file =
                                            (#constructors st) dts,
                       decls = []})
                   | _ =>
-                    (rev (d :: ds),
+                    (case #decls st of
+                          [] => [d]
+                        | dts => [(DDatatype dts, #2 d), d],
                      {count = #count st,
                       datatypes = #datatypes st,
                       constructors = #constructors st,
@@ -286,5 +285,4 @@ fun specialize file =
         ds
     end
 
-
 end
diff --git a/tests/tbody.ur b/tests/tbody.ur
new file mode 100644
index 00000000..53bc0296
--- /dev/null
+++ b/tests/tbody.ur
@@ -0,0 +1,13 @@
+fun main () : transaction page =
+    s <- source [];
+    entry <- source "";
+    return <xml><body>
+      <table>
+        <dyn signal={s <- signal s;
+                     return (List.mapX (fn s => <xml><tr><td>{[s]}</td></tr></xml>) s)}/>
+      </table>
+
+      Add one: <ctextbox source={entry}/> <button onclick={e <- get entry;
+                                                           v <- get s;
+                                                           set s (e :: v)}/>
+    </body></xml>
diff --git a/tests/tbody.urp b/tests/tbody.urp
new file mode 100644
index 00000000..4a264fbb
--- /dev/null
+++ b/tests/tbody.urp
@@ -0,0 +1,4 @@
+debug
+
+$/list
+tbody
-- 
cgit v1.2.3