Mercurial > urweb

comparison demo/batchFun.ur @ 1093:8d3aa6c7cee0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make summary unification more conservative; infer implicit arguments after applications
author Adam Chlipala <adamc@hcoop.net>
date Sat, 26 Dec 2009 11:56:40 -0500
parents bb3fc575cfe7
children ad15700272f6
comparison
equal deleted inserted replaced
1092:6f4b05fc4361 1093:8d3aa6c7cee0
43 (fn r acc => return (Cons (r.T, acc))) 43 (fn r acc => return (Cons (r.T, acc)))
44 Nil 44 Nil
45 45
46 fun add r = 46 fun add r =
47 dml (insert t 47 dml (insert t
48 (foldR2 [fst] [colMeta] 48 (@foldR2 [fst] [colMeta]
49 [fn cols => $(map (fn t :: (Type * Type) => 49 [fn cols => $(map (fn t :: (Type * Type) =>
50 sql_exp [] [] [] t.1) cols)] 50 sql_exp [] [] [] t.1) cols)]
51 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}] 51 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
52 [[nm] ~ rest] input col acc => 52 [[nm] ~ rest] input col acc =>
53 acc ++ {nm = @sql_inject col.Inject input}) 53 acc ++ {nm = @sql_inject col.Inject input})
54 {} [M.cols] M.fl (r -- #Id) M.cols 54 {} M.fl (r -- #Id) M.cols
55 ++ {Id = (SQL {[r.Id]})})) 55 ++ {Id = (SQL {[r.Id]})}))
56 56
57 fun doBatch ls = 57 fun doBatch ls =
58 case ls of 58 case ls of
59 Nil => return () 59 Nil => return ()
60 | Cons (r, ls') => 60 | Cons (r, ls') =>
70 case ls of 70 case ls of
71 Nil => <xml/> 71 Nil => <xml/>
72 | Cons (r, ls) => <xml> 72 | Cons (r, ls) => <xml>
73 <tr> 73 <tr>
74 <td>{[r.Id]}</td> 74 <td>{[r.Id]}</td>
75 {foldRX2 [colMeta] [fst] [_] 75 {@foldRX2 [colMeta] [fst] [_]
76 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] 76 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
77 [[nm] ~ rest] m v => 77 [[nm] ~ rest] m v =>
78 <xml><td>{m.Show v}</td></xml>) 78 <xml><td>{m.Show v}</td></xml>)
79 [M.cols] M.fl M.cols (r -- #Id)} 79 M.fl M.cols (r -- #Id)}
80 {if withDel then 80 {if withDel then
81 <xml><td><button value="Delete" onclick={rpc (del r.Id)}/></td></xml> 81 <xml><td><button value="Delete" onclick={rpc (del r.Id)}/></td></xml>
82 else 82 else
83 <xml/>} 83 <xml/>}
84 </tr> 84 </tr>
86 </xml> 86 </xml>
87 in 87 in
88 <xml><dyn signal={ls <- signal lss; return <xml><table> 88 <xml><dyn signal={ls <- signal lss; return <xml><table>
89 <tr> 89 <tr>
90 <th>Id</th> 90 <th>Id</th>
91 {foldRX [colMeta] [_] 91 {@foldRX [colMeta] [_]
92 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] 92 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
93 [[nm] ~ rest] m => 93 [[nm] ~ rest] m =>
94 <xml><th>{[m.Nam]}</th></xml>) 94 <xml><th>{[m.Nam]}</th></xml>)
95 [M.cols] M.fl M.cols} 95 M.fl M.cols}
96 </tr> 96 </tr>
97 {show' ls} 97 {show' ls}
98 </table></xml>}/></xml> 98 </table></xml>}/></xml>
99 end 99 end
100 100
101 fun main () = 101 fun main () =
102 lss <- source Nil; 102 lss <- source Nil;
103 batched <- source Nil; 103 batched <- source Nil;
104 104
105 id <- source ""; 105 id <- source "";
106 inps <- foldR [colMeta] [fn r => transaction ($(map snd r))] 106 inps <- @foldR [colMeta] [fn r => transaction ($(map snd r))]
107 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m acc => 107 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m acc =>
108 s <- m.NewState; 108 s <- m.NewState;
109 r <- acc; 109 r <- acc;
110 return ({nm = s} ++ r)) 110 return ({nm = s} ++ r))
111 (return {}) 111 (return {})
112 [M.cols] M.fl M.cols; 112 M.fl M.cols;
113 113
114 let 114 let
115 fun add () = 115 fun add () =
116 id <- get id; 116 id <- get id;
117 vs <- foldR2 [colMeta] [snd] [fn r => transaction ($(map fst r))] 117 vs <- @foldR2 [colMeta] [snd] [fn r => transaction ($(map fst r))]
118 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] 118 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
119 [[nm] ~ rest] m s acc => 119 [[nm] ~ rest] m s acc =>
120 v <- m.ReadState s; 120 v <- m.ReadState s;
121 r <- acc; 121 r <- acc;
122 return ({nm = v} ++ r)) 122 return ({nm = v} ++ r))
123 (return {}) 123 (return {})
124 [M.cols] M.fl M.cols inps; 124 M.fl M.cols inps;
125 ls <- get batched; 125 ls <- get batched;
126 126
127 set batched (Cons ({Id = readError id} ++ vs, ls)) 127 set batched (Cons ({Id = readError id} ++ vs, ls))
128 128
129 fun exec () = 129 fun exec () =
142 142
143 <h2>Batch new rows to add</h2> 143 <h2>Batch new rows to add</h2>
144 144
145 <table> 145 <table>
146 <tr> <th>Id:</th> <td><ctextbox source={id}/></td> </tr> 146 <tr> <th>Id:</th> <td><ctextbox source={id}/></td> </tr>
147 {foldRX2 [colMeta] [snd] [_] 147 {@foldRX2 [colMeta] [snd] [_]
148 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] 148 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
149 [[nm] ~ rest] m s => 149 [[nm] ~ rest] m s =>
150 <xml><tr> <th>{[m.Nam]}:</th> <td>{m.Widget s}</td> </tr></xml>) 150 <xml><tr> <th>{[m.Nam]}:</th> <td>{m.Widget s}</td> </tr></xml>)
151 [M.cols] M.fl M.cols inps} 151 M.fl M.cols inps}
152 <tr> <th/> <td><button value="Batch it" onclick={add ()}/></td> </tr> 152 <tr> <th/> <td><button value="Batch it" onclick={add ()}/></td> </tr>
153 </table> 153 </table>
154 154
155 <h2>Already batched:</h2> 155 <h2>Already batched:</h2>
156 {show False batched} 156 {show False batched}