Mercurial > urweb

annotate demo/batchFun.ur @ 1244:1eedc9086e6c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Use key information in more places, and catch cases where one key completion depends on another having happened already
author Adam Chlipala <adamc@hcoop.net>
date Sun, 18 Apr 2010 13:00:36 -0400
parents ad15700272f6
children d008c4c43a0a
rev   line source
adamc@1002 1 con colMeta = fn (db :: Type, state :: Type) =>
adamc@650 2 {Nam : string,
adamc@1002 3 Show : db -> xbody,
adamc@1002 4 Inject : sql_injectable db,
adamc@650 5
adamc@1002 6 NewState : transaction state,
adamc@1002 7 Widget : state -> xbody,
adamc@1002 8 ReadState : state -> transaction db}
adamc@650 9 con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols)
adamc@650 10
adamc@823 11 fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t)
adamc@650 12 name : colMeta (t, source string) =
adamc@650 13 {Nam = name,
adamc@650 14 Show = txt,
adamc@650 15 Inject = _,
adamc@650 16
adamc@650 17 NewState = source "",
adamc@650 18 Widget = fn s => <xml><ctextbox source={s}/></xml>,
adamc@650 19 ReadState = fn s => v <- get s; return (readError v)}
adamc@650 20
adamc@650 21 val int = default
adamc@650 22 val float = default
adamc@650 23 val string = default
adamc@650 24
adamc@650 25 functor Make(M : sig
adamc@650 26 con cols :: {(Type * Type)}
adamc@650 27 constraint [Id] ~ cols
adamc@650 28 val fl : folder cols
adamc@650 29
adamc@706 30 table tab : ([Id = int] ++ map fst cols)
adamc@650 31
adamc@650 32 val title : string
adamc@650 33
adamc@650 34 val cols : colsMeta cols
adamc@650 35 end) = struct
adamc@650 36
adamc@650 37 val t = M.tab
adamc@650 38
adamc@650 39 datatype list t = Nil | Cons of t * list t
adamc@650 40
adamc@650 41 fun allRows () =
adamc@650 42 query (SELECT * FROM t)
adamc@650 43 (fn r acc => return (Cons (r.T, acc)))
adamc@650 44 Nil
adamc@650 45
adamc@650 46 fun add r =
adamc@650 47 dml (insert t
adamc@1093 48 (@foldR2 [fst] [colMeta]
adamc@1093 49 [fn cols => $(map (fn t :: (Type * Type) =>
adamc@1093 50 sql_exp [] [] [] t.1) cols)]
adamc@1093 51 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@1093 52 [[nm] ~ rest] input col acc =>
adamc@1093 53 acc ++ {nm = @sql_inject col.Inject input})
adamc@1093 54 {} M.fl (r -- #Id) M.cols
adamc@1093 55 ++ {Id = (SQL {[r.Id]})}))
adamc@650 56
adamc@650 57 fun doBatch ls =
adamc@650 58 case ls of
adamc@650 59 Nil => return ()
adamc@650 60 | Cons (r, ls') =>
adamc@650 61 add r;
adamc@650 62 doBatch ls'
adamc@650 63
adamc@650 64 fun del id =
adamc@650 65 dml (DELETE FROM t WHERE t.Id = {[id]})
adamc@650 66
adamc@650 67 fun show withDel lss =
adamc@650 68 let
adamc@650 69 fun show' ls =
adamc@650 70 case ls of
adamc@650 71 Nil => <xml/>
adamc@650 72 | Cons (r, ls) => <xml>
adamc@650 73 <tr>
adamc@650 74 <td>{[r.Id]}</td>
adamc@1172 75 {@mapX2 [colMeta] [fst] [_]
adamc@1093 76 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@1093 77 [[nm] ~ rest] m v =>
adamc@1093 78 <xml><td>{m.Show v}</td></xml>)
adamc@1093 79 M.fl M.cols (r -- #Id)}
adamc@650 80 {if withDel then
adamc@908 81 <xml><td><button value="Delete" onclick={rpc (del r.Id)}/></td></xml>
adamc@650 82 else
adamc@650 83 <xml/>}
adamc@650 84 </tr>
adamc@650 85 {show' ls}
adamc@650 86 </xml>
adamc@650 87 in
adamc@650 88 <xml><dyn signal={ls <- signal lss; return <xml><table>
adamc@650 89 <tr>
adamc@650 90 <th>Id</th>
adamc@1172 91 {@mapX [colMeta] [_]
adamc@1093 92 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@1093 93 [[nm] ~ rest] m =>
adamc@1093 94 <xml><th>{[m.Nam]}</th></xml>)
adamc@1093 95 M.fl M.cols}
adamc@650 96 </tr>
adamc@650 97 {show' ls}
adamc@650 98 </table></xml>}/></xml>
adamc@650 99 end
adamc@650 100
adamc@650 101 fun main () =
adamc@650 102 lss <- source Nil;
adamc@650 103 batched <- source Nil;
adamc@650 104
adamc@650 105 id <- source "";
adamc@1093 106 inps <- @foldR [colMeta] [fn r => transaction ($(map snd r))]
adamc@1093 107 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m acc =>
adamc@1093 108 s <- m.NewState;
adamc@1093 109 r <- acc;
adamc@1093 110 return ({nm = s} ++ r))
adamc@1093 111 (return {})
adamc@1093 112 M.fl M.cols;
adamc@1093 113
adamc@650 114 let
adamc@650 115 fun add () =
adamc@650 116 id <- get id;
adamc@1093 117 vs <- @foldR2 [colMeta] [snd] [fn r => transaction ($(map fst r))]
adamc@1093 118 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@1093 119 [[nm] ~ rest] m s acc =>
adamc@1093 120 v <- m.ReadState s;
adamc@1093 121 r <- acc;
adamc@1093 122 return ({nm = v} ++ r))
adamc@1093 123 (return {})
adamc@1093 124 M.fl M.cols inps;
adamc@650 125 ls <- get batched;
adamc@650 126
adamc@650 127 set batched (Cons ({Id = readError id} ++ vs, ls))
adamc@650 128
adamc@650 129 fun exec () =
adamc@650 130 ls <- get batched;
adamc@650 131
adamc@908 132 rpc (doBatch ls);
adamc@650 133 set batched Nil
adamc@650 134 in
adamc@650 135 return <xml><body>
adamc@650 136 <h2>Rows</h2>
adamc@650 137
adamc@650 138 {show True lss}
adamc@650 139
adamc@908 140 <button value="Update" onclick={ls <- rpc (allRows ()); set lss ls}/><br/>
adamc@650 141 <br/>
adamc@650 142
adamc@650 143 <h2>Batch new rows to add</h2>
adamc@650 144
adamc@650 145 <table>
adamc@650 146 <tr> <th>Id:</th> <td><ctextbox source={id}/></td> </tr>
adamc@1172 147 {@mapX2 [colMeta] [snd] [_]
adamc@1093 148 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@1093 149 [[nm] ~ rest] m s =>
adamc@1093 150 <xml><tr> <th>{[m.Nam]}:</th> <td>{m.Widget s}</td> </tr></xml>)
adamc@1093 151 M.fl M.cols inps}
adamc@650 152 <tr> <th/> <td><button value="Batch it" onclick={add ()}/></td> </tr>
adamc@650 153 </table>
adamc@650 154
adamc@650 155 <h2>Already batched:</h2>
adamc@650 156 {show False batched}
adamc@650 157 <button value="Execute" onclick={exec ()}/>
adamc@650 158 </body></xml>
adamc@650 159 end
adamc@650 160
adamc@650 161 end