diff options
| -rw-r--r-- | demo/batch.ur | 80 | ||||
| -rw-r--r-- | demo/batch.urp | 3 | ||||
| -rw-r--r-- | demo/batch.urs | 1 | ||||
| -rw-r--r-- | demo/increment.urp | 1 | ||||
| -rw-r--r-- | demo/prose | 4 | ||||
| -rw-r--r-- | lib/js/urweb.js | 25 | ||||
| -rw-r--r-- | src/jscomp.sml | 6 | ||||
| -rw-r--r-- | src/mono_opt.sml | 2 | ||||
| -rw-r--r-- | src/rpcify.sml | 506 |
9 files changed, 395 insertions, 233 deletions
diff --git a/demo/batch.ur b/demo/batch.ur new file mode 100644 index 00000000..454ff691 --- /dev/null +++ b/demo/batch.ur @@ -0,0 +1,80 @@ +datatype list t = Nil | Cons of t * list t + +table t : {Id : int, A : string} + +fun allRows () = + query (SELECT * FROM t) + (fn r acc => return (Cons ((r.T.Id, r.T.A), acc))) + Nil + +fun doBatch ls = + case ls of + Nil => return () + | Cons ((id, a), ls') => + dml (INSERT INTO t (Id, A) VALUES ({[id]}, {[a]})); + doBatch ls' + +fun del id = + dml (DELETE FROM t WHERE t.Id = {[id]}) + +fun show withDel lss = + let + fun show' ls = + case ls of + Nil => <xml/> + | Cons ((id, a), ls) => <xml> + <tr><td>{[id]}</td> <td>{[a]}</td> {if withDel then + <xml><td><button value="Delete" onclick={del id}/></td></xml> + else + <xml/>} </tr> + {show' ls} + </xml> + in + <xml><dyn signal={ls <- signal lss; return <xml><table> + <tr> <th>Id</th> <th>A</th> </tr> + {show' ls} + </table></xml>}/></xml> + end + +fun main () = + lss <- source Nil; + batched <- source Nil; + + id <- source ""; + a <- source ""; + + let + fun add () = + id <- get id; + a <- get a; + ls <- get batched; + + set batched (Cons ((readError id, a), ls)) + + fun exec () = + ls <- get batched; + + doBatch ls; + set batched Nil + in + return <xml><body> + <h2>Rows</h2> + + {show True lss} + + <button value="Update" onclick={ls <- allRows (); set lss ls}/><br/> + <br/> + + <h2>Batch new rows to add</h2> + + <table> + <tr> <th>Id:</th> <td><ctextbox source={id}/></td> </tr> + <tr> <th>A:</th> <td><ctextbox source={a}/></td> </tr> + <tr> <th/> <td><button value="Batch it" onclick={add ()}/></td> </tr> + </table> + + <h2>Already batched:</h2> + {show False batched} + <button value="Execute" onclick={exec ()}/> + </body></xml> + end diff --git a/demo/batch.urp b/demo/batch.urp new file mode 100644 index 00000000..00a7b25e --- /dev/null +++ b/demo/batch.urp @@ -0,0 +1,3 @@ +database dbname=test + +batch diff --git a/demo/batch.urs b/demo/batch.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/batch.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/demo/increment.urp b/demo/increment.urp index 777a6edd..3a5c1073 100644 --- a/demo/increment.urp +++ b/demo/increment.urp @@ -1,4 +1,3 @@ database dbname=test -sql increment.sql increment @@ -209,3 +209,7 @@ listEdit.urp increment.urp <p>Here's an example where client-side code needs to run more code on the server. We maintain a (server-side) SQL sequence. When the user clicks a button, an AJAX request increments the remote sequence and gets the new value.</p> + +batch.urp + +<p>This example shows more of what is possible with mixed client/server code. The application is an editor for a simple database table, where additions of new rows can be batched in the client, before a button is clicked to trigger a mass addition.</p> diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 158e574d..08d96040 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -99,7 +99,26 @@ function eh(x) { function ts(x) { return x.toString() } function bs(b) { return (b ? "True" : "False") } -function pf() { alert("Pattern match failure") } +function pi(s) { + var r = parseInt(s); + if (r.toString() == s) + return r; + else + throw "Can't parse int: " + s; +} + +function pfl(s) { + var r = parseFloat(s); + if (r.toString() == s) + return r; + else + throw "Can't parse float: " + s; +} + +function pf() { + alert("Pattern match failure"); + throw "Pattern match failure"; +} var closures = []; @@ -145,8 +164,10 @@ function rc(uri, parse, k) { if (isok) k(parse(xhr.responseText)); - else + else { alert("Error querying remote server!"); + throw "Error querying remote server!"; + } } }; diff --git a/src/jscomp.sml b/src/jscomp.sml index 37bbf79d..adff2fda 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -44,6 +44,8 @@ val funcs = [(("Basis", "alert"), "alert"), (("Basis", "htmlifyString"), "eh"), (("Basis", "new_client_source"), "sc"), (("Basis", "set_client_source"), "sv"), + (("Basis", "stringToFloat_error"), "pfl"), + (("Basis", "stringToInt_error"), "pi"), (("Basis", "urlifyInt"), "ts"), (("Basis", "urlifyFloat"), "ts"), (("Basis", "urlifyString"), "escape")] @@ -893,7 +895,7 @@ fun process file = | EDml _ => unsupported "DML" | ENextval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" - | EJavaScript (_, e as (EAbs _, _), _) => + (*| EJavaScript (_, e as (EAbs _, _), _) => let val (e, st) = jsE inner (e, st) in @@ -901,7 +903,7 @@ fun process file = e, str ")+\")\""], st) - end + end*) | EJavaScript (_, e, _) => let val (e, st) = jsE inner (e, st) diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 7f23d8b1..469fc0d8 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -365,6 +365,8 @@ fun exp e = | EJavaScript (_, _, SOME (e, _)) => e + | EApp ((e1 as EServerCall _, _), (ERecord [], _)) => e1 + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/rpcify.sml b/src/rpcify.sml index 0b336a3d..7e731f63 100644 --- a/src/rpcify.sml +++ b/src/rpcify.sml @@ -140,242 +140,292 @@ fun frob file = IM.empty file fun exp (e, st) = - case e of - EApp ( - (EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - (ECase (ed, pes, {disc, ...}), _)), _), - trans2) => - let - val e' = (EFfi ("Basis", "bind"), loc) - val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) - val e' = (ECApp (e', t1), loc) - val e' = (ECApp (e', t2), loc) - val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) - - val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) => - let - val e' = (EApp (e', e), loc) - val e' = (EApp (e', - multiLiftExpInExp (E.patBindsN p) - trans2), loc) - val (e', st) = doExp (e', st) - in - ((p, e'), st) - end) st pes - in - (ECase (ed, pes, {disc = disc, - result = (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc)}), - st) - end - - | EApp ( - (EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - (EServerCall (n, es, ke, t), _)), _), - trans2) => - let - val e' = (EFfi ("Basis", "bind"), loc) - val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) - val e' = (ECApp (e', t), loc) - val e' = (ECApp (e', t2), loc) - val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) - val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc) - val e' = (EApp (e', E.liftExpInExp 0 trans2), loc) - val e' = (EAbs ("x", t, t2, e'), loc) - val e' = (EServerCall (n, es, e', t), loc) - val (e', st) = doExp (e', st) - in - (#1 e', st) - end - - | EApp ( - (EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - (EApp ((EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - trans1), _), trans2), _)), _), - trans3) => - let - val e'' = (EFfi ("Basis", "bind"), loc) - val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc) - val e'' = (ECApp (e'', t2), loc) - val e'' = (ECApp (e'', t3), loc) - val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc) - val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc) - val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc) - val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc) - - val e' = (EFfi ("Basis", "bind"), loc) - val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) - val e' = (ECApp (e', t1), loc) - val e' = (ECApp (e', t3), loc) - val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) - val e' = (EApp (e', trans1), loc) - val e' = (EApp (e', e''), loc) - val (e', st) = doExp (e', st) - in - (#1 e', st) - end - - | EApp ( - (EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), _), _), _), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - _), loc), - (EAbs (_, _, _, (EWrite _, _)), _)) => (e, st) - - | EApp ( - (EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - trans1), loc), - trans2) => - let - (*val () = Print.prefaces "Default" - [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*) - - fun getApp (e', args) = + let + fun getApp (e', args) = + let + val loc = #2 e' + in case #1 e' of ENamed n => (n, args) | EApp (e1, e2) => getApp (e1, e2 :: args) | _ => (ErrorMsg.errorAt loc "Mixed client/server code doesn't use a named function for server part"; Print.prefaces "Bad" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]; (0, [])) - in - case (serverSide (#cpsed_range st) trans1, clientSide (#cpsed_range st) trans1, - serverSide (#cpsed_range st) trans2, clientSide (#cpsed_range st) trans2) of - (true, false, _, true) => - let - val (n, args) = getApp (trans1, []) - - val (exported, export_decls) = - if IS.member (#exported st, n) then - (#exported st, #export_decls st) - else - (IS.add (#exported st, n), - (DExport (Rpc, n), loc) :: #export_decls st) - - val st = {cpsed = #cpsed st, - cpsed_range = #cpsed_range st, - cps_decls = #cps_decls st, - - exported = exported, - export_decls = export_decls, - - maxName = #maxName st} - - val ran = - case IM.find (tfuncs, n) of - NONE => (Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))]; - raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n)) - | SOME (_, _, ran, _) => ran - - val e' = EServerCall (n, args, trans2, ran) - in - (EServerCall (n, args, trans2, ran), st) - end - | (true, true, _, _) => - let - val (n, args) = getApp (trans1, []) - - fun makeCall n' = - let - val e = (ENamed n', loc) - val e = (EApp (e, trans2), loc) - in - #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args) - end - in - case IM.find (#cpsed_range st, n) of - SOME kdom => - (case args of - [] => raise Fail "Rpcify: cps'd function lacks first argument" - | ke :: args => + end + + fun newRpc (trans1, trans2, st : state) = + let + val loc = #2 trans1 + + val (n, args) = getApp (trans1, []) + + val (exported, export_decls) = + if IS.member (#exported st, n) then + (#exported st, #export_decls st) + else + (IS.add (#exported st, n), + (DExport (Rpc, n), loc) :: #export_decls st) + + val st = {cpsed = #cpsed st, + cpsed_range = #cpsed_range st, + cps_decls = #cps_decls st, + + exported = exported, + export_decls = export_decls, + + maxName = #maxName st} + + val ran = + case IM.find (tfuncs, n) of + NONE => (Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))]; + raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n)) + | SOME (_, _, ran, _) => ran + + val e' = EServerCall (n, args, trans2, ran) + in + (e', st) + end + in + case e of + EApp ( + (EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + (ECase (ed, pes, {disc, ...}), _)), _), + trans2) => + let + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) + val e' = (ECApp (e', t1), loc) + val e' = (ECApp (e', t2), loc) + val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) + + val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) => + let + val e' = (EApp (e', e), loc) + val e' = (EApp (e', + multiLiftExpInExp (E.patBindsN p) + trans2), loc) + val (e', st) = doExp (e', st) + in + ((p, e'), st) + end) st pes + in + (ECase (ed, pes, {disc = disc, + result = (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc)}), + st) + end + + | EApp ( + (EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + (EServerCall (n, es, ke, t), _)), _), + trans2) => + let + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) + val e' = (ECApp (e', t), loc) + val e' = (ECApp (e', t2), loc) + val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) + val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc) + val e' = (EApp (e', E.liftExpInExp 0 trans2), loc) + val e' = (EAbs ("x", t, t2, e'), loc) + val e' = (EServerCall (n, es, e', t), loc) + val (e', st) = doExp (e', st) + in + (#1 e', st) + end + + | EApp ( + (EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + (EApp ((EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + trans1), _), trans2), _)), _), + trans3) => + let + val e'' = (EFfi ("Basis", "bind"), loc) + val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc) + val e'' = (ECApp (e'', t2), loc) + val e'' = (ECApp (e'', t3), loc) + val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc) + val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc) + val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc) + val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc) + + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) + val e' = (ECApp (e', t1), loc) + val e' = (ECApp (e', t3), loc) + val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) + val e' = (EApp (e', trans1), loc) + val e' = (EApp (e', e''), loc) + val (e', st) = doExp (e', st) + in + (#1 e', st) + end + + | EApp ( + (EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), _), _), _), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + _), loc), + (EAbs (_, _, _, (EWrite _, _)), _)) => (e, st) + + | EApp ( + (EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + trans1), loc), + trans2) => + (case (serverSide (#cpsed_range st) trans1, clientSide (#cpsed_range st) trans1, + serverSide (#cpsed_range st) trans2, clientSide (#cpsed_range st) trans2) of + (true, false, _, true) => newRpc (trans1, trans2, st) + | (true, true, _, _) => + let + val (n, args) = getApp (trans1, []) + + fun makeCall n' = + let + val e = (ENamed n', loc) + val e = (EApp (e, trans2), loc) + in + #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args) + end + in + case IM.find (#cpsed_range st, n) of + SOME kdom => + (case args of + [] => raise Fail "Rpcify: cps'd function lacks first argument" + | ke :: args => + let + val ke' = (EFfi ("Basis", "bind"), loc) + val ke' = (ECApp (ke', (CFfi ("Basis", "transaction"), loc)), loc) + val ke' = (ECApp (ke', kdom), loc) + val ke' = (ECApp (ke', t2), loc) + val ke' = (EApp (ke', (EFfi ("Basis", "transaction_monad"), loc)), loc) + val ke' = (EApp (ke', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc) + val ke' = (EApp (ke', E.liftExpInExp 0 trans2), loc) + val ke' = (EAbs ("x", kdom, + (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc), + ke'), loc) + + val e' = (ENamed n, loc) + val e' = (EApp (e', ke'), loc) + val e' = foldl (fn (arg, e') => (EApp (e', arg), loc)) e' args + val (e', st) = doExp (e', st) + in + (#1 e', st) + end) + | NONE => + case IM.find (#cpsed st, n) of + SOME n' => (makeCall n', st) + | NONE => let - val ke' = (EFfi ("Basis", "bind"), loc) - val ke' = (ECApp (ke', (CFfi ("Basis", "transaction"), loc)), loc) - val ke' = (ECApp (ke', kdom), loc) - val ke' = (ECApp (ke', t2), loc) - val ke' = (EApp (ke', (EFfi ("Basis", "transaction_monad"), loc)), loc) - val ke' = (EApp (ke', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc) - val ke' = (EApp (ke', E.liftExpInExp 0 trans2), loc) - val ke' = (EAbs ("x", kdom, - (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc), - ke'), loc) - - val e' = (ENamed n, loc) - val e' = (EApp (e', ke'), loc) - val e' = foldl (fn (arg, e') => (EApp (e', arg), loc)) e' args - val (e', st) = doExp (e', st) + val (name, fargs, ran, e) = + case IM.find (tfuncs, n) of + NONE => (Print.prefaces "BAD" [("e", + CorePrint.p_exp CoreEnv.empty (e, loc))]; + raise Fail "Rpcify: Undetected transaction function [2]") + | SOME x => x + + val n' = #maxName st + + val st = {cpsed = IM.insert (#cpsed st, n, n'), + cpsed_range = IM.insert (#cpsed_range st, n', ran), + cps_decls = #cps_decls st, + exported = #exported st, + export_decls = #export_decls st, + maxName = n' + 1} + + val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) + val body = (EFfi ("Basis", "bind"), loc) + val body = (ECApp (body, (CFfi ("Basis", "transaction"), loc)), loc) + val body = (ECApp (body, t1), loc) + val body = (ECApp (body, unit), loc) + val body = (EApp (body, (EFfi ("Basis", "transaction_monad"), loc)), loc) + val body = (EApp (body, e), loc) + val body = (EApp (body, (ERel (length args), loc)), loc) + val bt = (CApp ((CFfi ("Basis", "transaction"), loc), unit), loc) + val (body, bt) = foldr (fn ((x, t), (body, bt)) => + ((EAbs (x, t, bt, body), loc), + (TFun (t, bt), loc))) + (body, bt) fargs + val kt = (TFun (ran, (CApp ((CFfi ("Basis", "transaction"), loc), + unit), + loc)), loc) + val body = (EAbs ("k", kt, bt, body), loc) + val bt = (TFun (kt, bt), loc) + + val (body, st) = doExp (body, st) + + val vi = (name ^ "_cps", + n', + bt, + body, + "") + + val st = {cpsed = #cpsed st, + cpsed_range = #cpsed_range st, + cps_decls = vi :: #cps_decls st, + exported = #exported st, + export_decls = #export_decls st, + maxName = #maxName st} in - (#1 e', st) - end) - | NONE => - case IM.find (#cpsed st, n) of - SOME n' => (makeCall n', st) - | NONE => - let - val (name, fargs, ran, e) = - case IM.find (tfuncs, n) of - NONE => (Print.prefaces "BAD" [("e", - CorePrint.p_exp CoreEnv.empty (e, loc))]; - raise Fail "Rpcify: Undetected transaction function [2]") - | SOME x => x - - val n' = #maxName st - - val st = {cpsed = IM.insert (#cpsed st, n, n'), - cpsed_range = IM.insert (#cpsed_range st, n', ran), - cps_decls = #cps_decls st, - exported = #exported st, - export_decls = #export_decls st, - maxName = n' + 1} - - val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) - val body = (EFfi ("Basis", "bind"), loc) - val body = (ECApp (body, (CFfi ("Basis", "transaction"), loc)), loc) - val body = (ECApp (body, t1), loc) - val body = (ECApp (body, unit), loc) - val body = (EApp (body, (EFfi ("Basis", "transaction_monad"), loc)), loc) - val body = (EApp (body, e), loc) - val body = (EApp (body, (ERel (length args), loc)), loc) - val bt = (CApp ((CFfi ("Basis", "transaction"), loc), unit), loc) - val (body, bt) = foldr (fn ((x, t), (body, bt)) => - ((EAbs (x, t, bt, body), loc), - (TFun (t, bt), loc))) - (body, bt) fargs - val kt = (TFun (ran, (CApp ((CFfi ("Basis", "transaction"), loc), - unit), - loc)), loc) - val body = (EAbs ("k", kt, bt, body), loc) - val bt = (TFun (kt, bt), loc) - - val (body, st) = doExp (body, st) - - val vi = (name ^ "_cps", - n', - bt, - body, - "") - - val st = {cpsed = #cpsed st, - cpsed_range = #cpsed_range st, - cps_decls = vi :: #cps_decls st, - exported = #exported st, - export_decls = #export_decls st, - maxName = #maxName st} - in - (makeCall n', st) - end - end - | _ => (e, st) - end - | _ => (e, st) + (makeCall n', st) + end + end + | _ => (e, st)) + + | ERecord xes => + let + val loc = case xes of + [] => ErrorMsg.dummySpan + | (_, (_, loc), _) :: _ => loc + + fun candidate (x, e) = + String.isPrefix "On" x + andalso serverSide (#cpsed_range st) e + andalso not (clientSide (#cpsed_range st) e) + in + if List.exists (fn ((CName x, _), e, _) => candidate (x, e) + | _ => false) xes then + let + val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) + + val k = (EFfi ("Basis", "return"), loc) + val k = (ECApp (k, (CFfi ("Basis", "transaction"), loc)), loc) + val k = (ECApp (k, unit), loc) + val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc) + val k = (EApp (k, (ERecord [], loc)), loc) + val k = (EAbs ("_", unit, unit, k), loc) + + val (xes, st) = ListUtil.foldlMap + (fn (y as (nm as (CName x, _), e, t), st) => + if candidate (x, e) then + let + val (n, args) = getApp (e, []) + + val (e, st) = newRpc (e, k, st) + in + ((nm, (e, loc), t), st) + end + else + (y, st) + | y => y) + st xes + in + (ERecord xes, st) + end + else + (e, st) + end + + | _ => (e, st) + end and doExp (e, st) = U.Exp.foldMap {kind = fn x => x, con = fn x => x, |