summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/jscomp.sml16
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_print.sml7
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_util.sml14
-rw-r--r--src/monoize.sml22
-rw-r--r--tests/rpcN.ur16
-rw-r--r--tests/rpcN.urp5
8 files changed, 62 insertions, 22 deletions
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 9651f930..383a9f6f 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -43,7 +43,10 @@ val funcs = [(("Basis", "alert"), "alert"),
(("Basis", "htmlifyInt"), "ts"),
(("Basis", "htmlifyString"), "eh"),
(("Basis", "new_client_source"), "sc"),
- (("Basis", "set_client_source"), "sv")]
+ (("Basis", "set_client_source"), "sv"),
+ (("Basis", "urlifyInt"), "ts"),
+ (("Basis", "urlifyFloat"), "ts"),
+ (("Basis", "urlifyString"), "escape")]
structure FM = BinaryMapFn(struct
type ord_key = string * string
@@ -98,7 +101,7 @@ fun varDepth (e, _) =
| ESignalReturn e => varDepth e
| ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
| ESignalSource e => varDepth e
- | EServerCall (_, es, ek, _) => foldl Int.max (varDepth ek) (map varDepth es)
+ | EServerCall (e, ek, _) => Int.max (varDepth e, varDepth ek)
fun closedUpto d =
let
@@ -139,7 +142,7 @@ fun closedUpto d =
| ESignalReturn e => cu inner e
| ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
| ESignalSource e => cu inner e
- | EServerCall (_, es, ek, _) => List.all (cu inner) es andalso cu inner ek
+ | EServerCall (e, ek, _) => cu inner e andalso cu inner ek
in
cu 0
end
@@ -926,12 +929,15 @@ fun process file =
st)
end
- | EServerCall (x, es, ek, t) =>
+ | EServerCall (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 ("rc(\"" ^ !Monoize.urlPrefix ^ x ^ "\", function(s){var t=s.split(\"/\");var i=0;return "
+ (strcat [str ("rc(\"" ^ !Monoize.urlPrefix ^ "\"+"),
+ e,
+ str (", function(s){var t=s.split(\"/\");var i=0;return "
^ unurl ^ "},"),
ek,
str ")"],
diff --git a/src/mono.sml b/src/mono.sml
index ea2b9720..b0be4c5f 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -109,7 +109,7 @@ datatype exp' =
| ESignalBind of exp * exp
| ESignalSource of exp
- | EServerCall of string * exp list * exp * typ
+ | EServerCall of exp * exp * typ
withtype exp = exp' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index ba4c57f1..a61b5847 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -308,11 +308,8 @@ fun p_exp' par env (e, _) =
p_exp env e,
string ")"]
- | EServerCall (n, es, e, _) => box [string "Server(",
- string n,
- string ",",
- space,
- p_list (p_exp env) es,
+ | EServerCall (n, e, _) => box [string "Server(",
+ p_exp env n,
string ")[",
p_exp env e,
string "]"]
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 2d0412fd..1f640004 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -346,7 +346,7 @@ fun reduce file =
| ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
| ESignalSource e => summarize d e
- | EServerCall (_, es, ek, _) => List.concat (map (summarize d) es) @ summarize d ek @ [Unsure]
+ | EServerCall (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 d1157218..00113c9b 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -350,14 +350,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
fn e' =>
(ESignalSource e', loc))
- | EServerCall (n, es, ek, t) =>
- S.bind2 (ListUtil.mapfold (fn e => mfe ctx e) es,
- fn es' =>
- S.bind2 (mfe ctx ek,
- fn ek' =>
- S.map2 (mft t,
- fn t' =>
- (EServerCall (n, es', ek', t'), loc))))
+ | EServerCall (n, ek, t) =>
+ S.bind2 (mfe ctx ek,
+ fn ek' =>
+ S.map2 (mft t,
+ fn t' =>
+ (EServerCall (n, ek', t'), loc)))
in
mfe
end
diff --git a/src/monoize.sml b/src/monoize.sml
index 43c3f47d..4efa2fea 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2228,8 +2228,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.EServerCall (n, es, ek, t) =>
let
val t = monoType env t
- val (_, _, _, name) = Env.lookupENamed env n
+ val (_, ft, _, name) = Env.lookupENamed env n
val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
+
+ fun encodeArgs (es, ft, acc, fm) =
+ case (es, ft) of
+ ([], _) => (rev acc, fm)
+ | (e :: es, (L.TFun (dom, ran), _)) =>
+ let
+ val (e, fm) = urlifyExp env fm (e, monoType env dom)
+ in
+ encodeArgs (es, ran, e
+ :: (L'.EPrim (Prim.String "/"), loc)
+ :: acc, fm)
+ end
+ | _ => raise Fail "Monoize: Not enough arguments visible in RPC function type"
+
+ val (call, fm) = encodeArgs (es, ft, [], fm)
+ val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc))
+ (L'.EPrim (Prim.String name), loc) call
+
val (ek, fm) = monoExp (env, st, fm) ek
val ekf = (L'.EAbs ("f",
@@ -2246,7 +2264,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.ERecord [], loc)), loc)), loc)), loc)
val ek = (L'.EApp (ekf, ek), loc)
in
- ((L'.EServerCall (name, es, ek, t), loc), fm)
+ ((L'.EServerCall (call, ek, t), loc), fm)
end
end
diff --git a/tests/rpcN.ur b/tests/rpcN.ur
new file mode 100644
index 00000000..857b5ed0
--- /dev/null
+++ b/tests/rpcN.ur
@@ -0,0 +1,16 @@
+table t : { A : int }
+
+fun main () : transaction page =
+ let
+ fun count a = r <- oneRow (SELECT COUNT( * ) AS N FROM t WHERE t.A = {[a]});
+ return r.N
+ in
+ s <- source 0;
+ return <xml><body>
+ <button value="Get It On!"
+ onclick={n <- count 3;
+ set s n}/><br/>
+ <br/>
+ Current: <dyn signal={n <- signal s; return <xml>{[n]}</xml>}/>
+ </body></xml>
+ end
diff --git a/tests/rpcN.urp b/tests/rpcN.urp
new file mode 100644
index 00000000..6181d8b6
--- /dev/null
+++ b/tests/rpcN.urp
@@ -0,0 +1,5 @@
+debug
+sql rpcN.sql
+database dbname=rpcN
+
+rpcN
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 23:55:37 +0000