diff options
author | Adam Chlipala <adamc@hcoop.net> | 2009-02-15 13:03:09 -0500 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2009-02-15 13:03:09 -0500 |
commit | 4f0987ddef3dc105c3883aa9c1c69c29fbe86a8a (patch) | |
tree | 30c7775fe1755a17af3ea46d0a02ebf077c822ac | |
parent | f083e82c95ac4a9d3a22e032f81b6dc88a88f499 (diff) |
Parameterized RPC query
-rw-r--r-- | src/jscomp.sml | 16 | ||||
-rw-r--r-- | src/mono.sml | 2 | ||||
-rw-r--r-- | src/mono_print.sml | 7 | ||||
-rw-r--r-- | src/mono_reduce.sml | 2 | ||||
-rw-r--r-- | src/mono_util.sml | 14 | ||||
-rw-r--r-- | src/monoize.sml | 22 | ||||
-rw-r--r-- | tests/rpcN.ur | 16 | ||||
-rw-r--r-- | tests/rpcN.urp | 5 |
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 |