Initial experiments with nested <dyn>

10 files changed, 105 insertions, 15 deletions

diff --git a/jslib/urweb.js b/jslib/urweb.js
index 8e39f9f3..0ee19992 100644
--- a/jslib/urweb.js
+++ b/jslib/urweb.js
@@ -13,6 +13,9 @@ function sv(s, v) {
   s.v = v;
   callAll(s.h);
 }
+function sg(s) {
+  return s.v;
+}
 
 function ss(s) {
   return s;
diff --git a/lib/basis.urs b/lib/basis.urs
index 9b09e8d2..b4a40fde 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -86,6 +86,7 @@ val transaction_monad : monad transaction
 con source :: Type -> Type
 val source : t ::: Type -> t -> transaction (source t)
 val set : t ::: Type -> source t -> t -> transaction unit
+val get : t ::: Type -> source t -> transaction t
 
 con signal :: Type -> Type
 val signal_monad : monad signal
@@ -443,6 +444,16 @@ val submit : ctx ::: {Unit} -> use ::: {Type}
                    -> tag [Value = string, Action = $use -> transaction page]
                           ([Form] ++ ctx) ([Form] ++ ctx) use []
 
+(*** AJAX-oriented widgets *)
+
+con cformTag = fn (attrs :: {Type}) =>
+                  ctx ::: {Unit}
+                  -> fn [[Body] ~ ctx] =>
+                        unit -> tag attrs ([Body] ++ ctx) [] [] []
+
+val ctextbox : cformTag [Value = string, Size = int, Source = source string]
+val button : cformTag [Value = string, Onclick = transaction unit]
+
 (*** Tables *)
 
 val tabl : other ::: {Unit} -> fn [other ~ [Body, Table]] =>
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)
diff --git a/tests/dlist.ur b/tests/dlist.ur
new file mode 100644
index 00000000..211291bc
--- /dev/null
+++ b/tests/dlist.ur
@@ -0,0 +1,22 @@
+datatype dlist = Nil | Cons of string * source dlist
+
+fun delist dl =
+    case dl of
+        Nil => <xml>[]</xml>
+      | Cons (x, s) => <xml>{[x]} :: {delistSource s}</xml>
+
+and delistSource s = <xml><dyn signal={dl <- signal s; return (delist dl)}/></xml>
+
+fun main () : transaction page =
+    ns <- source Nil;
+    s <- source ns;
+    tb <- source "";
+    return <xml><body>
+      <dyn signal={s <- signal s; return (delistSource s)}/><br/>
+      <br/>
+      <ctextbox source={tb}/>
+      <button value="Add" onclick={hd <- get tb;
+                                   tl <- get s;
+                                   s' <- source (Cons (hd, tl));
+                                   set s s'}/>
+    </body></xml>
diff --git a/tests/dlist.urp b/tests/dlist.urp
new file mode 100644
index 00000000..16037274
--- /dev/null
+++ b/tests/dlist.urp
@@ -0,0 +1,3 @@
+debug
+
+dlist