summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--demo/noisy.ur42
-rw-r--r--demo/noisy.urp4
-rw-r--r--demo/noisy.urs1
-rw-r--r--demo/prose4
-rw-r--r--src/jscomp.sml13
-rw-r--r--src/mono_opt.sml2
-rw-r--r--src/monoize.sml7
-rw-r--r--src/rpcify.sml239
8 files changed, 188 insertions, 124 deletions
diff --git a/demo/noisy.ur b/demo/noisy.ur
new file mode 100644
index 00000000..118af737
--- /dev/null
+++ b/demo/noisy.ur
@@ -0,0 +1,42 @@
+datatype list t = Nil | Cons of t * list t
+
+table t : { Id : int, A : string }
+
+fun add id s =
+ dml (INSERT INTO t (Id, A) VALUES ({[id]}, {[s]}))
+
+fun del id =
+ dml (DELETE FROM t WHERE t.Id = {[id]})
+
+fun lookup id =
+ ro <- oneOrNoRows (SELECT t.A FROM t WHERE t.Id = {[id]});
+ case ro of
+ None => return None
+ | Some r => return (Some r.T.A)
+
+fun check ls =
+ case ls of
+ Nil => return ()
+ | Cons (id, ls') =>
+ ao <- lookup id;
+ alert (case ao of
+ None => "Nada"
+ | Some a => a);
+ check ls'
+
+fun main () =
+ idAdd <- source "";
+ aAdd <- source "";
+
+ idDel <- source "";
+
+ 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}/>
+ <ctextbox source={idAdd}/>
+ <ctextbox source={aAdd}/><br/>
+ <br/>
+ <button value="Delete" onclick={id <- get idDel; del (readError id)}/>
+ <ctextbox source={idDel}/>
+ </body></xml>
diff --git a/demo/noisy.urp b/demo/noisy.urp
new file mode 100644
index 00000000..ea08bf74
--- /dev/null
+++ b/demo/noisy.urp
@@ -0,0 +1,4 @@
+database dbname=test
+sql noisy.sql
+
+noisy
diff --git a/demo/noisy.urs b/demo/noisy.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/demo/noisy.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
diff --git a/demo/prose b/demo/prose
index 57722a81..11f8c2d9 100644
--- a/demo/prose
+++ b/demo/prose
@@ -210,6 +210,10 @@ 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>
+noisy.urp
+
+<p>This example shows how easy it is to make the flow of control "ping pong" back and forth between the client and the server. Clicking a button triggers three queries to the server, with an alert generated after each query.</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/src/jscomp.sml b/src/jscomp.sml
index adff2fda..00048458 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -895,15 +895,6 @@ fun process file =
| EDml _ => unsupported "DML"
| ENextval _ => unsupported "Nextval"
| EUnurlify _ => unsupported "EUnurlify"
- (*| EJavaScript (_, e as (EAbs _, _), _) =>
- let
- val (e, st) = jsE inner (e, st)
- in
- (strcat [str "\"cr(\"+ca(",
- e,
- str ")+\")\""],
- st)
- end*)
| EJavaScript (_, e, _) =>
let
val (e, st) = jsE inner (e, st)
@@ -982,9 +973,7 @@ fun process file =
end
in
case e of
- EJavaScript (m, orig as (EAbs (_, t, _, e), _), NONE) =>
- doCode m 1 (t :: env) orig e
- | EJavaScript (m, orig, NONE) =>
+ EJavaScript (m, orig, NONE) =>
doCode m 0 env orig orig
| _ => (e, st)
end,
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 469fc0d8..7f23d8b1 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -365,8 +365,6 @@ 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/monoize.sml b/src/monoize.sml
index 131bdf67..01f18baf 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1820,6 +1820,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| (L'.TFun _, _) =>
let
val s' = " " ^ lowercaseFirst x ^ "='"
+ val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
in
((L'.EStrcat (s,
(L'.EStrcat (
@@ -2264,8 +2265,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.ERel 0, loc)), loc),
(L'.ERecord [], loc)), loc)), loc)), loc)
val ek = (L'.EApp (ekf, ek), loc)
+ val e = (L'.EServerCall (call, ek, t), loc)
+ val e = liftExpInExp 0 e
+ val unit = (L'.TRecord [], loc)
+ val e = (L'.EAbs ("_", unit, unit, e), loc)
in
- ((L'.EServerCall (call, ek, t), loc), fm)
+ (e, fm)
end
| L.EKAbs _ => poly ()
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 13d42390..f4db3444 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -188,6 +188,116 @@ fun frob file =
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)
+ 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 (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 (
@@ -287,104 +397,26 @@ fun frob file =
(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, [])
+ | (_, 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)
- 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 (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 () = Print.prefaces "Double true"
- [("trans1", CorePrint.p_exp CoreEnv.empty trans1),
- ("e", CorePrint.p_exp CoreEnv.empty e)]
-
- 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))
| ERecord xes =>
@@ -401,22 +433,11 @@ fun frob file =
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)
+ val (e, st) = newRpc (e, dummyK loc, st)
in
((nm, (e, loc), t), st)
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-18 01:08:21 +0000