Ur/Web: demo/batch.ur annotate

annotate demo/batch.ur @ 1176:51e596feec37

Tone down Reduce and compensate with a new push-lambda-inside-case rule in MonoOpt; expand more Basis synonyms in Monoize

author	Adam Chlipala <adamc@hcoop.net>
date	Tue, 02 Mar 2010 16:00:48 -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

Mercurial > urweb

annotate demo/batch.ur @ 1176:51e596feec37