Mercurial > urweb
changeset 614:5891f47d7cff
Parameterized RPC query
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 15 Feb 2009 13:03:09 -0500 |
| parents | c5991cdb0c4b |
| children | 3c77133afd9a |
| files | src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml tests/rpcN.ur tests/rpcN.urp |
| diffstat | 8 files changed, 62 insertions(+), 22 deletions(-) [+] |
line wrap: on
line diff
--- a/src/jscomp.sml Sun Feb 15 12:33:41 2009 -0500 +++ b/src/jscomp.sml Sun Feb 15 13:03:09 2009 -0500 @@ -43,7 +43,10 @@ (("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 @@ | 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 @@ | 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 @@ 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 ")"],
--- a/src/mono.sml Sun Feb 15 12:33:41 2009 -0500 +++ b/src/mono.sml Sun Feb 15 13:03:09 2009 -0500 @@ -109,7 +109,7 @@ | ESignalBind of exp * exp | ESignalSource of exp - | EServerCall of string * exp list * exp * typ + | EServerCall of exp * exp * typ withtype exp = exp' located
--- a/src/mono_print.sml Sun Feb 15 12:33:41 2009 -0500 +++ b/src/mono_print.sml Sun Feb 15 13:03:09 2009 -0500 @@ -308,11 +308,8 @@ 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 "]"]
--- a/src/mono_reduce.sml Sun Feb 15 12:33:41 2009 -0500 +++ b/src/mono_reduce.sml Sun Feb 15 13:03:09 2009 -0500 @@ -346,7 +346,7 @@ | 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)),
--- a/src/mono_util.sml Sun Feb 15 12:33:41 2009 -0500 +++ b/src/mono_util.sml Sun Feb 15 13:03:09 2009 -0500 @@ -350,14 +350,12 @@ 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
--- a/src/monoize.sml Sun Feb 15 12:33:41 2009 -0500 +++ b/src/monoize.sml Sun Feb 15 13:03:09 2009 -0500 @@ -2228,8 +2228,26 @@ | 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 @@ (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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/rpcN.ur Sun Feb 15 13:03:09 2009 -0500 @@ -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