summaryrefslogtreecommitdiff
path: root/demo
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-03-10 16:38:38 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-03-10 16:38:38 -0400
commit3a94a798557f71cba0fdfdb54cdf431c44a4ef1d (patch)
treec0dff25071f38e045374e6d001ef7356af04e5db /demo
parent74f41e27e7940eec0320f7358f030185e8c2c2e0 (diff)
BatchG demo
Diffstat (limited to 'demo')
-rw-r--r--demo/batchFun.ur162
-rw-r--r--demo/batchFun.urs27
-rw-r--r--demo/batchG.ur8
-rw-r--r--demo/batchG.urp5
-rw-r--r--demo/batchG.urs1
-rw-r--r--demo/prose17
6 files changed, 220 insertions, 0 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
diff --git a/demo/prose b/demo/prose
index dd764ae4..57722a81 100644
--- a/demo/prose
+++ b/demo/prose
@@ -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>