From 015297d90b7b9e87034a100d9ce417af6929eaa6 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 22 Mar 2009 16:03:45 -0400 Subject: Proper recv --- lib/js/urweb.js | 78 +++++++++++++++++++++++++++++++++++++++++++++++++++-- lib/ur/basis.urs | 1 + src/cjrize.sml | 1 + src/jscomp.sml | 22 +++++++++++++-- src/mono.sml | 1 + src/mono_print.sml | 5 ++++ src/mono_reduce.sml | 2 ++ src/mono_util.sml | 8 ++++++ src/monoize.sml | 18 +++++++++++++ src/rpcify.sml | 3 ++- src/scriptcheck.sml | 4 ++- tests/channel.ur | 11 +++++++- 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 = ["