Mercurial > urweb
changeset 650:fcf0bd3d1667
BatchG demo
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 10 Mar 2009 16:38:38 -0400 |
| parents | 96ebc6bdb5a0 |
| children | bab524996fca |
| files | demo/batchFun.ur demo/batchFun.urs demo/batchG.ur demo/batchG.urp demo/batchG.urs demo/prose lib/ur/top.ur lib/ur/top.urs src/rpcify.sml |
| diffstat | 9 files changed, 236 insertions(+), 9 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/batchFun.ur Tue Mar 10 16:38:38 2009 -0400 @@ -0,0 +1,162 @@ +con colMeta = fn t_state :: (Type * Type) => + {Nam : string, + Show : t_state.1 -> xbody, + Inject : sql_injectable t_state.1, + + NewState : transaction t_state.2, + Widget : t_state.2 -> xbody, + ReadState : t_state.2 -> transaction t_state.1} +con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols) + +fun default (t ::: Type) (sh : show t) (rd : read t) (inj : sql_injectable t) + name : colMeta (t, source string) = + {Nam = name, + Show = txt, + Inject = _, + + NewState = source "", + Widget = fn s => <xml><ctextbox source={s}/></xml>, + ReadState = fn s => v <- get s; return (readError v)} + +val int = default +val float = default +val string = default + +functor Make(M : sig + con cols :: {(Type * Type)} + constraint [Id] ~ cols + val fl : folder cols + + val tab : sql_table ([Id = int] ++ map fst cols) + + val title : string + + val cols : colsMeta cols + end) = struct + + open constraints M + val t = M.tab + + datatype list t = Nil | Cons of t * list t + + fun allRows () = + query (SELECT * FROM t) + (fn r acc => return (Cons (r.T, acc))) + Nil + + fun add r = + dml (insert t + (foldR2 [fst] [colMeta] + [fn cols => $(map (fn t :: (Type * Type) => + sql_exp [] [] [] t.1) cols)] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] input col acc => + acc ++ {nm = @sql_inject col.Inject input}) + {} [M.cols] M.fl (r -- #Id) M.cols + ++ {Id = (SQL {[r.Id]})})) + + fun doBatch ls = + case ls of + Nil => return () + | Cons (r, ls') => + add r; + 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 (r, ls) => <xml> + <tr> + <td>{[r.Id]}</td> + {foldRX2 [colMeta] [fst] [_] + (fn (nm :: Name) (p :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] m v => + <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> + else + <xml/>} + </tr> + {show' ls} + </xml> + in + <xml><dyn signal={ls <- signal lss; return <xml><table> + <tr> + <th>Id</th> + {foldRX [colMeta] [_] + (fn (nm :: Name) (p :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] m => + <xml><th>{[m.Nam]}</th></xml>) + [M.cols] M.fl M.cols} + </tr> + {show' ls} + </table></xml>}/></xml> + end + + fun main () = + lss <- source Nil; + batched <- source Nil; + + id <- source ""; + inps <- foldR [colMeta] [fn r => transaction ($(map snd r))] + (fn (nm :: Name) (p :: (Type * Type)) (rest :: {(Type * Type)}) [[nm] ~ rest] m acc => + s <- m.NewState; + r <- acc; + return ({nm = s} ++ r)) + (return {}) + [M.cols] M.fl M.cols; + + let + fun add () = + id <- get id; + vs <- foldR2 [colMeta] [snd] [fn r => transaction ($(map fst r))] + (fn (nm :: Name) (p :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] m s acc => + v <- m.ReadState s; + r <- acc; + return ({nm = v} ++ r)) + (return {}) + [M.cols] M.fl M.cols inps; + ls <- get batched; + + set batched (Cons ({Id = readError id} ++ vs, 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> + {foldRX2 [colMeta] [snd] [_] + (fn (nm :: Name) (p :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] m s => + <xml><tr> <th>{[m.Nam]}:</th> <td>{m.Widget s}</td> </tr></xml>) + [M.cols] M.fl M.cols inps} + <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 + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/batchFun.urs Tue Mar 10 16:38:38 2009 -0400 @@ -0,0 +1,27 @@ +con colMeta = fn t_state :: (Type * Type) => + {Nam : string, + Show : t_state.1 -> xbody, + Inject : sql_injectable t_state.1, + + NewState : transaction t_state.2, + Widget : t_state.2 -> xbody, + ReadState : t_state.2 -> transaction t_state.1} +con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols) + +val int : string -> colMeta (int, source string) +val float : string -> colMeta (float, source string) +val string : string -> colMeta (string, source string) + +functor Make(M : sig + con cols :: {(Type * Type)} + constraint [Id] ~ cols + val fl : folder cols + + val tab : sql_table ([Id = int] ++ map fst cols) + + val title : string + + val cols : colsMeta cols + end) : sig + val main : unit -> transaction page +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/batchG.ur Tue Mar 10 16:38:38 2009 -0400 @@ -0,0 +1,8 @@ +table t : {Id : int, A : string, B : float} + +open BatchFun.Make(struct + val tab = t + val title = "BatchG" + val cols = {A = BatchFun.string "A", + B = BatchFun.float "B"} + end)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/batchG.urp Tue Mar 10 16:38:38 2009 -0400 @@ -0,0 +1,5 @@ +database dbname=test +sql batchG.sql + +batchFun +batchG
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/batchG.urs Tue Mar 10 16:38:38 2009 -0400 @@ -0,0 +1,1 @@ +val main : unit -> transaction page
--- a/demo/prose Tue Mar 10 15:17:23 2009 -0400 +++ b/demo/prose Tue Mar 10 16:38:38 2009 -0400 @@ -213,3 +213,20 @@ 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> + +batchG.urp + +<p>We can redo the last example with a generic component, like we did in the <tt>Crud</tt> examples. The module <tt>BatchFun</tt> is analogous to the <tt>Crud</tt> module. It contains a functor that builds a batching editor, when given a suitable description of a table.</p> + +<p>The signature of the functor is the same as for <tt>Crud</tt>. We change the definition of <tt>colMeta</tt> to reflect the different kinds of column metadata that we need. Each column is still described by a pair of types, and the first element of each pair still gives the SQL type for a column. Now, however, the second type in a pair gives a type of <i>local state</i> to be used in a reactive widget for inputing that column.</p> + +<p>The first three fields of a <tt>colMeta</tt> record are the same as for <tt>Crud</tt>. The rest of the fields are:</p> +<ol> + <li> <tt>NewState</tt>, which allocates some new widget local state</li> + <li> <tt>Widget</tt>, which produces a reactive widget from some state</li> + <li> <tt>ReadState</tt>, which reads the current value of some state to determine which SQL value it encodes</li> +</ol> + +<p><tt>BatchFun.Make</tt> handles the plumbing of allocating the local state, using it to create widgets, and reading the state values when the user clicks "Batch it."</p> + +<p><tt>batchG.ur</tt> contains an example instantiation, which is just as easy to write as in the <tt>Crud1</tt> example.</p>
--- a/lib/ur/top.ur Tue Mar 10 15:17:23 2009 -0400 +++ b/lib/ur/top.ur Tue Mar 10 16:38:38 2009 -0400 @@ -7,7 +7,7 @@ -> tf [] -> tf r structure Folder = struct - fun fold K (r ::: {K}) (fl : folder r) = fl + fun fold K (r :: {K}) (fl : folder r) = fl fun nil K (tf :: {K} -> Type) (f : nm :: Name -> v :: K -> r :: {K} -> tf r
--- a/lib/ur/top.urs Tue Mar 10 15:17:23 2009 -0400 +++ b/lib/ur/top.urs Tue Mar 10 16:38:38 2009 -0400 @@ -3,7 +3,7 @@ con folder :: K --> {K} -> Type structure Folder : sig - val fold : K --> r ::: {K} -> folder r + val fold : K --> r :: {K} -> folder r -> tf :: ({K} -> Type) -> (nm :: Name -> v :: K -> r :: {K} -> tf r -> [[nm] ~ r] => tf ([nm = v] ++ r))
--- a/src/rpcify.sml Tue Mar 10 15:17:23 2009 -0400 +++ b/src/rpcify.sml Tue Mar 10 16:38:38 2009 -0400 @@ -71,13 +71,16 @@ fun frob file = let - fun sideish (basis, ssids) = - U.Exp.exists {kind = fn _ => false, - con = fn _ => false, - exp = fn ENamed n => IS.member (ssids, n) - | EFfi ("Basis", x) => SS.member (basis, x) - | EFfiApp ("Basis", x, _) => SS.member (basis, x) - | _ => false} + fun sideish (basis, ssids) e = + case #1 e of + ERecord _ => false + | _ => + U.Exp.exists {kind = fn _ => false, + con = fn _ => false, + exp = fn ENamed n => IS.member (ssids, n) + | EFfi ("Basis", x) => SS.member (basis, x) + | EFfiApp ("Basis", x, _) => SS.member (basis, x) + | _ => false} e fun whichIds basis = let @@ -331,6 +334,10 @@ 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