Mercurial > urweb

comparison demo/batchFun.ur @ 650:fcf0bd3d1667

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