Mercurial > urweb
changeset 670:f73913d97a40
Proper recv
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 22 Mar 2009 16:03:45 -0400 |
| parents | f68eee90dbcf |
| children | 729e65db2e2f |
| files | lib/js/urweb.js lib/ur/basis.urs src/cjrize.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/rpcify.sml src/scriptcheck.sml tests/channel.ur |
| diffstat | 12 files changed, 147 insertions(+), 7 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/js/urweb.js Sun Mar 22 15:16:34 2009 -0400 +++ b/lib/js/urweb.js Sun Mar 22 16:03:45 2009 -0400 @@ -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 @@ requestUri(xhr, uri); } - function path_join(s1, s2) { if (s1.length > 0 && s1[s1.length-1] == '/') return s1 + s2; @@ -200,6 +200,37 @@ 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 @@ 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 @@ 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("+", " "); +}
--- a/lib/ur/basis.urs Sun Mar 22 15:16:34 2009 -0400 +++ b/lib/ur/basis.urs Sun Mar 22 16:03:45 2009 -0400 @@ -460,3 +460,4 @@ 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
--- a/src/cjrize.sml Sun Mar 22 15:16:34 2009 -0400 +++ b/src/cjrize.sml Sun Mar 22 16:03:45 2009 -0400 @@ -430,6 +430,7 @@ | 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
--- a/src/jscomp.sml Sun Mar 22 15:16:34 2009 -0400 +++ b/src/jscomp.sml Sun Mar 22 16:03:45 2009 -0400 @@ -49,7 +49,8 @@ (("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 @@ | 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 @@ | 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 @@ @ ["}"]), 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 @@ 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
--- a/src/mono.sml Sun Mar 22 15:16:34 2009 -0400 +++ b/src/mono.sml Sun Mar 22 16:03:45 2009 -0400 @@ -110,6 +110,7 @@ | ESignalSource of exp | EServerCall of exp * exp * typ + | ERecv of exp * exp * typ withtype exp = exp' located
--- a/src/mono_print.sml Sun Mar 22 15:16:34 2009 -0400 +++ b/src/mono_print.sml Sun Mar 22 16:03:45 2009 -0400 @@ -313,6 +313,11 @@ 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
--- a/src/mono_reduce.sml Sun Mar 22 15:16:34 2009 -0400 +++ b/src/mono_reduce.sml Sun Mar 22 16:03:45 2009 -0400 @@ -85,6 +85,7 @@ | ESignalBind (e1, e2) => impure e1 orelse impure e2 | ESignalSource e => impure e | EServerCall _ => true + | ERecv _ => true val liftExpInExp = Monoize.liftExpInExp @@ -355,6 +356,7 @@ | 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)),
--- a/src/mono_util.sml Sun Mar 22 15:16:34 2009 -0400 +++ b/src/mono_util.sml Sun Mar 22 16:03:45 2009 -0400 @@ -358,6 +358,14 @@ 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
--- a/src/monoize.sml Sun Mar 22 15:16:34 2009 -0400 +++ b/src/monoize.sml Sun Mar 22 16:03:45 2009 -0400 @@ -979,6 +979,24 @@ 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
--- a/src/rpcify.sml Sun Mar 22 15:16:34 2009 -0400 +++ b/src/rpcify.sml Sun Mar 22 16:03:45 2009 -0400 @@ -59,7 +59,8 @@ ["source", "get", "set", - "alert"]) + "alert", + "recv"]) type state = { cpsed : int IM.map,
--- a/src/scriptcheck.sml Sun Mar 22 15:16:34 2009 -0400 +++ b/src/scriptcheck.sml Sun Mar 22 16:03:45 2009 -0400 @@ -41,10 +41,12 @@ "set_client_source", "new_channel", "subscribe", + "send", "recv"]) val scriptWords = ["<script", - " onclick="] + " onclick=", + " onload="] fun classify (ds, ps) = let
--- a/tests/channel.ur Sun Mar 22 15:16:34 2009 -0400 +++ b/tests/channel.ur Sun Mar 22 16:03:45 2009 -0400 @@ -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