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}
|
adam@1302
|
9 con colsMeta = fn cols => $(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]
|
adam@1302
|
49 [fn cols => $(map (fn t => sql_exp [] [] [] t.1) cols)]
|
adam@1302
|
50 (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] input col acc =>
|
adamc@1093
|
51 acc ++ {nm = @sql_inject col.Inject input})
|
adamc@1093
|
52 {} M.fl (r -- #Id) M.cols
|
adamc@1093
|
53 ++ {Id = (SQL {[r.Id]})}))
|
adamc@650
|
54
|
adamc@650
|
55 fun doBatch ls =
|
adamc@650
|
56 case ls of
|
adamc@650
|
57 Nil => return ()
|
adamc@650
|
58 | Cons (r, ls') =>
|
adamc@650
|
59 add r;
|
adamc@650
|
60 doBatch ls'
|
adamc@650
|
61
|
adamc@650
|
62 fun del id =
|
adamc@650
|
63 dml (DELETE FROM t WHERE t.Id = {[id]})
|
adamc@650
|
64
|
adamc@650
|
65 fun show withDel lss =
|
adamc@650
|
66 let
|
adamc@650
|
67 fun show' ls =
|
adamc@650
|
68 case ls of
|
adamc@650
|
69 Nil => <xml/>
|
adamc@650
|
70 | Cons (r, ls) => <xml>
|
adamc@650
|
71 <tr>
|
adamc@650
|
72 <td>{[r.Id]}</td>
|
adamc@1172
|
73 {@mapX2 [colMeta] [fst] [_]
|
adam@1302
|
74 (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m v =>
|
adamc@1093
|
75 <xml><td>{m.Show v}</td></xml>)
|
adamc@1093
|
76 M.fl M.cols (r -- #Id)}
|
adamc@650
|
77 {if withDel then
|
adamc@908
|
78 <xml><td><button value="Delete" onclick={rpc (del r.Id)}/></td></xml>
|
adamc@650
|
79 else
|
adamc@650
|
80 <xml/>}
|
adamc@650
|
81 </tr>
|
adamc@650
|
82 {show' ls}
|
adamc@650
|
83 </xml>
|
adamc@650
|
84 in
|
adamc@650
|
85 <xml><dyn signal={ls <- signal lss; return <xml><table>
|
adamc@650
|
86 <tr>
|
adamc@650
|
87 <th>Id</th>
|
adam@1342
|
88 {@mapX [colMeta] [[Body, Tr]]
|
adam@1302
|
89 (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m =>
|
adamc@1093
|
90 <xml><th>{[m.Nam]}</th></xml>)
|
adamc@1093
|
91 M.fl M.cols}
|
adamc@650
|
92 </tr>
|
adamc@650
|
93 {show' ls}
|
adamc@650
|
94 </table></xml>}/></xml>
|
adamc@650
|
95 end
|
adamc@650
|
96
|
adamc@650
|
97 fun main () =
|
adamc@650
|
98 lss <- source Nil;
|
adamc@650
|
99 batched <- source Nil;
|
adamc@650
|
100
|
adamc@650
|
101 id <- source "";
|
adamc@1093
|
102 inps <- @foldR [colMeta] [fn r => transaction ($(map snd r))]
|
adam@1302
|
103 (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m acc =>
|
adamc@1093
|
104 s <- m.NewState;
|
adamc@1093
|
105 r <- acc;
|
adamc@1093
|
106 return ({nm = s} ++ r))
|
adamc@1093
|
107 (return {})
|
adamc@1093
|
108 M.fl M.cols;
|
adamc@1093
|
109
|
adamc@650
|
110 let
|
adamc@650
|
111 fun add () =
|
adamc@650
|
112 id <- get id;
|
adamc@1093
|
113 vs <- @foldR2 [colMeta] [snd] [fn r => transaction ($(map fst r))]
|
adam@1302
|
114 (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m s acc =>
|
adamc@1093
|
115 v <- m.ReadState s;
|
adamc@1093
|
116 r <- acc;
|
adamc@1093
|
117 return ({nm = v} ++ r))
|
adamc@1093
|
118 (return {})
|
adamc@1093
|
119 M.fl M.cols inps;
|
adamc@650
|
120 ls <- get batched;
|
adamc@650
|
121
|
adamc@650
|
122 set batched (Cons ({Id = readError id} ++ vs, ls))
|
adamc@650
|
123
|
adamc@650
|
124 fun exec () =
|
adamc@650
|
125 ls <- get batched;
|
adamc@650
|
126
|
adamc@908
|
127 rpc (doBatch ls);
|
adamc@650
|
128 set batched Nil
|
adamc@650
|
129 in
|
adamc@650
|
130 return <xml><body>
|
adamc@650
|
131 <h2>Rows</h2>
|
adamc@650
|
132
|
adamc@650
|
133 {show True lss}
|
adamc@650
|
134
|
adamc@908
|
135 <button value="Update" onclick={ls <- rpc (allRows ()); set lss ls}/><br/>
|
adamc@650
|
136 <br/>
|
adamc@650
|
137
|
adamc@650
|
138 <h2>Batch new rows to add</h2>
|
adamc@650
|
139
|
adamc@650
|
140 <table>
|
adamc@650
|
141 <tr> <th>Id:</th> <td><ctextbox source={id}/></td> </tr>
|
adamc@1172
|
142 {@mapX2 [colMeta] [snd] [_]
|
adam@1302
|
143 (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m s =>
|
adamc@1093
|
144 <xml><tr> <th>{[m.Nam]}:</th> <td>{m.Widget s}</td> </tr></xml>)
|
adamc@1093
|
145 M.fl M.cols inps}
|
adamc@650
|
146 <tr> <th/> <td><button value="Batch it" onclick={add ()}/></td> </tr>
|
adamc@650
|
147 </table>
|
adamc@650
|
148
|
adamc@650
|
149 <h2>Already batched:</h2>
|
adamc@650
|
150 {show False batched}
|
adamc@650
|
151 <button value="Execute" onclick={exec ()}/>
|
adamc@650
|
152 </body></xml>
|
adamc@650
|
153 end
|
adamc@650
|
154
|
adamc@650
|
155 end
|