Proper recv

12 files changed, 147 insertions, 7 deletions

diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 18842188..6cb5c60a 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -1,6 +1,7 @@
 function cons(v, ls) {
   return { n : ls, v : v };
 }
+
 function callAll(ls) {
   for (; ls; ls = ls.n)
     ls.v();
@@ -192,7 +193,6 @@ function rc(uri, parse, k) {
   requestUri(xhr, uri);
 }
 
-
 function path_join(s1, s2) {
   if (s1.length > 0 && s1[s1.length-1] == '/')
     return s1 + s2;
@@ -200,6 +200,37 @@ function path_join(s1, s2) {
     return s1 + "/" + s2;
 }
 
+var channels = [];
+
+function newQueue() {
+  return { front : null, back : null };
+}
+function enqueue(q, v) {
+  if (q.front == null) {
+    q.front = cons(v, null);
+    q.back = q.front;
+  } else {
+    var node = cons(v, null);
+    q.back.n = node;
+    q.back = node;
+  }
+}
+function dequeue(q) {
+  if (q.front == null)
+    return null;
+  else {
+    var r = q.front.v;
+    q.front = q.front.n;
+    if (q.front == null)
+      q.back = null;
+    return r;
+  }
+}
+
+function newChannel() {
+  return { msgs : newQueue(), listeners : newQueue() };
+}
+
 function listener() {
   var uri = path_join(url_prefix, ".msgs");
   var xhr = getXHR();
@@ -218,7 +249,26 @@ function listener() {
           whine("Empty message from remote server");
 
         for (var i = 0; i+1 < lines.length; i += 2) {
-          alert("Message(" + lines[i] + "): " + lines[i+1]);
+          var chn = lines[i];
+          var msg = lines[i+1];
+
+          if (chn < 0)
+            whine("Out-of-bounds channel in message from remote server");
+
+          var ch;
+
+          if (chn >= channels.length || channels[chn] == null) {
+            ch = newChannel();
+            channels[chn] = ch;
+          } else
+            ch = channels[chn];
+
+          var listener = dequeue(ch.listeners);
+          if (listener == null) {
+            enqueue(ch.msgs, msg);
+          } else {
+            listener(msg);
+          }
         }
 
         xhr.onreadystatechange = orsc;
@@ -233,3 +283,27 @@ function listener() {
   xhr.onreadystatechange = orsc;
   requestUri(xhr, uri);
 }
+
+function rv(chn, parse, k) {
+  if (chn < 0)
+    whine("Out-of-bounds channel receive");
+
+  var ch;
+
+  if (chn >= channels.length || channels[chn] == null) {
+    ch = newChannel();
+    channels[chn] = ch;
+  } else
+    ch = channels[chn];
+
+  var msg = dequeue(ch.msgs);
+  if (msg == null) {
+    enqueue(ch.listeners, function(msg) { k(parse(msg))(null); });
+  } else {
+    k(parse(msg))(null);
+  }
+}
+
+function unesc(s) {
+  return unescape(s).replace("+", " ");
+}
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index e7172db1..8c28dacb 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -460,3 +460,4 @@ con channel :: Type -> Type
 val channel : t ::: Type -> transaction (channel t)
 val subscribe : t ::: Type -> channel t -> transaction unit
 val send : t ::: Type -> channel t -> t -> transaction unit
+val recv : t ::: Type -> channel t -> transaction t
diff --git a/src/cjrize.sml b/src/cjrize.sml
index e637c82c..27287d6e 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -430,6 +430,7 @@ fun cifyExp (eAll as (e, loc), sm) =
       | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains"
 
       | L.EServerCall _ => raise Fail "Cjrize EServerCall"
+      | L.ERecv _ => raise Fail "Cjrize ERecv"
 
 fun cifyDecl ((d, loc), sm) =
     case d of
diff --git a/src/jscomp.sml b/src/jscomp.sml
index be227035..36d42754 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -49,7 +49,8 @@ val funcs = [(("Basis", "alert"), "alert"),
              (("Basis", "urlifyInt"), "ts"),
              (("Basis", "urlifyFloat"), "ts"),
              (("Basis", "urlifyString"), "escape"),
-             (("Basis", "urlifyChannel"), "ts")]
+             (("Basis", "urlifyChannel"), "ts"),
+             (("Basis", "recv"), "rv")]
 
 structure FM = BinaryMapFn(struct
                            type ord_key = string * string
@@ -106,6 +107,7 @@ fun varDepth (e, _) =
       | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
       | ESignalSource e => varDepth e
       | EServerCall (e, ek, _) => Int.max (varDepth e, varDepth ek)
+      | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek)
 
 fun closedUpto d =
     let
@@ -147,6 +149,7 @@ fun closedUpto d =
               | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
               | ESignalSource e => cu inner e
               | EServerCall (e, ek, _) => cu inner e andalso cu inner ek
+              | ERecv (e, ek, _) => cu inner e andalso cu inner ek
     in
         cu 0
     end
@@ -342,7 +345,7 @@ fun process file =
                                     @ ["}"]), st)
                 end
 
-              | TFfi ("Basis", "string") => ("unescape(t[i++])", st)
+              | TFfi ("Basis", "string") => ("unesc(t[i++])", st)
               | TFfi ("Basis", "int") => ("parseInt(t[i++])", st)
               | TFfi ("Basis", "float") => ("parseFloat(t[i++])", st)
 
@@ -952,6 +955,21 @@ fun process file =
                                          str ")"],
                                  st)
                             end
+
+                          | ERecv (e, ek, t) =>
+                            let
+                                val (e, st) = jsE inner (e, st)
+                                val (ek, st) = jsE inner (ek, st)
+                                val (unurl, st) = unurlifyExp loc (t, st)
+                            in
+                                (strcat [str "rv(",
+                                         e,
+                                         str (", function(s){var t=s.split(\"/\");var i=0;return "
+                                              ^ unurl ^ "},"),
+                                         ek,
+                                         str ")"],
+                                 st)
+                            end
                     end
             in
                 jsE
diff --git a/src/mono.sml b/src/mono.sml
index b0be4c5f..3aa65b6a 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -110,6 +110,7 @@ datatype exp' =
        | ESignalSource of exp
 
        | EServerCall of exp * exp * typ
+       | ERecv of exp * exp * typ
 
 withtype exp = exp' located
 
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a61b5847..cbe90371 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -313,6 +313,11 @@ fun p_exp' par env (e, _) =
                                           string ")[",
                                           p_exp env e,
                                           string "]"]
+      | ERecv (n, e, _) => box [string "Recv(",
+                                p_exp env n,
+                                string ")[",
+                                p_exp env e,
+                                string "]"]
 
 and p_exp env = p_exp' false env
 
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index b789e05f..b2f0ecee 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -85,6 +85,7 @@ fun impure (e, _) =
       | ESignalBind (e1, e2) => impure e1 orelse impure e2
       | ESignalSource e => impure e
       | EServerCall _ => true
+      | ERecv _ => true
 
 
 val liftExpInExp = Monoize.liftExpInExp
@@ -355,6 +356,7 @@ fun reduce file =
                       | ESignalSource e => summarize d e
 
                       | EServerCall (e, ek, _) => summarize d e @ summarize d ek @ [Unsure]
+                      | ERecv (e, ek, _) => summarize d e @ summarize d ek @ [Unsure]
             in
                 (*Print.prefaces "Summarize"
                                [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
diff --git a/src/mono_util.sml b/src/mono_util.sml
index dd5107c6..bbc9c7e7 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -358,6 +358,14 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                                      S.map2 (mft t,
                                           fn t' =>
                                              (EServerCall (s', ek', t'), loc))))
+              | ERecv (s, ek, t) =>
+                S.bind2 (mfe ctx s,
+                         fn s' =>
+                            S.bind2 (mfe ctx ek,
+                                  fn ek' =>
+                                     S.map2 (mft t,
+                                          fn t' =>
+                                             (ERecv (s', ek', t'), loc))))
     in
         mfe
     end
diff --git a/src/monoize.sml b/src/monoize.sml
index d6b5ae15..87530070 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -979,6 +979,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                           loc)), loc)), loc)), loc)), loc),
                  fm)
             end
+          | L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _),
+                             (L.EFfi ("Basis", "transaction_monad"), _)), _),
+                    (L.EApp ((L.ECApp ((L.EFfi ("Basis", "recv"), _), t1), _),
+                             ch), loc)) =>
+            let
+                val t1 = monoType env t1
+                val t2 = monoType env t2
+                val un = (L'.TRecord [], loc)
+                val mt2 = (L'.TFun (un, t2), loc)
+                val (ch, fm) = monoExp (env, st, fm) ch
+            in
+                ((L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
+                           (L'.EAbs ("_", un, un,
+                                     (L'.ERecv (liftExpInExp 0 (liftExpInExp 0 ch),
+                                                (L'.ERel 1, loc),
+                                                t1), loc)), loc)), loc),
+                 fm)
+            end
 
           | L.ECApp ((L.EFfi ("Basis", "source"), _), t) =>
             let
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 1212b81e..a4bfe71a 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -59,7 +59,8 @@ val csBasis = SS.addList (SS.empty,
                           ["source",
                            "get",
                            "set",
-                           "alert"])
+                           "alert",
+                           "recv"])
 
 type state = {
      cpsed : int IM.map,
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 2bc185f9..0b51747f 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -41,10 +41,12 @@ val csBasis = SS.addList (SS.empty,
                            "set_client_source",
                            "new_channel",
                            "subscribe",
+                           "send",
                            "recv"])
 
 val scriptWords = ["<script",
-                   " onclick="]
+                   " onclick=",
+                   " onload="]
 
 fun classify (ds, ps) =
     let
diff --git a/tests/channel.ur b/tests/channel.ur
index 6b98f5d7..df50ea27 100644
--- a/tests/channel.ur
+++ b/tests/channel.ur
@@ -1,10 +1,19 @@
 fun main () : transaction page =
     ch <- channel;
     let
-        fun onload () =
+        fun make () =
             subscribe ch;
             send ch "Hello world!"
 
+        fun echo () =
+            msg <- recv ch;
+            alert(msg);
+            echo ()
+
+        fun onload () =
+            make ();
+            echo ()
+
         fun haveAnother () =
             send ch "Here's another."
     in