Propagated a source change into a dynamic document element

5 files changed, 130 insertions, 97 deletions

diff --git a/jslib/urweb.js b/jslib/urweb.js
index eab67626..86c3808c 100644
--- a/jslib/urweb.js
+++ b/jslib/urweb.js
@@ -1,11 +1,18 @@
-function sc(v) { return {v : v} }
+function callAll(ls) {
+  for (; ls; ls = ls.next)
+    ls.v();
+}
+
+function sc(v) { return {v : v, h : null} }
+function sv(s, v) { s.v = v; callAll(s.h); }
 
-function ss(s) { return {v : s.v} }
-function sr(v) { return {v : v} }
-function sb(x,y) { return {v : y(x.v).v} }
+function ss(s) { return s }
+function sr(v) { return {v : v, h : null} }
+function sb(x,y) { return {v : y(x.v).v, h : null} }
 
 function dyn(s) {
   var x = document.createElement("span");
   x.innerHTML = s.v;
   document.body.appendChild(x);
+  s.h = { n : s.h, v : function() { x.innerHTML = s.v } };
 }
diff --git a/src/jscomp.sml b/src/jscomp.sml
index a4e3dd35..bc407db8 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -35,7 +35,8 @@ structure U = MonoUtil
 
 val funcs = [(("Basis", "alert"), "alert"),
              (("Basis", "htmlifyString"), "escape"),
-             (("Basis", "new_client_source"), "sc")]
+             (("Basis", "new_client_source"), "sc"),
+             (("Basis", "set_client_source"), "sv")]
 
 structure FM = BinaryMapFn(struct
                            type ord_key = string * string
@@ -94,7 +95,7 @@ fun strcat loc es =
       | [x] => x
       | x :: es' => (EStrcat (x, strcat loc es'), loc)
 
-fun jsExp mode outer =
+fun jsExp mode skip outer =
     let
         val len = length outer
 
@@ -126,7 +127,10 @@ fun jsExp mode outer =
                     case #1 t of
                         TSource => strcat [str "s",
                                            (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
+                      | TRecord [] => str "null"
+                      | TFfi ("Basis", "string") => e
                       | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
+                              Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
                               str "ERROR")
             in
                 case #1 e of
@@ -154,7 +158,7 @@ fun jsExp mode outer =
                         let
                             val n = n - inner
                         in
-                            (quoteExp (List.nth (outer, n)) (ERel n, loc), st)
+                            (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st)
                         end
                   | ENamed _ => raise Fail "Named"
                   | ECon (_, pc, NONE) => (patCon pc, st)
@@ -403,7 +407,7 @@ val decl : state -> decl -> decl * state =
     U.Decl.foldMapB {typ = fn x => x,
                      exp = fn (env, e, st) =>
                               let
-                                  fun doCode m env orig e =
+                                  fun doCode m skip env orig e =
                                       let
                                           val len = length env
                                           fun str s = (EPrim (Prim.String s), #2 e)
@@ -411,14 +415,14 @@ val decl : state -> decl -> decl * state =
                                           val locals = List.tabulate
                                                            (varDepth e,
                                                          fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";"))
-                                          val (e, st) = jsExp m env 0 (e, st)
+                                          val (e, st) = jsExp m skip env 0 (e, st)
                                       in
                                           (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
                                       end
                               in
                                   case e of
-                                      EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m (t :: env) orig e
-                                    | EJavaScript (m, e, _) => doCode m env e e
+                                      EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m 1 (t :: env) orig e
+                                    | EJavaScript (m, e, _) => doCode m 0 env e e
                                     | _ => (e, st)
                               end,
                      decl = fn (_, e, st) => (e, st),
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index c96f97cf..0117623f 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -56,6 +56,7 @@ fun impure (e, _) =
       | EFfiApp ("Basis", "set_cookie", _) => true
       | EFfiApp ("Basis", "new_client_source", _) => true
       | EFfiApp ("Basis", "set_client_source", _) => true
+      | EFfiApp ("Basis", "alert", _) => true
       | EFfiApp _ => false
       | EApp ((EFfi _, _), _) => false
       | EApp _ => true
@@ -253,92 +254,103 @@ fun reduce file =
             IM.empty file
 
         fun summarize d (e, _) =
-            case e of
-                EPrim _ => []
-              | ERel n => if n = d then [UseRel] else []
-              | ENamed _ => []
-              | ECon (_, _, NONE) => []
-              | ECon (_, _, SOME e) => summarize d e
-              | ENone _ => []
-              | ESome (_, e) => summarize d e
-              | EFfi _ => []
-              | EFfiApp ("Basis", "set_cookie", _) => [Unsure]
-              | EFfiApp ("Basis", "new_client_source", _) => [Unsure]
-              | EFfiApp ("Basis", "set_client_source", _) => [Unsure]
-              | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
-              | EApp ((EFfi _, _), e) => summarize d e
-              | EApp _ =>
-                let
-                    fun unravel (e, ls) =
-                        case e of
-                            ENamed n =>
-                            let
-                                val ls = rev ls
-                            in
-                                case IM.find (absCounts, n) of
-                                    NONE => [Unsure]
-                                  | SOME len =>
-                                    if length ls < len then
-                                        ls
-                                    else
-                                        [Unsure]
-                            end
-                          | ERel n => List.revAppend (ls,
-                                                      if n = d then
-                                                          [UseRel, Unsure]
-                                                      else
-                                                          [Unsure])
-                          | EApp (f, x) =>
-                            unravel (#1 f, summarize d x @ ls)
-                          | _ => [Unsure]
-                in
-                    unravel (e, [])
-                end
-
-              | EAbs _ => []
-
-              | EUnop (_, e) => summarize d e
-              | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2
-
-              | ERecord xets => List.concat (map (summarize d o #2) xets)
-              | EField (e, _) => summarize d e
-
-              | ECase (e, pes, _) =>
-                let
-                    val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
-                in
-                    case lss of
-                        [] => raise Fail "Empty pattern match"
-                      | ls :: lss =>
-                        if List.all (fn ls' => ls' = ls) lss then
-                            summarize d e @ ls
-                        else
-                            [Unsure]
-                end
-              | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
-
-              | EError (e, _) => summarize d e @ [Unsure]
-
-              | EWrite e => summarize d e @ [WritePage]
-                            
-              | ESeq (e1, e2) => summarize d e1 @ summarize d e2
-              | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
-
-              | EClosure (_, es) => List.concat (map (summarize d) es)
-
-              | EQuery {query, body, initial, ...} =>
-                List.concat [summarize d query,
-                             summarize (d + 2) body,
-                             summarize d initial,
-                             [ReadDb]]
-
-              | EDml e => summarize d e @ [WriteDb]
-              | ENextval e => summarize d e @ [WriteDb]
-              | EUnurlify (e, _) => summarize d e
-              | EJavaScript (_, e, _) => summarize d e
-              | ESignalReturn e => summarize d e
-              | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
-              | ESignalSource e => summarize d e
+            let
+                val s =
+                    case e of
+                        EPrim _ => []
+                      | ERel n => if n = d then [UseRel] else []
+                      | ENamed _ => []
+                      | ECon (_, _, NONE) => []
+                      | ECon (_, _, SOME e) => summarize d e
+                      | ENone _ => []
+                      | ESome (_, e) => summarize d e
+                      | EFfi _ => []
+                      | EFfiApp ("Basis", "set_cookie", es) => List.concat (map (summarize d) es) @ [Unsure]
+                      | EFfiApp ("Basis", "new_client_source", es) => List.concat (map (summarize d) es) @ [Unsure]
+                      | EFfiApp ("Basis", "set_client_source", es) => List.concat (map (summarize d) es) @ [Unsure]
+                      | EFfiApp ("Basis", "alert", es) => List.concat (map (summarize d) es) @ [Unsure]
+                      | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
+                      | EApp ((EFfi _, _), e) => summarize d e
+                      | EApp _ =>
+                        let
+                            fun unravel (e, ls) =
+                                case e of
+                                    ENamed n =>
+                                    let
+                                        val ls = rev ls
+                                    in
+                                        case IM.find (absCounts, n) of
+                                            NONE => [Unsure]
+                                          | SOME len =>
+                                            if length ls < len then
+                                                ls
+                                            else
+                                                [Unsure]
+                                    end
+                                  | ERel n => List.revAppend (ls,
+                                                              if n = d then
+                                                                  [UseRel, Unsure]
+                                                              else
+                                                                  [Unsure])
+                                  | EApp (f, x) =>
+                                    unravel (#1 f, summarize d x @ ls)
+                                  | _ => [Unsure]
+                        in
+                            unravel (e, [])
+                        end
+
+                      | EAbs (_, _, _, e) => List.filter (fn UseRel => true
+                                                           | _ => false) (summarize (d + 1) e)
+
+                      | EUnop (_, e) => summarize d e
+                      | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2
+
+                      | ERecord xets => List.concat (map (summarize d o #2) xets)
+                      | EField (e, _) => summarize d e
+
+                      | ECase (e, pes, _) =>
+                        let
+                            val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
+                        in
+                            case lss of
+                                [] => raise Fail "Empty pattern match"
+                              | ls :: lss =>
+                                if List.all (fn ls' => ls' = ls) lss then
+                                    summarize d e @ ls
+                                else
+                                    [Unsure]
+                        end
+                      | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
+
+                      | EError (e, _) => summarize d e @ [Unsure]
+
+                      | EWrite e => summarize d e @ [WritePage]
+                                    
+                      | ESeq (e1, e2) => summarize d e1 @ summarize d e2
+                      | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
+
+                      | EClosure (_, es) => List.concat (map (summarize d) es)
+
+                      | EQuery {query, body, initial, ...} =>
+                        List.concat [summarize d query,
+                                     summarize (d + 2) body,
+                                     summarize d initial,
+                                     [ReadDb]]
+
+                      | EDml e => summarize d e @ [WriteDb]
+                      | ENextval e => summarize d e @ [WriteDb]
+                      | EUnurlify (e, _) => summarize d e
+                      | EJavaScript (_, e, _) => summarize d e
+                      | ESignalReturn e => summarize d e
+                      | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
+                      | ESignalSource e => summarize d e
+            in
+                (*Print.prefaces "Summarize"
+                               [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
+                                ("d", Print.PD.string (Int.toString d)),
+                                ("s", p_events s)];*)
+                s
+            end
 
         fun exp env e =
             let
diff --git a/tests/reactive3.ur b/tests/reactive3.ur
new file mode 100644
index 00000000..c12455c5
--- /dev/null
+++ b/tests/reactive3.ur
@@ -0,0 +1,7 @@
+fun main () : transaction page =
+  x <- source <xml>TEST</xml>;
+  return <xml><body>
+    <dyn signal={signal x}/>
+    <br/>
+    <a onclick={alert "Changing...."; set x <xml>CHANGEUP</xml>}>Oh My</a>
+  </body></xml>
diff --git a/tests/reactive3.urp b/tests/reactive3.urp
new file mode 100644
index 00000000..8a95bc84
--- /dev/null
+++ b/tests/reactive3.urp
@@ -0,0 +1,3 @@
+debug
+
+reactive3