diff options
author | 2009-03-10 16:38:38 -0400 | |
---|---|---|
committer | 2009-03-10 16:38:38 -0400 | |
commit | 4bc363c5ec2724b9d310e17181ca87517c98aa68 (patch) | |
tree | c0dff25071f38e045374e6d001ef7356af04e5db | |
parent | b8e7b835e7cde4cf374138467da8b16e93a65eb9 (diff) |
BatchG demo
-rw-r--r-- | demo/batchFun.ur | 162 | ||||
-rw-r--r-- | demo/batchFun.urs | 27 | ||||
-rw-r--r-- | demo/batchG.ur | 8 | ||||
-rw-r--r-- | demo/batchG.urp | 5 | ||||
-rw-r--r-- | demo/batchG.urs | 1 | ||||
-rw-r--r-- | demo/prose | 17 | ||||
-rw-r--r-- | lib/ur/top.ur | 2 | ||||
-rw-r--r-- | lib/ur/top.urs | 2 | ||||
-rw-r--r-- | src/rpcify.sml | 21 |
9 files changed, 236 insertions, 9 deletions
diff --git a/demo/batchFun.ur b/demo/batchFun.ur new file mode 100644 index 00000000..2eed464b --- /dev/null +++ b/demo/batchFun.ur @@ -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 diff --git a/demo/batchFun.urs b/demo/batchFun.urs new file mode 100644 index 00000000..695576c5 --- /dev/null +++ b/demo/batchFun.urs @@ -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 diff --git a/demo/batchG.ur b/demo/batchG.ur new file mode 100644 index 00000000..e370b26e --- /dev/null +++ b/demo/batchG.ur @@ -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) diff --git a/demo/batchG.urp b/demo/batchG.urp new file mode 100644 index 00000000..ba4ce189 --- /dev/null +++ b/demo/batchG.urp @@ -0,0 +1,5 @@ +database dbname=test +sql batchG.sql + +batchFun +batchG diff --git a/demo/batchG.urs b/demo/batchG.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/batchG.urs @@ -0,0 +1 @@ +val main : unit -> transaction page @@ -213,3 +213,20 @@ increment.urp 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> diff --git a/lib/ur/top.ur b/lib/ur/top.ur index f4adaba7..2ae424ab 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -7,7 +7,7 @@ con folder = K ==> fn r :: {K} => -> 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 diff --git a/lib/ur/top.urs b/lib/ur/top.urs index bb85abd0..009a4ed5 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -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)) diff --git a/src/rpcify.sml b/src/rpcify.sml index 7e731f63..13d42390 100644 --- a/src/rpcify.sml +++ b/src/rpcify.sml @@ -71,13 +71,16 @@ type state = { 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 @@ fun frob file = 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 |