summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/cjrize.sml1
-rw-r--r--src/jscomp.sml22
-rw-r--r--src/mono.sml1
-rw-r--r--src/mono_print.sml5
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_util.sml8
-rw-r--r--src/monoize.sml18
-rw-r--r--src/rpcify.sml3
-rw-r--r--src/scriptcheck.sml4
9 files changed, 60 insertions, 4 deletions
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