Initial experiments with nested <dyn>

6 files changed, 66 insertions, 15 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index c156b268..b126fb51 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -107,6 +107,7 @@ signature COMPILER = sig
     val toMono_opt3 : (string, Mono.file) transform
     val toFuse : (string, Mono.file) transform
     val toUntangle2 : (string, Mono.file) transform
+    val toMono_reduce2 : (string, Mono.file) transform
     val toMono_shake2 : (string, Mono.file) transform
     val toPathcheck : (string, Mono.file) transform
     val toCjrize : (string, Cjr.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index 6d499283..52181401 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -531,7 +531,8 @@ val toFuse = transform fuse "fuse" o toMono_opt3
 
 val toUntangle2 = transform untangle "untangle2" o toFuse
 
-val toMono_shake2 = transform mono_shake "mono_shake2" o toUntangle2
+val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
+val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2
 
 val pathcheck = {
     func = (fn file => (PathCheck.check file; file)),
diff --git a/src/elaborate.sml b/src/elaborate.sml
index c18cfb49..39cb85b2 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -3003,10 +3003,10 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
                     val env = E.pushDatatype env n xs xcs
                     val d' = (L'.DDatatype (x, n, xs, xcs), loc)
                 in
-                    if positive then
+                    (*if positive then
                         ()
                     else
-                        declError env (Nonpositive d');
+                        declError env (Nonpositive d');*)
 
                     ([d'], (env, denv, gs' @ gs))
                 end
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 64cb1771..1b675abd 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -37,6 +37,7 @@ structure IS = IntBinarySet
 structure IM = IntBinaryMap
 
 val funcs = [(("Basis", "alert"), "alert"),
+             (("Basis", "get_client_source"), "sg"),
              (("Basis", "htmlifyBool"), "bs"),
              (("Basis", "htmlifyFloat"), "ts"),
              (("Basis", "htmlifyInt"), "ts"),
@@ -435,11 +436,22 @@ fun process file =
                                                            fail,
                                                            str ")"])
 
-                        fun deStrcat (e, _) =
+                        val jsifyString = String.translate (fn #"\"" => "\\\""
+                                                             | #"\\" => "\\\\"
+                                                             | ch => String.str ch)
+
+                        fun jsifyStringMulti (n, s) =
+                            case n of
+                                0 => s
+                              | _ => jsifyStringMulti (n - 1, jsifyString s)
+
+                        fun deStrcat level (all as (e, _)) =
                             case e of
-                                EPrim (Prim.String s) => s
-                              | EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2
-                              | _ => raise Fail "Jscomp: deStrcat"
+                                EPrim (Prim.String s) => jsifyStringMulti (level, s)
+                              | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2
+                              | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\""
+                              | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)];
+                                      raise Fail "Jscomp: deStrcat")
 
                         val quoteExp = quoteExp loc
                     in
@@ -474,7 +486,8 @@ fun process file =
                                                           maxName = #maxName st}
 
                                                 val (e, st) = jsExp mode skip [] 0 (e, st)
-                                                val e = deStrcat e
+                                                val () = Print.prefaces "Pre-e" [("e", MonoPrint.p_exp MonoEnv.empty e)]
+                                                val e = deStrcat 0 e
                                                 
                                                 val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n"
                                             in
@@ -745,14 +758,20 @@ fun process file =
                                          str ")"], st)
                             end
 
-                          | EJavaScript (_, _, SOME _) => (e, st)
+                          | EJavaScript (Source _, _, SOME _) => (e, st)
+                          | EJavaScript (_, _, SOME e) => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st)
 
                           | EClosure _ => unsupported "EClosure"
                           | EQuery _ => unsupported "Query"
                           | EDml _ => unsupported "DML"
                           | ENextval _ => unsupported "Nextval"
                           | EUnurlify _ => unsupported "EUnurlify"
-                          | EJavaScript (_, e, _) => unsupported "Nested JavaScript"
+                          | EJavaScript (_, e, _) =>
+                            let
+                                val (e, st) = jsE inner (e, st)
+                            in
+                                ((EFfiApp ("Basis", "jsifyString", [e]), loc), st)
+                            end
 
                           | ESignalReturn e =>
                             let
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 0117623f..878fec92 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -479,11 +479,12 @@ fun reduce file =
                                               | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
                                 in
                                     (*Print.prefaces "verifyCompatible"
-                                                     [("e'", MonoPrint.p_exp env e'),
-                                                      ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
-                                                      ("effs_e'", Print.p_list p_event effs_e'),
-                                                      ("effs_b", Print.p_list p_event effs_b)];*)
-                                    if List.null effs_e' orelse verifyCompatible effs_b then
+                                                   [("e'", MonoPrint.p_exp env e'),
+                                                    ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
+                                                    ("effs_e'", Print.p_list p_event effs_e'),
+                                                    ("effs_b", Print.p_list p_event effs_b)];*)
+                                    if List.null effs_e' orelse (List.all (fn eff => eff <> Unsure) effs_e'
+                                                                 andalso verifyCompatible effs_b) then
                                         trySub ()
                                     else
                                         e
diff --git a/src/monoize.sml b/src/monoize.sml
index 56310c1b..993034e4 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1000,6 +1000,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                 loc)), loc)), loc)), loc),
                  fm)
             end
+          | L.ECApp ((L.EFfi ("Basis", "get"), _), t) =>
+            let
+                val t = monoType env t
+            in
+                ((L'.EAbs ("src", (L'.TSource, loc),
+                           (L'.TFun ((L'.TRecord [], loc), t), loc),
+                           (L'.EAbs ("_", (L'.TRecord [], loc), t,
+                                     (L'.EFfiApp ("Basis", "get_client_source",
+                                                  [(L'.ERel 1, loc)]),
+                                      loc)), loc)), loc),
+                 fm)
+            end
 
           | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _),
                     (L.EFfi ("Basis", "signal_monad"), _)) =>
@@ -1905,6 +1917,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                        | _ => raise Fail "Monoize: Bad dyn attributes")
                     
                   | "submit" => normal ("input type=\"submit\"", NONE, NONE)
+                  | "button" => normal ("input type=\"submit\"", NONE, NONE)
 
                   | "textbox" =>
                     (case targs of
@@ -1978,6 +1991,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                        | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
                                raise Fail "No name passed to lselect tag"))
 
+                  | "ctextbox" =>
+                    (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
+                         NONE =>
+                         let
+                             val (ts, fm) = tagStart "input"
+                         in
+                             ((L'.EStrcat (ts,
+                                           (L'.EPrim (Prim.String "/>"), loc)),
+                               loc), fm)
+                         end
+                       | SOME (_, src, _) =>
+                         (strcat [str "<script>inp(\"input\",",
+                                  (L'.EJavaScript (L'.Script, src, NONE), loc),
+                                  str ")</script>"],
+                          fm))
+
                   | "option" => normal ("option", NONE, NONE)
 
                   | "tabl" => normal ("table", NONE, NONE)