BatchG demo

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>