<dyn> inside <table>; fix Specialize bug with datatype decls generating other mutually-recursive datatype decls

5 files changed, 54 insertions, 14 deletions

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