annotate demo/batch.ur @ 1107:52571ca9b777
Eta-expand bodies of transaction functions in Monoization, to enable later optimization
| author |
Adam Chlipala <adamc@hcoop.net> |
| date |
Thu, 31 Dec 2009 18:07:53 -0500 |
| parents |
ed06e25c70ef |
| children |
e6bc6bbd7a32 |
| rev |
line source |
|
adamc@649
|
1 datatype list t = Nil | Cons of t * list t
|
|
adamc@649
|
2
|
|
adamc@649
|
3 table t : {Id : int, A : string}
|
|
adamc@708
|
4 PRIMARY KEY Id
|
|
adamc@649
|
5
|
|
adamc@649
|
6 fun allRows () =
|
|
adamc@649
|
7 query (SELECT * FROM t)
|
|
adamc@649
|
8 (fn r acc => return (Cons ((r.T.Id, r.T.A), acc)))
|
|
adamc@649
|
9 Nil
|
|
adamc@649
|
10
|
|
adamc@649
|
11 fun doBatch ls =
|
|
adamc@649
|
12 case ls of
|
|
adamc@649
|
13 Nil => return ()
|
|
adamc@649
|
14 | Cons ((id, a), ls') =>
|
|
adamc@649
|
15 dml (INSERT INTO t (Id, A) VALUES ({[id]}, {[a]}));
|
|
adamc@649
|
16 doBatch ls'
|
|
adamc@649
|
17
|
|
adamc@649
|
18 fun del id =
|
|
adamc@649
|
19 dml (DELETE FROM t WHERE t.Id = {[id]})
|
|
adamc@649
|
20
|
|
adamc@649
|
21 fun show withDel lss =
|
|
adamc@649
|
22 let
|
|
adamc@649
|
23 fun show' ls =
|
|
adamc@649
|
24 case ls of
|
|
adamc@649
|
25 Nil => <xml/>
|
|
adamc@649
|
26 | Cons ((id, a), ls) => <xml>
|
|
adamc@649
|
27 <tr><td>{[id]}</td> <td>{[a]}</td> {if withDel then
|
|
adamc@908
|
28 <xml><td><button value="Delete" onclick={rpc (del id)}/>
|
|
adamc@908
|
29 </td></xml>
|
|
adamc@649
|
30 else
|
|
adamc@649
|
31 <xml/>} </tr>
|
|
adamc@649
|
32 {show' ls}
|
|
adamc@649
|
33 </xml>
|
|
adamc@649
|
34 in
|
|
adamc@649
|
35 <xml><dyn signal={ls <- signal lss; return <xml><table>
|
|
adamc@649
|
36 <tr> <th>Id</th> <th>A</th> </tr>
|
|
adamc@649
|
37 {show' ls}
|
|
adamc@649
|
38 </table></xml>}/></xml>
|
|
adamc@649
|
39 end
|
|
adamc@649
|
40
|
|
adamc@782
|
41 fun main () =
|
|
adamc@649
|
42 lss <- source Nil;
|
|
adamc@649
|
43 batched <- source Nil;
|
|
adamc@649
|
44
|
|
adamc@649
|
45 id <- source "";
|
|
adamc@649
|
46 a <- source "";
|
|
adamc@649
|
47
|
|
adamc@649
|
48 let
|
|
adamc@649
|
49 fun add () =
|
|
adamc@649
|
50 id <- get id;
|
|
adamc@649
|
51 a <- get a;
|
|
adamc@649
|
52 ls <- get batched;
|
|
adamc@649
|
53
|
|
adamc@649
|
54 set batched (Cons ((readError id, a), ls))
|
|
adamc@649
|
55
|
|
adamc@649
|
56 fun exec () =
|
|
adamc@649
|
57 ls <- get batched;
|
|
adamc@649
|
58
|
|
adamc@908
|
59 rpc (doBatch ls);
|
|
adamc@649
|
60 set batched Nil
|
|
adamc@649
|
61 in
|
|
adamc@649
|
62 return <xml><body>
|
|
adamc@649
|
63 <h2>Rows</h2>
|
|
adamc@649
|
64
|
|
adamc@649
|
65 {show True lss}
|
|
adamc@649
|
66
|
|
adamc@908
|
67 <button value="Update" onclick={ls <- rpc (allRows ()); set lss ls}/><br/>
|
|
adamc@649
|
68 <br/>
|
|
adamc@649
|
69
|
|
adamc@649
|
70 <h2>Batch new rows to add</h2>
|
|
adamc@649
|
71
|
|
adamc@649
|
72 <table>
|
|
adamc@649
|
73 <tr> <th>Id:</th> <td><ctextbox source={id}/></td> </tr>
|
|
adamc@649
|
74 <tr> <th>A:</th> <td><ctextbox source={a}/></td> </tr>
|
|
adamc@649
|
75 <tr> <th/> <td><button value="Batch it" onclick={add ()}/></td> </tr>
|
|
adamc@649
|
76 </table>
|
|
adamc@649
|
77
|
|
adamc@649
|
78 <h2>Already batched:</h2>
|
|
adamc@649
|
79 {show False batched}
|
|
adamc@649
|
80 <button value="Execute" onclick={exec ()}/>
|
|
adamc@649
|
81 </body></xml>
|
|
adamc@649
|
82 end
|
