Mercurial > urweb
changeset 651:bab524996fca
Noisy demo
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 10 Mar 2009 17:29:03 -0400 |
| parents | fcf0bd3d1667 |
| children | 9db6880184d0 |
| files | demo/noisy.ur demo/noisy.urp demo/noisy.urs demo/prose src/jscomp.sml src/mono_opt.sml src/monoize.sml src/rpcify.sml |
| diffstat | 8 files changed, 187 insertions(+), 123 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/noisy.ur Tue Mar 10 17:29:03 2009 -0400 @@ -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>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/noisy.urp Tue Mar 10 17:29:03 2009 -0400 @@ -0,0 +1,4 @@ +database dbname=test +sql noisy.sql + +noisy
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/noisy.urs Tue Mar 10 17:29:03 2009 -0400 @@ -0,0 +1,1 @@ +val main : unit -> transaction page
--- a/demo/prose Tue Mar 10 16:38:38 2009 -0400 +++ b/demo/prose Tue Mar 10 17:29:03 2009 -0400 @@ -210,6 +210,10 @@ <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>
--- a/src/jscomp.sml Tue Mar 10 16:38:38 2009 -0400 +++ b/src/jscomp.sml Tue Mar 10 17:29:03 2009 -0400 @@ -895,15 +895,6 @@ | 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 @@ 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,
--- a/src/mono_opt.sml Tue Mar 10 16:38:38 2009 -0400 +++ b/src/mono_opt.sml Tue Mar 10 17:29:03 2009 -0400 @@ -365,8 +365,6 @@ | EJavaScript (_, _, SOME (e, _)) => e - | EApp ((e1 as EServerCall _, _), (ERecord [], _)) => e1 - | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
--- a/src/monoize.sml Tue Mar 10 16:38:38 2009 -0400 +++ b/src/monoize.sml Tue Mar 10 17:29:03 2009 -0400 @@ -1820,6 +1820,7 @@ | (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 @@ (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 ()
--- a/src/rpcify.sml Tue Mar 10 16:38:38 2009 -0400 +++ b/src/rpcify.sml Tue Mar 10 17:29:03 2009 -0400 @@ -188,6 +188,116 @@ 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 @@ (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) - 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 = (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) - 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 @@ 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