adamc@1002: con colMeta = fn (db :: Type, state :: Type) =>
adamc@650:                  {Nam : string,
adamc@1002:                   Show : db -> xbody,
adamc@1002:                   Inject : sql_injectable db,
adamc@650: 
adamc@1002:                   NewState : transaction state,
adamc@1002:                   Widget : state -> xbody,
adamc@1002:                   ReadState : state -> transaction db}
adamc@650: con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols)
adamc@650: 
adamc@823: fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t)
adamc@650:             name : colMeta (t, source string) =
adamc@650:     {Nam = name,
adamc@650:      Show = txt,
adamc@650:      Inject = _,
adamc@650: 
adamc@650:      NewState = source "",
adamc@650:      Widget = fn s => <xml><ctextbox source={s}/></xml>,
adamc@650:      ReadState = fn s => v <- get s; return (readError v)}
adamc@650: 
adamc@650: val int = default
adamc@650: val float = default
adamc@650: val string = default
adamc@650: 
adamc@650: functor Make(M : sig
adamc@650:                  con cols :: {(Type * Type)}
adamc@650:                  constraint [Id] ~ cols
adamc@650:                  val fl : folder cols
adamc@650:                           
adamc@706:                  table tab : ([Id = int] ++ map fst cols)
adamc@650:                            
adamc@650:                  val title : string
adamc@650:                              
adamc@650:                  val cols : colsMeta cols
adamc@650:              end) = struct
adamc@650: 
adamc@650:     val t = M.tab
adamc@650: 
adamc@650:     datatype list t = Nil | Cons of t * list t
adamc@650: 
adamc@650:     fun allRows () =
adamc@650:         query (SELECT * FROM t)
adamc@650:               (fn r acc => return (Cons (r.T, acc)))
adamc@650:               Nil
adamc@650: 
adamc@650:     fun add r =
adamc@650:         dml (insert t
adamc@650:                     (foldR2 [fst] [colMeta]
adamc@650:                             [fn cols => $(map (fn t :: (Type * Type) =>
adamc@650:                                                   sql_exp [] [] [] t.1) cols)]
adamc@823:                             (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@650:                                              [[nm] ~ rest] input col acc =>
adamc@650:                                 acc ++ {nm = @sql_inject col.Inject input})
adamc@650:                             {} [M.cols] M.fl (r -- #Id) M.cols
adamc@650:                             ++ {Id = (SQL {[r.Id]})}))
adamc@650: 
adamc@650:     fun doBatch ls =
adamc@650:         case ls of
adamc@650:             Nil => return ()
adamc@650:           | Cons (r, ls') =>
adamc@650:             add r;
adamc@650:             doBatch ls'
adamc@650: 
adamc@650:     fun del id =
adamc@650:         dml (DELETE FROM t WHERE t.Id = {[id]})
adamc@650: 
adamc@650:     fun show withDel lss =
adamc@650:         let
adamc@650:             fun show' ls =
adamc@650:                 case ls of
adamc@650:                     Nil => <xml/>
adamc@650:                   | Cons (r, ls) => <xml>
adamc@650:                     <tr>
adamc@650:                       <td>{[r.Id]}</td>
adamc@650:                       {foldRX2 [colMeta] [fst] [_]
adamc@823:                                (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@650:                                                 [[nm] ~ rest] m v =>
adamc@650:                                    <xml><td>{m.Show v}</td></xml>)
adamc@650:                                [M.cols] M.fl M.cols (r -- #Id)}
adamc@650:                       {if withDel then
adamc@908:                            <xml><td><button value="Delete" onclick={rpc (del r.Id)}/></td></xml>
adamc@650:                        else
adamc@650:                            <xml/>}
adamc@650:                     </tr>
adamc@650:                     {show' ls}
adamc@650:                   </xml>
adamc@650:         in
adamc@650:             <xml><dyn signal={ls <- signal lss; return <xml><table>
adamc@650:               <tr>
adamc@650:                 <th>Id</th>
adamc@650:                 {foldRX [colMeta] [_]
adamc@823:                         (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@650:                                          [[nm] ~ rest] m =>
adamc@650:                             <xml><th>{[m.Nam]}</th></xml>)
adamc@650:                         [M.cols] M.fl M.cols}
adamc@650:               </tr>
adamc@650:               {show' ls}
adamc@650:             </table></xml>}/></xml>
adamc@650:         end
adamc@650: 
adamc@650:     fun main () =
adamc@650:         lss <- source Nil;
adamc@650:         batched <- source Nil;
adamc@650: 
adamc@650:         id <- source "";
adamc@650:         inps <- foldR [colMeta] [fn r => transaction ($(map snd r))]
adamc@823:                 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m acc =>
adamc@650:                     s <- m.NewState;
adamc@650:                     r <- acc;
adamc@650:                     return ({nm = s} ++ r))
adamc@650:                 (return {})
adamc@650:                 [M.cols] M.fl M.cols;
adamc@650: 
adamc@650:         let
adamc@650:             fun add () =
adamc@650:                 id <- get id;
adamc@650:                 vs <- foldR2 [colMeta] [snd] [fn r => transaction ($(map fst r))]
adamc@823:                              (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@650:                                               [[nm] ~ rest] m s acc =>
adamc@650:                                  v <- m.ReadState s;
adamc@650:                                  r <- acc;
adamc@650:                                  return ({nm = v} ++ r))
adamc@650:                              (return {})
adamc@650:                              [M.cols] M.fl M.cols inps;
adamc@650:                 ls <- get batched;
adamc@650: 
adamc@650:                 set batched (Cons ({Id = readError id} ++ vs, ls))
adamc@650: 
adamc@650:             fun exec () =
adamc@650:                 ls <- get batched;
adamc@650: 
adamc@908:                 rpc (doBatch ls);
adamc@650:                 set batched Nil
adamc@650:         in
adamc@650:             return <xml><body>
adamc@650:               <h2>Rows</h2>
adamc@650: 
adamc@650:               {show True lss}
adamc@650: 
adamc@908:               <button value="Update" onclick={ls <- rpc (allRows ()); set lss ls}/><br/>
adamc@650:               <br/>
adamc@650: 
adamc@650:               <h2>Batch new rows to add</h2>
adamc@650: 
adamc@650:               <table>
adamc@650:                 <tr> <th>Id:</th> <td><ctextbox source={id}/></td> </tr>
adamc@650:                 {foldRX2 [colMeta] [snd] [_]
adamc@823:                  (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@650:                                   [[nm] ~ rest] m s =>
adamc@650:                      <xml><tr> <th>{[m.Nam]}:</th> <td>{m.Widget s}</td> </tr></xml>)
adamc@650:                  [M.cols] M.fl M.cols inps}
adamc@650:                 <tr> <th/> <td><button value="Batch it" onclick={add ()}/></td> </tr>
adamc@650:               </table>
adamc@650: 
adamc@650:               <h2>Already batched:</h2>
adamc@650:               {show False batched}
adamc@650:               <button value="Execute" onclick={exec ()}/>
adamc@650:             </body></xml>
adamc@650:         end
adamc@650: 
adamc@650: end