_Really_ implement embedded closure GC; extend Scriptcheck to figure out when client IDs must be assigned

8 files changed, 100 insertions, 53 deletions

diff --git a/include/urweb.h b/include/urweb.h
index aa574ff3..daf965b0 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -52,6 +52,8 @@ void uw_set_script_header(uw_context, const char*);
 const char *uw_Basis_get_settings(uw_context, uw_Basis_string);
 const char *uw_Basis_get_script(uw_context, uw_unit);
 
+void uw_set_needs_push(uw_context, int);
+
 char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int);
 char *uw_Basis_htmlifyFloat(uw_context, uw_Basis_float);
 char *uw_Basis_htmlifyString(uw_context, uw_Basis_string);
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index fe996833..de956d3f 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -22,11 +22,19 @@ function union(ls1, ls2) {
 
 // Embedding closures in XML strings
 
+function cs(f) {
+  return {closure: f};
+}
+
+function isWeird(v) {
+  return v.closure != null || v.cat1 != null;
+}
+
 function cat(s1, s2) {
-  if (s1.length && s2.length)
-    return s1 + s2;
+  if (isWeird(s1) || isWeird(s2))
+    return {cat1: s1, cat2: s2};
   else
-    return {_1: s1, _2: s2};
+    return s1 + s2;
 }
 
 var closures = [];
@@ -42,12 +50,12 @@ function cr(n) {
 }
 
 function flatten(tr) {
-  if (tr.length)
-    return tr;
-  else if (tr._1)
-    return cs(tr._1) + cs(tr._2);
+  if (tr.cat1 != null)
+    return flatten(tr.cat1) + flatten(tr.cat2);
+  else if (tr.closure != null)
+    return "cr(" + newClosure(tr.closure) + ")";
   else
-    return "cr(" + newClosure(tr) + ")";
+    return tr;
 }
 
 function clearClosures() {
@@ -157,7 +165,7 @@ function dyn(s) {
         ls.data.dyns = remove(span, ls.data.dyns);
     }
 
-    x.innerHTML = v;
+    x.innerHTML = flatten(v);
     runScripts(x);
 
     if (--dynDepth == 0)
@@ -412,3 +420,7 @@ function rv(chn, parse, k) {
     k(parse(msg))(null);
   }
 }
+
+
+// App-specific code
+
diff --git a/src/c/urweb.c b/src/c/urweb.c
index ed19305e..880cd143 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -300,6 +300,8 @@ struct uw_context {
 
   const char *script_header, *url_prefix;
 
+  int needs_push;
+
   size_t n_deltas, used_deltas;
   delta *deltas;
 
@@ -333,6 +335,7 @@ uw_context uw_init() {
 
   ctx->script_header = "";
   ctx->url_prefix = "/";
+  ctx->needs_push = 0;
   
   ctx->error_message[0] = 0;
 
@@ -476,7 +479,7 @@ uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) {
 }
 
 void uw_login(uw_context ctx) {
-  if (ctx->script_header[0]) {
+  if (ctx->needs_push) {
     char *id_s, *pass_s;
 
     if ((id_s = uw_Basis_requestHeader(ctx, "UrWeb-Client"))
@@ -578,6 +581,10 @@ void uw_set_url_prefix(uw_context ctx, const char *s) {
   ctx->url_prefix = s;
 }
 
+void uw_set_needs_push(uw_context ctx, int n) {
+  ctx->needs_push = n;
+}
+
 
 static void buf_check_ctx(uw_context ctx, buf *b, size_t extra, const char *desc) {
   if (b->back - b->front < extra) {
diff --git a/src/cjr.sml b/src/cjr.sml
index 41bb6a4c..78c2e63b 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -115,7 +115,8 @@ withtype decl = decl' located
 
 datatype sidedness =
          ServerOnly
-       | ServerAndClient
+       | ServerAndPull
+       | ServerAndPullAndPush
 
 type file = decl list * (Core.export_kind * string * int * typ list * typ * sidedness) list
 
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 9c652d4a..54ec3cbf 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2391,12 +2391,19 @@ fun p_file env (ds, ps) =
                                     newline,
                                     string "uw_set_script_header(ctx, \"",
                                     string (case side of
-                                                ServerAndClient => "<script src=\\\""
-                                                                   ^ OS.Path.joinDirFile {dir = !Monoize.urlPrefix,
-                                                                                          file = "app.js"}
-                                                                   ^ "\\\"></script>\\n"
-                                              | ServerOnly => ""),
+                                                ServerOnly => ""
+                                              | _ => "<script src=\\\""
+                                                     ^ OS.Path.joinDirFile {dir = !Monoize.urlPrefix,
+                                                                            file = "app.js"}
+                                                     ^ "\\\"></script>\\n"),
                                     string "\");",
+                                    newline,
+                                    string "uw_set_needs_push(ctx, ",
+                                    string (case side of
+                                                ServerAndPullAndPush => "1"
+                                              | _ => "0"),
+                                    string ");",
+                                    newline,
                                     string "uw_set_url_prefix(ctx, \"",
                                     string (!Monoize.urlPrefix),
                                     string "\");",
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 27287d6e..998ae38e 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -520,7 +520,7 @@ fun cifyDecl ((d, loc), sm) =
             val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
             val (t, sm) = cifyTyp (t, sm)
         in
-            (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndClient), sm)
+            (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush), sm)
         end
 
       | L.DTable (s, xts) =>
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 1409a0cb..c28f58d0 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -850,7 +850,7 @@ fun process file =
                                 val (e1, st) = jsE inner (e1, st)
                                 val (e2, st) = jsE inner (e2, st)
                             in
-                                (strcat [str "(", e1, str "+", e2, str ")"], st)
+                                (strcat [str "cat(", e1, str ",", e2, str ")"], st)
                             end
 
                           | EError (e, _) =>
@@ -891,9 +891,9 @@ fun process file =
 
                           | EJavaScript (Source _, _, SOME _) => (e, st)
                           | EJavaScript (_, _, SOME e) =>
-                            (strcat [str "function(){return ",
+                            (strcat [str "cs(function(){return ",
                                      e,
-                                     str "}"],
+                                     str "})"],
                              st)
 
                           | EClosure _ => unsupported "EClosure"
@@ -905,9 +905,9 @@ fun process file =
                             let
                                 val (e, st) = jsE inner (e, st)
                             in
-                                (strcat [str "function(){return ",
+                                (strcat [str "cs(function(){return ",
                                          e,
-                                         str "}"],
+                                         str "})"],
                                  st)
                             end
 
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 0b51747f..34bf2337 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -35,19 +35,21 @@ structure SS = BinarySetFn(struct
                            end)
 structure IS = IntBinarySet
 
-val csBasis = SS.addList (SS.empty,
-                          ["new_client_source",
-                           "get_client_source",
-                           "set_client_source",
-                           "new_channel",
-                           "subscribe",
-                           "send",
-                           "recv"])
+val pullBasis = SS.addList (SS.empty,
+                            ["new_client_source",
+                             "get_client_source",
+                             "set_client_source"])
 
+val pushBasis = SS.addList (SS.empty,
+                            ["new_channel",
+                             "self"])
+                
 val scriptWords = ["<script",
                    " onclick=",
                    " onload="]
 
+val pushWords = ["rv("]
+
 fun classify (ds, ps) =
     let
         fun inString {needle, haystack} =
@@ -57,11 +59,11 @@ fun classify (ds, ps) =
                 not (Substring.isEmpty suffix)
             end
 
-        fun hasClient csids =
+        fun hasClient {basis, words} csids =
             let
                 fun hasClient e =
                     case #1 e of
-                        EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) scriptWords
+                        EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words
                       | EPrim _ => false
                       | ERel _ => false
                       | ENamed n => IS.member (csids, n)
@@ -69,9 +71,9 @@ fun classify (ds, ps) =
                       | ECon (_, _, SOME e) => hasClient e
                       | ENone _ => false
                       | ESome (_, e) => hasClient e
-                      | EFfi ("Basis", x) => SS.member (csBasis, x)
+                      | EFfi ("Basis", x) => SS.member (basis, x)
                       | EFfi _ => false
-                      | EFfiApp ("Basis", x, es) => SS.member (csBasis, x)
+                      | EFfiApp ("Basis", x, es) => SS.member (basis, x)
                                                     orelse List.exists hasClient es
                       | EFfiApp (_, _, es) => List.exists hasClient es
                       | EApp (e, es) => hasClient e orelse List.exists hasClient es
@@ -93,33 +95,49 @@ fun classify (ds, ps) =
                 hasClient
             end
 
-        fun decl ((d, _), csids) =
+        fun decl ((d, _), (pull_ids, push_ids)) =
             let
-                val hasClient = hasClient csids
+                val hasClientPull = hasClient {basis = pullBasis, words = scriptWords} pull_ids
+                val hasClientPush = hasClient {basis = pushBasis, words = pushWords} push_ids
             in
                 case d of
-                    DVal (_, n, _, e) => if hasClient e then
-                                             IS.add (csids, n)
-                                         else
-                                             csids
-                  | DFun (_, n, _, _, e) => if hasClient e then
-                                                IS.add (csids, n)
-                                            else
-                                                csids
-                  | DFunRec xes => if List.exists (fn (_, _, _, _, e) => hasClient e) xes then
-                                       foldl (fn ((_, n, _, _, _), csids) => IS.add (csids, n))
-                                             csids xes
-                                   else
-                                       csids
-                  | _ => csids
+                    DVal (_, n, _, e) => (if hasClientPull e then
+                                             IS.add (pull_ids, n)
+                                          else
+                                              pull_ids,
+                                          if hasClientPush e then
+                                              IS.add (push_ids, n)
+                                          else
+                                              push_ids)
+                  | DFun (_, n, _, _, e) => (if hasClientPull e then
+                                                 IS.add (pull_ids, n)
+                                             else
+                                                 pull_ids,
+                                             if hasClientPush e then
+                                                 IS.add (push_ids, n)
+                                             else
+                                                 push_ids)
+                  | DFunRec xes => (if List.exists (fn (_, _, _, _, e) => hasClientPull e) xes then
+                                       foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
+                                             pull_ids xes
+                                    else
+                                        pull_ids,
+                                    if List.exists (fn (_, _, _, _, e) => hasClientPush e) xes then
+                                        foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n))
+                                              push_ids xes
+                                    else
+                                        push_ids)
+                  | _ => (pull_ids, push_ids)
             end
 
-        val csids = foldl decl IS.empty ds
+        val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds
 
         val ps = map (fn (ek, x, n, ts, t, _) =>
                          (ek, x, n, ts, t,
-                          if IS.member (csids, n) then
-                              ServerAndClient
+                          if IS.member (push_ids, n) then
+                              ServerAndPullAndPush
+                          else if IS.member (pull_ids, n) then
+                              ServerAndPull
                           else
                               ServerOnly)) ps
     in