summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--demo/batch.ur7
-rw-r--r--demo/batchFun.ur6
-rw-r--r--demo/chat.ur2
-rw-r--r--demo/increment.ur2
-rw-r--r--demo/noisy.ur6
-rw-r--r--demo/roundTrip.ur2
-rw-r--r--lib/ur/basis.urs2
-rw-r--r--lib/ur/list.ur7
-rw-r--r--lib/ur/list.urs5
-rw-r--r--src/core.sml2
-rw-r--r--src/core_print.sml16
-rw-r--r--src/core_util.sml12
-rw-r--r--src/effectize.sml4
-rw-r--r--src/monoize.sml5
-rw-r--r--src/reduce.sml103
-rw-r--r--src/reduce_local.sml2
-rw-r--r--src/rpcify.sml433
-rw-r--r--src/shake.sml2
18 files changed, 207 insertions, 411 deletions
diff --git a/demo/batch.ur b/demo/batch.ur
index 4100749f..8213dd81 100644
--- a/demo/batch.ur
+++ b/demo/batch.ur
@@ -25,7 +25,8 @@ fun show withDel lss =
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 main () =
fun exec () =
ls <- get batched;
- doBatch ls;
+ rpc (doBatch ls);
set batched Nil
in
return <xml><body>
@@ -63,7 +64,7 @@ fun main () =
{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>
diff --git a/demo/batchFun.ur b/demo/batchFun.ur
index 560c0c55..d88f11ca 100644
--- a/demo/batchFun.ur
+++ b/demo/batchFun.ur
@@ -78,7 +78,7 @@ functor Make(M : sig
<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 @@ functor Make(M : sig
fun exec () =
ls <- get batched;
- doBatch ls;
+ rpc (doBatch ls);
set batched Nil
in
return <xml><body>
@@ -137,7 +137,7 @@ functor Make(M : sig
{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>
diff --git a/demo/chat.ur b/demo/chat.ur
index 52c344be..9f18e9ef 100644
--- a/demo/chat.ur
+++ b/demo/chat.ur
@@ -35,7 +35,7 @@ fun chat id () =
fun doSpeak () =
line <- get newLine;
set newLine "";
- speak line
+ rpc (speak line)
in
return <xml><body onload={onload ()}>
<h1>{[r.T.Title]}</h1>
diff --git a/demo/increment.ur b/demo/increment.ur
index a74e80df..532ceb83 100644
--- a/demo/increment.ur
+++ b/demo/increment.ur
@@ -6,5 +6,5 @@ fun main () =
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>
diff --git a/demo/noisy.ur b/demo/noisy.ur
index 708cfa2c..068e2ec1 100644
--- a/demo/noisy.ur
+++ b/demo/noisy.ur
@@ -19,7 +19,7 @@ fun check ls =
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 @@ fun main () =
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>
diff --git a/demo/roundTrip.ur b/demo/roundTrip.ur
index c3a111b7..aa7017a0 100644
--- a/demo/roundTrip.ur
+++ b/demo/roundTrip.ur
@@ -21,7 +21,7 @@ fun action () =
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}>
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 7f06a47a..9f5a9b97 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -125,6 +125,8 @@ val alert : string -> transaction unit
val spawn : transaction unit -> transaction unit
val sleep : int -> transaction unit
+val rpc : t ::: Type -> transaction t -> transaction t
+
(** Channels *)
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index d774cc54..3d4134ea 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -217,6 +217,13 @@ fun app [m] (_ : monad m) [a] f =
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)) =
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index 1b0fced9..ece85e8c 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -43,6 +43,11 @@ val all : a ::: Type -> (a -> bool) -> t a -> bool
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 *)
diff --git a/src/core.sml b/src/core.sml
index e7466746..2b2d5ca5 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -115,7 +115,7 @@ datatype exp' =
| 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
diff --git a/src/core_print.sml b/src/core_print.sml
index 08739aea..5daf7137 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -437,14 +437,14 @@ fun p_exp' par env (e, _) =
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,
diff --git a/src/core_util.sml b/src/core_util.sml
index db1eab1a..197f688a 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -532,7 +532,7 @@ fun compare ((e1, _), (e2, _)) =
| (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 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
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,
diff --git a/src/effectize.sml b/src/effectize.sml
index c07f74bc..d458561d 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -46,7 +46,7 @@ fun effectize file =
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 @@ fun effectize file =
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,
diff --git a/src/monoize.sml b/src/monoize.sml
index 4d48a7ff..a5772976 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3137,7 +3137,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 ()
diff --git a/src/reduce.sml b/src/reduce.sml
index a6c0b38a..88d3f2d9 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -33,6 +33,14 @@ open Core
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 @@ fun kindConAndExp (namedC, namedE) =
| 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 @@ fun kindConAndExp (namedC, namedE) =
| 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
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index 6c25ebf3..9ea5a16d 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -139,7 +139,7 @@ fun exp env (all as (e, loc)) =
| 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
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 1ed4cd54..75f80940 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -40,67 +40,22 @@ structure SS = BinarySetFn(struct
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 frob file =
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
-
- 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 ReadWrite, 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
-
- fun newCps (t1, t2, trans1, trans2, st) =
- let
- val loc = #2 trans1
-
- val (n, args) = getApp (trans1, [])
-
- fun makeCall n' =
+ case e' of
+ ENamed n => SOME (n, args)
+ | EApp (e1, e2) => getApp (#1 e1, e2 :: args)
+ | _ => NONE
+
+ 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 e = (ENamed n', loc)
- val e = (EApp (e, trans2), loc)
+ val loc = #2 trans
+
+ 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 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 @@ fun frob file =
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
diff --git a/src/shake.sml b/src/shake.sml
index 4a40d336..e27e9839 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -137,7 +137,7 @@ fun shake file =
in
case e of
ENamed n => check n
- | EServerCall (n, _, _, _) => check n
+ | EServerCall (n, _, _, _, _) => check n
| _ => s
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-12 07:13:52 +0000