Mercurial > urweb
comparison demo/more/grid.ur @ 937:37dd42935dad
Summary row with aggregates
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Tue, 15 Sep 2009 10:18:56 -0400 |
parents | 6966d98c80b5 |
children | e2be476673f2 |
comparison
equal
deleted
inserted
replaced
936:6966d98c80b5 | 937:37dd42935dad |
---|---|
30 | 30 |
31 val folder : folder cols | 31 val folder : folder cols |
32 | 32 |
33 con aggregates :: {Type} | 33 con aggregates :: {Type} |
34 val aggregates : $(map (aggregateMeta row) aggregates) | 34 val aggregates : $(map (aggregateMeta row) aggregates) |
35 val aggFolder : folder aggregates | |
35 end) = struct | 36 end) = struct |
36 style tabl | 37 style tabl |
37 style tr | 38 style tr |
38 style th | 39 style th |
39 style td | 40 style td |
41 style agg | |
40 | 42 |
41 fun make (row : M.row) [t] (m : colMeta' M.row t) : transaction t = m.Project row | 43 fun make (row : M.row) [t] (m : colMeta' M.row t) : transaction t = m.Project row |
42 | 44 |
43 fun makeAll cols row = @@Monad.exec [transaction] _ [map snd M.cols] | 45 fun makeAll cols row = @@Monad.exec [transaction] _ [map snd M.cols] |
44 (map2 [fst] [colMeta M.row] [fn p :: (Type * Type) => transaction p.2] | 46 (map2 [fst] [colMeta M.row] [fn p :: (Type * Type) => transaction p.2] |
75 fun render grid = <xml> | 77 fun render grid = <xml> |
76 <table class={tabl}> | 78 <table class={tabl}> |
77 <tr class={tr}> | 79 <tr class={tr}> |
78 <th/> <th/> | 80 <th/> <th/> |
79 {foldRX2 [fst] [colMeta M.row] [_] | 81 {foldRX2 [fst] [colMeta M.row] [_] |
80 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] | 82 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] |
81 data (meta : colMeta M.row p) => | 83 data (meta : colMeta M.row p) => |
82 <xml><th class={th}>{[(meta.Handlers data).Header]}</th></xml>) | 84 <xml><th class={th}>{[(meta.Handlers data).Header]}</th></xml>) |
83 [_] M.folder grid.Cols M.cols} | 85 [_] M.folder grid.Cols M.cols} |
84 </tr> | 86 </tr> |
85 | 87 |
86 {Dlist.render (fn {Row = rowS, Cols = colsS, Updating = ud} pos => | 88 {Dlist.render (fn {Row = rowS, Cols = colsS, Updating = ud} pos => |
87 let | 89 let |
88 val delete = | 90 val delete = |
89 Dlist.delete pos; | 91 Dlist.delete pos; |
90 row <- get rowS; | 92 row <- get rowS; |
91 rpc (M.delete (M.keyOf row)) | 93 rpc (M.delete (M.keyOf row)) |
92 | 94 |
93 val update = set ud True | 95 val update = set ud True |
94 | 96 |
95 val cancel = | 97 val cancel = |
96 set ud False; | 98 set ud False; |
97 row <- get rowS; | 99 row <- get rowS; |
98 cols <- makeAll grid.Cols row; | 100 cols <- makeAll grid.Cols row; |
99 set colsS cols | 101 set colsS cols |
100 | 102 |
101 val save = | 103 val save = |
102 cols <- get colsS; | 104 cols <- get colsS; |
103 errors <- Monad.foldR3 [fst] [colMeta M.row] [snd] [fn _ => option string] | 105 errors <- Monad.foldR3 [fst] [colMeta M.row] [snd] [fn _ => option string] |
104 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] | 106 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] |
105 [[nm] ~ rest] data meta v errors => | 107 [[nm] ~ rest] data meta v errors => |
106 b <- current ((meta.Handlers data).Validate v); | 108 b <- current ((meta.Handlers data).Validate v); |
107 return (if b then | 109 return (if b then |
108 errors | 110 errors |
109 else | 111 else |
110 case errors of | 112 case errors of |
111 None => Some ((meta.Handlers data).Header) | 113 None => Some ((meta.Handlers data).Header) |
112 | Some s => Some ((meta.Handlers data).Header | 114 | Some s => Some ((meta.Handlers data).Header |
113 ^ ", " ^ s))) | 115 ^ ", " ^ s))) |
114 None [_] M.folder grid.Cols M.cols cols; | 116 None [_] M.folder grid.Cols M.cols cols; |
115 | 117 |
116 case errors of | 118 case errors of |
117 Some s => alert ("Can't save because the following columns have invalid values:\n" | 119 Some s => alert ("Can't save because the following columns have invalid values:\n" |
118 ^ s) | 120 ^ s) |
119 | None => | 121 | None => |
120 set ud False; | 122 set ud False; |
121 row <- get rowS; | 123 row <- get rowS; |
122 row' <- Monad.foldR3 [fst] [colMeta M.row] [snd] [fn _ => M.row] | 124 row' <- Monad.foldR3 [fst] [colMeta M.row] [snd] [fn _ => M.row] |
125 (fn [nm :: Name] [t :: (Type * Type)] | |
126 [rest :: {(Type * Type)}] | |
127 [[nm] ~ rest] data meta v row' => | |
128 (meta.Handlers data).Update row' v) | |
129 row [_] M.folder grid.Cols M.cols cols; | |
130 rpc (M.save (M.keyOf row) row'); | |
131 set rowS row'; | |
132 | |
133 cols <- makeAll grid.Cols row'; | |
134 set colsS cols | |
135 in | |
136 <xml><tr class={tr}> | |
137 <td> | |
138 <dyn signal={b <- signal ud; | |
139 return (if b then | |
140 <xml><button value="Save" onclick={save}/></xml> | |
141 else | |
142 <xml><button value="Update" onclick={update}/></xml>)}/> | |
143 </td> | |
144 | |
145 <td><dyn signal={b <- signal ud; | |
146 return (if b then | |
147 <xml><button value="Cancel" onclick={cancel}/></xml> | |
148 else | |
149 <xml><button value="Delete" onclick={delete}/></xml>)}/> | |
150 </td> | |
151 | |
152 <dyn signal={cols <- signal colsS; | |
153 return (foldRX3 [fst] [colMeta M.row] [snd] [_] | |
123 (fn [nm :: Name] [t :: (Type * Type)] | 154 (fn [nm :: Name] [t :: (Type * Type)] |
124 [rest :: {(Type * Type)}] | 155 [rest :: {(Type * Type)}] |
125 [[nm] ~ rest] data meta v row' => | 156 [[nm] ~ rest] data meta v => |
126 (meta.Handlers data).Update row' v) | 157 <xml><td class={td}> |
127 row [_] M.folder grid.Cols M.cols cols; | 158 <dyn signal={b <- signal ud; |
128 rpc (M.save (M.keyOf row) row'); | 159 return (if b then |
129 set rowS row'; | 160 (meta.Handlers data).Edit v |
130 | 161 else |
131 cols <- makeAll grid.Cols row'; | 162 (meta.Handlers data).Display |
132 set colsS cols | 163 v)}/> |
133 in | 164 <dyn signal={b <- signal ud; |
134 <xml><tr class={tr}> | 165 if b then |
135 <td> | 166 valid <- |
136 <dyn signal={b <- signal ud; | 167 (meta.Handlers data).Validate v; |
137 return (if b then | 168 return (if valid then |
138 <xml><button value="Save" onclick={save}/></xml> | 169 <xml/> |
139 else | 170 else |
140 <xml><button value="Update" onclick={update}/></xml>)}/> | 171 <xml>!</xml>) |
141 </td> | 172 else |
142 <td><dyn signal={b <- signal ud; | 173 return <xml/>}/> |
143 return (if b then | 174 </td></xml>) |
144 <xml><button value="Cancel" onclick={cancel}/></xml> | 175 [_] M.folder grid.Cols M.cols cols)}/> |
145 else | 176 </tr></xml> |
146 <xml><button value="Delete" onclick={delete}/></xml>)}/> | 177 end) grid.Rows} |
147 </td> | 178 |
148 | 179 <dyn signal={rows <- Dlist.foldl (fn row => Monad.mapR2 [aggregateMeta M.row] [id] [id] |
149 <dyn signal={cols <- signal colsS; | 180 (fn [nm :: Name] [t :: Type] meta acc => |
150 return (foldRX3 [fst] [colMeta M.row] [snd] [_] | 181 Monad.mp (fn v => meta.Step v acc) |
151 (fn [nm :: Name] [t :: (Type * Type)] | 182 (signal row.Row)) |
152 [rest :: {(Type * Type)}] | 183 [_] M.aggFolder M.aggregates) |
153 [[nm] ~ rest] data meta v => | 184 (mp [aggregateMeta M.row] [id] |
154 <xml><td class={td}> | 185 (fn [t] meta => meta.Initial) |
155 <dyn signal={b <- signal ud; | 186 [_] M.aggFolder M.aggregates) grid.Rows; |
156 return (if b then | 187 return <xml><tr> |
157 (meta.Handlers data).Edit v | 188 <td/><td/> |
158 else | 189 {foldRX2 [aggregateMeta M.row] [id] [_] |
159 (meta.Handlers data).Display | 190 (fn [nm :: Name] [t :: Type] [rest :: {Type}] [[nm] ~ rest] meta acc => |
160 v)}/> | 191 <xml><td class={agg}>{meta.Display acc}</td></xml>) |
161 <dyn signal={b <- signal ud; | 192 [_] M.aggFolder M.aggregates rows} |
162 if b then | 193 </tr></xml>}/> |
163 valid <- | |
164 (meta.Handlers data).Validate v; | |
165 return (if valid then | |
166 <xml/> | |
167 else | |
168 <xml>!</xml>) | |
169 else | |
170 return <xml/>}/> | |
171 </td></xml>) | |
172 [_] M.folder grid.Cols M.cols cols)}/> | |
173 </tr></xml> | |
174 end) grid.Rows} | |
175 </table> | 194 </table> |
176 | 195 |
177 <button value="New row" onclick={row <- rpc M.new; | 196 <button value="New row" onclick={row <- rpc M.new; |
178 addRow grid.Cols grid.Rows row}/> | 197 addRow grid.Cols grid.Rows row}/> |
179 <button value="Refresh" onclick={sync grid}/> | 198 <button value="Refresh" onclick={sync grid}/> |