Mercurial > urweb
changeset 908:ed06e25c70ef
Convert to requiring explicit 'rpc' marker
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 22 Aug 2009 12:55:18 -0400 |
| parents | 5fe49effbc83 |
| children | 1d3f60e74ec7 |
| files | demo/batch.ur demo/batchFun.ur demo/chat.ur demo/increment.ur demo/noisy.ur demo/roundTrip.ur lib/ur/basis.urs lib/ur/list.ur lib/ur/list.urs src/core.sml src/core_print.sml src/core_util.sml src/effectize.sml src/monoize.sml src/reduce.sml src/reduce_local.sml src/rpcify.sml src/shake.sml |
| diffstat | 18 files changed, 204 insertions(+), 408 deletions(-) [+] |
line wrap: on
line diff
--- a/demo/batch.ur Tue Aug 11 12:01:54 2009 -0400 +++ b/demo/batch.ur Sat Aug 22 12:55:18 2009 -0400 @@ -25,7 +25,8 @@ 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> + <xml><td><button value="Delete" onclick={rpc (del id)}/> + </td></xml> else <xml/>} </tr> {show' ls} @@ -55,7 +56,7 @@ fun exec () = ls <- get batched; - doBatch ls; + rpc (doBatch ls); set batched Nil in return <xml><body> @@ -63,7 +64,7 @@ {show True lss} - <button value="Update" onclick={ls <- allRows (); set lss ls}/><br/> + <button value="Update" onclick={ls <- rpc (allRows ()); set lss ls}/><br/> <br/> <h2>Batch new rows to add</h2>
--- a/demo/batchFun.ur Tue Aug 11 12:01:54 2009 -0400 +++ b/demo/batchFun.ur Sat Aug 22 12:55:18 2009 -0400 @@ -78,7 +78,7 @@ <xml><td>{m.Show v}</td></xml>) [M.cols] M.fl M.cols (r -- #Id)} {if withDel then - <xml><td><button value="Delete" onclick={del r.Id}/></td></xml> + <xml><td><button value="Delete" onclick={rpc (del r.Id)}/></td></xml> else <xml/>} </tr> @@ -129,7 +129,7 @@ fun exec () = ls <- get batched; - doBatch ls; + rpc (doBatch ls); set batched Nil in return <xml><body> @@ -137,7 +137,7 @@ {show True lss} - <button value="Update" onclick={ls <- allRows (); set lss ls}/><br/> + <button value="Update" onclick={ls <- rpc (allRows ()); set lss ls}/><br/> <br/> <h2>Batch new rows to add</h2>
--- a/demo/chat.ur Tue Aug 11 12:01:54 2009 -0400 +++ b/demo/chat.ur Sat Aug 22 12:55:18 2009 -0400 @@ -35,7 +35,7 @@ fun doSpeak () = line <- get newLine; set newLine ""; - speak line + rpc (speak line) in return <xml><body onload={onload ()}> <h1>{[r.T.Title]}</h1>
--- a/demo/increment.ur Tue Aug 11 12:01:54 2009 -0400 +++ b/demo/increment.ur Sat Aug 22 12:55:18 2009 -0400 @@ -6,5 +6,5 @@ src <- source 0; return <xml><body> <dyn signal={n <- signal src; return <xml>{[n]}</xml>}/> - <button value="Update" onclick={n <- increment (); set src n}/> + <button value="Update" onclick={n <- rpc (increment ()); set src n}/> </body></xml>
--- a/demo/noisy.ur Tue Aug 11 12:01:54 2009 -0400 +++ b/demo/noisy.ur Sat Aug 22 12:55:18 2009 -0400 @@ -19,7 +19,7 @@ case ls of Nil => return () | Cons (id, ls') => - ao <- lookup id; + ao <- rpc (lookup id); alert (case ao of None => "Nada" | Some a => a); @@ -34,10 +34,10 @@ return <xml><body> <button value="Check values of 1, 2, and 3" onclick={check (Cons (1, Cons (2, Cons (3, Nil))))}/><br/> <br/> - <button value="Add" onclick={id <- get idAdd; a <- get aAdd; add (readError id) a}/> + <button value="Add" onclick={id <- get idAdd; a <- get aAdd; rpc (add (readError id) a)}/> <ctextbox source={idAdd}/> <ctextbox source={aAdd}/><br/> <br/> - <button value="Delete" onclick={id <- get idDel; del (readError id)}/> + <button value="Delete" onclick={id <- get idDel; rpc (del (readError id))}/> <ctextbox source={idDel}/> </body></xml>
--- a/demo/roundTrip.ur Tue Aug 11 12:01:54 2009 -0400 +++ b/demo/roundTrip.ur Sat Aug 22 12:55:18 2009 -0400 @@ -21,7 +21,7 @@ fun sender s n f = sleep 2000; - writeBack (s, n, f); + rpc (writeBack (s, n, f)); sender (s ^ "!") (n + 1) (f + 1.23) in return <xml><body onload={spawn (receiver ()); sender "" 0 0.0}>
--- a/lib/ur/basis.urs Tue Aug 11 12:01:54 2009 -0400 +++ b/lib/ur/basis.urs Sat Aug 22 12:55:18 2009 -0400 @@ -125,6 +125,8 @@ val spawn : transaction unit -> transaction unit val sleep : int -> transaction unit +val rpc : t ::: Type -> transaction t -> transaction t + (** Channels *)
--- a/lib/ur/list.ur Tue Aug 11 12:01:54 2009 -0400 +++ b/lib/ur/list.ur Sat Aug 22 12:55:18 2009 -0400 @@ -217,6 +217,13 @@ app' end +fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] + [tables ~ exps] (q : sql_query tables exps) + (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> t) = + query q + (fn fs acc => return (f fs :: acc)) + [] + fun assoc [a] [b] (_ : eq a) (x : a) = let fun assoc' (ls : list (a * b)) =
--- a/lib/ur/list.urs Tue Aug 11 12:01:54 2009 -0400 +++ b/lib/ur/list.urs Sat Aug 22 12:55:18 2009 -0400 @@ -43,6 +43,11 @@ val app : m ::: (Type -> Type) -> monad m -> a ::: Type -> (a -> m unit) -> t a -> m unit +val mapQuery : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type + -> [tables ~ exps] => + sql_query tables exps + -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> t) + -> transaction (list t) (** Association lists *)
--- a/src/core.sml Tue Aug 11 12:01:54 2009 -0400 +++ b/src/core.sml Sat Aug 22 12:55:18 2009 -0400 @@ -115,7 +115,7 @@ | ELet of string * con * exp * exp - | EServerCall of int * exp list * exp * con + | EServerCall of int * exp list * exp * con * con withtype exp = exp' located
--- a/src/core_print.sml Tue Aug 11 12:01:54 2009 -0400 +++ b/src/core_print.sml Sat Aug 22 12:55:18 2009 -0400 @@ -437,14 +437,14 @@ newline, p_exp (E.pushERel env x t) e2] - | EServerCall (n, es, e, _) => box [string "Server(", - p_enamed env n, - string ",", - space, - p_list (p_exp env) es, - string ")[", - p_exp env e, - string "]"] + | EServerCall (n, es, e, _, _) => box [string "Server(", + p_enamed env n, + string ",", + space, + p_list (p_exp env) es, + string ")[", + p_exp env e, + string "]"] | EKAbs (x, e) => box [string x, space,
--- a/src/core_util.sml Tue Aug 11 12:01:54 2009 -0400 +++ b/src/core_util.sml Sat Aug 22 12:55:18 2009 -0400 @@ -532,7 +532,7 @@ | (ELet _, _) => LESS | (_, ELet _) => GREATER - | (EServerCall (n1, es1, e1, _), EServerCall (n2, es2, e2, _)) => + | (EServerCall (n1, es1, e1, _, _), EServerCall (n2, es2, e2, _, _)) => join (Int.compare (n1, n2), fn () => join (joinL compare (es1, es2), fn () => compare (e1, e2))) @@ -718,14 +718,16 @@ fn e2' => (ELet (x, t', e1', e2'), loc)))) - | EServerCall (n, es, e, t) => + | EServerCall (n, es, e, t1, t2) => S.bind2 (ListUtil.mapfold (mfe ctx) es, fn es' => S.bind2 (mfe ctx e, fn e' => - S.map2 (mfc ctx t, - fn t' => - (EServerCall (n, es', e', t'), loc)))) + S.bind2 (mfc ctx t1, + fn t1' => + S.map2 (mfc ctx t2, + fn t2' => + (EServerCall (n, es', e', t1', t2'), loc))))) | EKAbs (x, e) => S.map2 (mfe (bind (ctx, RelK x)) e,
--- a/src/effectize.sml Tue Aug 11 12:01:54 2009 -0400 +++ b/src/effectize.sml Sat Aug 22 12:55:18 2009 -0400 @@ -46,7 +46,7 @@ EFfi f => effectful f | EFfiApp (m, x, _) => effectful (m, x) | ENamed n => IM.inDomain (evs, n) - | EServerCall (n, _, _, _) => IM.inDomain (evs, n) + | EServerCall (n, _, _, _, _) => IM.inDomain (evs, n) | _ => false fun couldWriteOnload evs = U.Exp.exists {kind = fn _ => false, @@ -70,7 +70,7 @@ case e of EFfi ("Basis", "getCookie") => true | ENamed n => IM.inDomain (evs, n) - | EServerCall (n, _, _, _) => IM.inDomain (evs, n) + | EServerCall (n, _, _, _, _) => IM.inDomain (evs, n) | _ => false fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false,
--- a/src/monoize.sml Tue Aug 11 12:01:54 2009 -0400 +++ b/src/monoize.sml Sat Aug 22 12:55:18 2009 -0400 @@ -3137,7 +3137,7 @@ ((L'.ELet (x, t', e1, e2), loc), fm) end - | L.EServerCall (n, es, ek, t) => + | L.EServerCall (n, es, ek, t, (L.TRecord (L.CRecord (_, []), _), _)) => let val t = monoType env t val (_, ft, _, name) = Env.lookupENamed env n @@ -3192,6 +3192,9 @@ in (e, fm) end + | L.EServerCall _ => (E.errorAt loc "Full scope of server call continuation isn't known"; + Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; + (dummyExp, fm)) | L.EKAbs _ => poly () | L.EKApp _ => poly ()
--- a/src/reduce.sml Tue Aug 11 12:01:54 2009 -0400 +++ b/src/reduce.sml Sat Aug 22 12:55:18 2009 -0400 @@ -33,6 +33,14 @@ structure IM = IntBinaryMap +structure E = CoreEnv + +fun multiLiftExpInExp n e = + if n = 0 then + e + else + multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e) + datatype env_item = UnknownK | KnownK of kind @@ -254,6 +262,98 @@ | EFfi _ => all | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc) + | EApp ( + (EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), + _), _), + (EApp ( + (EApp ( + (ECApp ( + (ECApp ((EFfi ("Basis", "return"), _), _), _), + _), _), + _), _), v), _)), _), trans2) => exp env (EApp (trans2, v), loc) + + (*| 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 = map (fn (p, e) => + let + val e' = (EApp (e', e), loc) + val e' = (EApp (e', + multiLiftExpInExp (E.patBindsN p) + trans2), loc) + val e' = exp env e' + in + (p, e') + end) pes + in + (ECase (exp env ed, + pes, + {disc = con env disc, + result = (CApp ((CFfi ("Basis", "transaction"), loc), con env t2), loc)}), + loc) + end*) + + | EApp ( + (EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + (EServerCall (n, es, ke, dom, ran), _)), _), + trans2) => + let + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) + val e' = (ECApp (e', dom), 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", dom, t2, e'), loc) + val e' = (EServerCall (n, es, e', dom, t2), loc) + in + exp env e' + 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) + in + exp env e' + end + | EApp (e1, e2) => let val e1 = exp env e1 @@ -424,7 +524,8 @@ | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc) - | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, con env t), loc)) + | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e, + con env t1, con env t2), loc)) in {kind = kind, con = con, exp = exp} end
--- a/src/reduce_local.sml Tue Aug 11 12:01:54 2009 -0400 +++ b/src/reduce_local.sml Sat Aug 22 12:55:18 2009 -0400 @@ -139,7 +139,7 @@ | ELet (x, t, e1, e2) => (ELet (x, t, exp env e1, exp (Unknown :: env) e2), loc) - | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, t), loc) + | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e, t1, t2), loc) fun reduce file = let
--- a/src/rpcify.sml Tue Aug 11 12:01:54 2009 -0400 +++ b/src/rpcify.sml Sat Aug 22 12:55:18 2009 -0400 @@ -40,67 +40,22 @@ val compare = String.compare end) -fun multiLiftExpInExp n e = - if n = 0 then - e - else - multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e) - type state = { - cpsed : int IM.map, - cpsed_range : con IM.map, - cps_decls : (string * int * con * exp * string) list, - exported : IS.set, - export_decls : decl list, - - maxName : int + export_decls : decl list } fun frob file = let - fun sideish (basis, ssids) e = - U.Exp.exists {kind = fn _ => false, - con = fn _ => false, - exp = fn ENamed n => IS.member (ssids, n) - | EFfi x => basis x - | EFfiApp (m, x, _) => basis (m, x) - | _ => false} - (U.Exp.map {kind = fn x => x, - con = fn x => x, - exp = fn ERecord _ => ERecord [] - | x => x} e) - - fun whichIds basis = - let - fun decl ((d, _), ssids) = - let - val impure = sideish (basis, ssids) - in - case d of - DVal (_, n, _, e, _) => if impure e then - IS.add (ssids, n) - else - ssids - | DValRec xes => if List.exists (fn (_, _, _, e, _) => impure e) xes then - foldl (fn ((_, n, _, _, _), ssids) => IS.add (ssids, n)) - ssids xes - else - ssids - | _ => ssids - end - in - foldl decl IS.empty file - end - - val ssids = whichIds Settings.isServerOnly - val csids = whichIds Settings.isClientOnly - - fun sideish' (basis, ids) extra = - sideish (basis, IM.foldli (fn (id, _, ids) => IS.add (ids, id)) ids extra) - - val serverSide = sideish' (Settings.isServerOnly, ssids) - val clientSide = sideish' (Settings.isClientOnly, csids) + val rpcBaseIds = foldl (fn ((d, _), rpcIds) => + case d of + DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => IS.add (rpcIds, n) + | DVal (_, n, _, (ENamed n', _), _) => if IS.member (rpcIds, n') then + IS.add (rpcIds, n) + else + rpcIds + | _ => rpcIds) + IS.empty file val tfuncs = foldl (fn ((d, _), tfuncs) => @@ -134,312 +89,50 @@ fun exp (e, st) = 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, [])) - end + case e' of + ENamed n => SOME (n, args) + | EApp (e1, e2) => getApp (#1 e1, e2 :: args) + | _ => NONE - fun newRpc (trans1, trans2, st : state) = - let - val loc = #2 trans1 + fun newRpc (trans : exp, st : state) = + case getApp (#1 trans, []) of + NONE => (ErrorMsg.errorAt (#2 trans) + "RPC code doesn't use a named function or transaction"; + (#1 trans, st)) + | SOME (n, args) => + 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, _) => + let + val loc = #2 trans - 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 ReadWrite, n), loc) :: #export_decls st) - val (exported, export_decls) = - if IS.member (#exported st, n) then - (#exported st, #export_decls st) - else - (IS.add (#exported st, n), - (DExport (Rpc ReadWrite, n), loc) :: #export_decls st) + val st = {exported = exported, + export_decls = export_decls} - 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 - - fun newCps (t1, t2, trans1, trans2, st) = - let - val loc = #2 trans1 - - val (n, args) = getApp (trans1, []) - - fun makeCall n' = - let - val e = (ENamed n', loc) - val e = (EApp (e, trans2), loc) + val k = (ECApp ((EFfi ("Basis", "return"), loc), + (CFfi ("Basis", "transaction"), loc)), loc) + val k = (ECApp (k, ran), loc) + val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc) + val e' = EServerCall (n, args, k, ran, ran) in - #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args) + (e', st) 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 (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 - - fun dummyK loc = - 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) - in - (EAbs ("_", unit, unit, k), loc) - 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, false) => - (case #1 trans2 of - EAbs (x, dom, ran, trans2) => - let - val (trans2, st) = newRpc (trans2, dummyK loc, st) - val trans2 = (EAbs (x, dom, ran, (trans2, loc)), 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, t2), loc) - val e = (EApp (e, (EFfi ("Basis", "transaction_monad"), loc)), loc) - val e = (EApp (e, trans1), loc) - val e = EApp (e, trans2) - in - (e, st) - end - | _ => (e, st)) - | (true, true, _, _) => newCps (t1, t2, trans1, trans2, st) - - | _ => (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 (xes, st) = ListUtil.foldlMap - (fn (y as (nm as (CName x, _), e, t), st) => - if candidate (x, e) then - let - val (e, st) = newRpc (e, dummyK loc, st) - in - ((nm, (e, loc), t), st) - end - else - (y, st) - | y => y) - st xes - in - (ERecord xes, st) - end - else - (e, st) - end + EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st) + | EApp ((ECApp ((ENamed n, _), ran), _), trans) => + if IS.member (rpcBaseIds, n) then + newRpc (trans, st) + else + (e, st) | _ => (e, st) end @@ -456,32 +149,14 @@ decl = fn x => x} st d in - (List.revAppend (case #cps_decls st of - [] => [d] - | ds => - case d of - (DValRec vis, loc) => [(DValRec (ds @ vis), loc)] - | (_, loc) => [d, (DValRec ds, loc)], - #export_decls st), - {cpsed = #cpsed st, - cpsed_range = #cpsed_range st, - cps_decls = [], - - exported = #exported st, - export_decls = [], - - maxName = #maxName st}) + (#export_decls st @ [d], + {exported = #exported st, + export_decls = []}) end val (file, _) = ListUtil.foldlMapConcat decl - {cpsed = IM.empty, - cpsed_range = IM.empty, - cps_decls = [], - - exported = IS.empty, - export_decls = [], - - maxName = U.File.maxName file + 1} + {exported = IS.empty, + export_decls = []} file in file