Mercurial > urweb

annotate demo/more/grid.ur @ 964:fbc3a0eef45a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Paging mostly working; just need to get it working properly with filtering
author Adam Chlipala <adamc@hcoop.net>
date Sat, 19 Sep 2009 14:21:25 -0400
parents 6f9d1565de56
children e9c5992bc9bc
rev   line source
adamc@944 1 con colMeta' = fn (row :: Type) (input :: Type) (filter :: Type) =>
adamc@915 2 {Header : string,
adamc@944 3 Project : row -> transaction input,
adamc@944 4 Update : row -> input -> transaction row,
adamc@944 5 Display : input -> xbody,
adamc@944 6 Edit : input -> xbody,
adamc@944 7 Validate : input -> signal bool,
adamc@944 8 CreateFilter : transaction filter,
adamc@944 9 DisplayFilter : filter -> xbody,
adamc@961 10 Filter : filter -> row -> signal bool,
adamc@961 11 Sort : option (row -> row -> bool)}
adamc@944 12
adamc@944 13 con colMeta = fn (row :: Type) (global_input_filter :: (Type * Type * Type)) =>
adamc@944 14 {Initialize : transaction global_input_filter.1,
adamc@944 15 Handlers : global_input_filter.1 -> colMeta' row global_input_filter.2 global_input_filter.3}
adamc@915 16
adamc@935 17 con aggregateMeta = fn (row :: Type) (acc :: Type) =>
adamc@935 18 {Initial : acc,
adamc@935 19 Step : row -> acc -> acc,
adamc@935 20 Display : acc -> xbody}
adamc@935 21
adamc@915 22 functor Make(M : sig
adamc@915 23 type row
adamc@936 24 type key
adamc@936 25 val keyOf : row -> key
adamc@936 26
adamc@915 27 val list : transaction (list row)
adamc@915 28 val new : transaction row
adamc@936 29 val save : key -> row -> transaction unit
adamc@936 30 val delete : key -> transaction unit
adamc@915 31
adamc@944 32 con cols :: {(Type * Type * Type)}
adamc@915 33 val cols : $(map (colMeta row) cols)
adamc@915 34
adamc@915 35 val folder : folder cols
adamc@935 36
adamc@935 37 con aggregates :: {Type}
adamc@935 38 val aggregates : $(map (aggregateMeta row) aggregates)
adamc@937 39 val aggFolder : folder aggregates
adamc@964 40
adamc@964 41 val pageLength : option int
adamc@915 42 end) = struct
adamc@915 43 style tabl
adamc@915 44 style tr
adamc@915 45 style th
adamc@915 46 style td
adamc@937 47 style agg
adamc@915 48
adamc@944 49 fun make (row : M.row) [input] [filter] (m : colMeta' M.row input filter) : transaction input = m.Project row
adamc@915 50
adamc@944 51 fun makeAll cols row = @@Monad.exec [transaction] _ [map snd3 M.cols]
adamc@944 52 (map2 [fst3] [colMeta M.row] [fn p => transaction (snd3 p)]
adamc@944 53 (fn [p] data meta => make row [_] [_] (meta.Handlers data))
adamc@915 54 [_] M.folder cols M.cols)
adamc@915 55 (@@Folder.mp [_] [_] M.folder)
adamc@915 56
adamc@944 57 type grid = {Cols : $(map fst3 M.cols),
adamc@940 58 Rows : Dlist.dlist {Row : source M.row,
adamc@944 59 Cols : source ($(map snd3 M.cols)),
adamc@940 60 Updating : source bool,
adamc@940 61 Selected : source bool},
adamc@944 62 Selection : source bool,
adamc@960 63 Filters : $(map thd3 M.cols),
adamc@964 64 Sort : source (option (M.row -> M.row -> bool)),
adamc@964 65 Position : source int}
adamc@940 66
adamc@954 67 fun newRow cols row =
adamc@915 68 rowS <- source row;
adamc@915 69 cols <- makeAll cols row;
adamc@915 70 colsS <- source cols;
adamc@915 71 ud <- source False;
adamc@940 72 sd <- source False;
adamc@954 73 return {Row = rowS,
adamc@954 74 Cols = colsS,
adamc@954 75 Updating = ud,
adamc@954 76 Selected = sd}
adamc@954 77
adamc@954 78 fun addRow cols rows row =
adamc@954 79 r <- newRow cols row;
adamc@954 80 Monad.ignore (Dlist.append rows r)
adamc@915 81
adamc@944 82 val grid =
adamc@944 83 cols <- Monad.mapR [colMeta M.row] [fst3]
adamc@944 84 (fn [nm :: Name] [p :: (Type * Type * Type)] meta => meta.Initialize)
adamc@944 85 [_] M.folder M.cols;
adamc@915 86
adamc@944 87 filters <- Monad.mapR2 [colMeta M.row] [fst3] [thd3]
adamc@944 88 (fn [nm :: Name] [p :: (Type * Type * Type)] meta state =>
adamc@944 89 (meta.Handlers state).CreateFilter)
adamc@944 90 [_] M.folder M.cols cols;
adamc@944 91
adamc@951 92 rows <- Dlist.create;
adamc@940 93 sel <- source False;
adamc@960 94 sort <- source None;
adamc@964 95 pos <- source 0;
adamc@951 96
adamc@951 97 return {Cols = cols,
adamc@951 98 Rows = rows,
adamc@951 99 Selection = sel,
adamc@960 100 Filters = filters,
adamc@964 101 Sort = sort,
adamc@964 102 Position = pos}
adamc@915 103
adamc@940 104 fun sync {Cols = cols, Rows = rows, ...} =
adamc@915 105 Dlist.clear rows;
adamc@915 106 init <- rpc M.list;
adamc@954 107 rs <- List.mapM (newRow cols) init;
adamc@954 108 Dlist.replace rows rs
adamc@915 109
adamc@961 110 fun render (grid : grid) = <xml>
adamc@915 111 <table class={tabl}>
adamc@915 112 <tr class={tr}>
adamc@961 113 <th/> <th/> <th><button value="No sort" onclick={set grid.Sort None}/></th>
adamc@944 114 {foldRX2 [fst3] [colMeta M.row] [_]
adamc@944 115 (fn [nm :: Name] [p :: (Type * Type * Type)] [rest :: {(Type * Type * Type)}] [[nm] ~ rest]
adamc@937 116 data (meta : colMeta M.row p) =>
adamc@961 117 <xml><th class={th}>
adamc@961 118 {case (meta.Handlers data).Sort of
adamc@961 119 None => txt (meta.Handlers data).Header
adamc@961 120 | sort => <xml><button value={(meta.Handlers data).Header}
adamc@961 121 onclick={set grid.Sort sort}/></xml>}
adamc@961 122 </th></xml>)
adamc@937 123 [_] M.folder grid.Cols M.cols}
adamc@937 124 </tr>
adamc@915 125
adamc@940 126 {Dlist.render (fn {Row = rowS, Cols = colsS, Updating = ud, Selected = sd} pos =>
adamc@937 127 let
adamc@937 128 val delete =
adamc@937 129 Dlist.delete pos;
adamc@937 130 row <- get rowS;
adamc@937 131 rpc (M.delete (M.keyOf row))
adamc@915 132
adamc@937 133 val update = set ud True
adamc@915 134
adamc@937 135 val cancel =
adamc@937 136 set ud False;
adamc@937 137 row <- get rowS;
adamc@937 138 cols <- makeAll grid.Cols row;
adamc@937 139 set colsS cols
adamc@937 140
adamc@937 141 val save =
adamc@937 142 cols <- get colsS;
adamc@944 143 errors <- Monad.foldR3 [fst3] [colMeta M.row] [snd3] [fn _ => option string]
adamc@944 144 (fn [nm :: Name] [p :: (Type * Type * Type)] [rest :: {(Type * Type * Type)}]
adamc@937 145 [[nm] ~ rest] data meta v errors =>
adamc@937 146 b <- current ((meta.Handlers data).Validate v);
adamc@937 147 return (if b then
adamc@937 148 errors
adamc@937 149 else
adamc@937 150 case errors of
adamc@937 151 None => Some ((meta.Handlers data).Header)
adamc@937 152 | Some s => Some ((meta.Handlers data).Header
adamc@937 153 ^ ", " ^ s)))
adamc@937 154 None [_] M.folder grid.Cols M.cols cols;
adamc@915 155
adamc@937 156 case errors of
adamc@937 157 Some s => alert ("Can't save because the following columns have invalid values:\n"
adamc@937 158 ^ s)
adamc@937 159 | None =>
adamc@937 160 set ud False;
adamc@937 161 row <- get rowS;
adamc@944 162 row' <- Monad.foldR3 [fst3] [colMeta M.row] [snd3] [fn _ => M.row]
adamc@944 163 (fn [nm :: Name] [t :: (Type * Type * Type)]
adamc@944 164 [rest :: {(Type * Type * Type)}]
adamc@937 165 [[nm] ~ rest] data meta v row' =>
adamc@937 166 (meta.Handlers data).Update row' v)
adamc@937 167 row [_] M.folder grid.Cols M.cols cols;
adamc@937 168 rpc (M.save (M.keyOf row) row');
adamc@937 169 set rowS row';
adamc@937 170
adamc@937 171 cols <- makeAll grid.Cols row';
adamc@937 172 set colsS cols
adamc@937 173 in
adamc@937 174 <xml><tr class={tr}>
adamc@937 175 <td>
adamc@940 176 <dyn signal={b <- signal grid.Selection;
adamc@941 177 return (if b then
adamc@940 178 <xml><ccheckbox source={sd}/></xml>
adamc@940 179 else
adamc@941 180 <xml/>)}/>
adamc@940 181 </td>
adamc@940 182
adamc@940 183 <td>
adamc@937 184 <dyn signal={b <- signal ud;
adamc@937 185 return (if b then
adamc@937 186 <xml><button value="Save" onclick={save}/></xml>
adamc@937 187 else
adamc@937 188 <xml><button value="Update" onclick={update}/></xml>)}/>
adamc@937 189 </td>
adamc@937 190
adamc@937 191 <td><dyn signal={b <- signal ud;
adamc@937 192 return (if b then
adamc@937 193 <xml><button value="Cancel" onclick={cancel}/></xml>
adamc@937 194 else
adamc@937 195 <xml><button value="Delete" onclick={delete}/></xml>)}/>
adamc@937 196 </td>
adamc@937 197
adamc@937 198 <dyn signal={cols <- signal colsS;
adamc@944 199 return (foldRX3 [fst3] [colMeta M.row] [snd3] [_]
adamc@944 200 (fn [nm :: Name] [t :: (Type * Type * Type)]
adamc@944 201 [rest :: {(Type * Type * Type)}]
adamc@937 202 [[nm] ~ rest] data meta v =>
adamc@937 203 <xml><td class={td}>
adamc@937 204 <dyn signal={b <- signal ud;
adamc@937 205 return (if b then
adamc@937 206 (meta.Handlers data).Edit v
adamc@937 207 else
adamc@937 208 (meta.Handlers data).Display
adamc@937 209 v)}/>
adamc@937 210 <dyn signal={b <- signal ud;
adamc@937 211 if b then
adamc@937 212 valid <-
adamc@937 213 (meta.Handlers data).Validate v;
adamc@937 214 return (if valid then
adamc@937 215 <xml/>
adamc@937 216 else
adamc@937 217 <xml>!</xml>)
adamc@937 218 else
adamc@937 219 return <xml/>}/>
adamc@937 220 </td></xml>)
adamc@937 221 [_] M.folder grid.Cols M.cols cols)}/>
adamc@937 222 </tr></xml>
adamc@951 223 end)
adamc@964 224 {StartPosition = Monad.mp Some (signal grid.Position),
adamc@964 225 MaxLength = return M.pageLength,
adamc@962 226 Filter = fn all =>
adamc@951 227 row <- signal all.Row;
adamc@951 228 foldR3 [colMeta M.row] [fst3] [thd3] [fn _ => M.row -> signal bool]
adamc@951 229 (fn [nm :: Name] [p :: (Type * Type * Type)]
adamc@951 230 [rest :: {(Type * Type * Type)}] [[nm] ~ rest]
adamc@951 231 meta state filter combinedFilter row =>
adamc@951 232 previous <- combinedFilter row;
adamc@951 233 this <- (meta.Handlers state).Filter filter row;
adamc@951 234 return (previous && this))
adamc@951 235 (fn _ => return True)
adamc@952 236 [_] M.folder M.cols grid.Cols grid.Filters row,
adamc@960 237 Sort = f <- signal grid.Sort;
adamc@960 238 return (Option.mp (fn f r1 r2 => r1 <- signal r1.Row;
adamc@960 239 r2 <- signal r2.Row;
adamc@960 240 return (f r1 r2)) f)}
adamc@951 241 grid.Rows}
adamc@915 242
adamc@937 243 <dyn signal={rows <- Dlist.foldl (fn row => Monad.mapR2 [aggregateMeta M.row] [id] [id]
adamc@937 244 (fn [nm :: Name] [t :: Type] meta acc =>
adamc@937 245 Monad.mp (fn v => meta.Step v acc)
adamc@937 246 (signal row.Row))
adamc@937 247 [_] M.aggFolder M.aggregates)
adamc@937 248 (mp [aggregateMeta M.row] [id]
adamc@937 249 (fn [t] meta => meta.Initial)
adamc@937 250 [_] M.aggFolder M.aggregates) grid.Rows;
adamc@937 251 return <xml><tr>
adamc@941 252 <th colspan={3}>Aggregates</th>
adamc@937 253 {foldRX2 [aggregateMeta M.row] [id] [_]
adamc@937 254 (fn [nm :: Name] [t :: Type] [rest :: {Type}] [[nm] ~ rest] meta acc =>
adamc@937 255 <xml><td class={agg}>{meta.Display acc}</td></xml>)
adamc@937 256 [_] M.aggFolder M.aggregates rows}
adamc@937 257 </tr></xml>}/>
adamc@944 258
adamc@944 259 <tr><th colspan={3}>Filters</th>
adamc@944 260 {foldRX3 [colMeta M.row] [fst3] [thd3] [_]
adamc@944 261 (fn [nm :: Name] [p :: (Type * Type * Type)] [rest :: {(Type * Type * Type)}] [[nm] ~ rest]
adamc@944 262 meta state filter => <xml><td>{(meta.Handlers state).DisplayFilter filter}</td></xml>)
adamc@944 263 [_] M.folder M.cols grid.Cols grid.Filters}
adamc@944 264 </tr>
adamc@915 265 </table>
adamc@964 266
adamc@964 267 {case M.pageLength of
adamc@964 268 None => <xml/>
adamc@964 269 | Some plen => <xml>
adamc@964 270 <dyn signal={avail <- Dlist.size grid.Rows;
adamc@964 271 return (if avail <= plen then
adamc@964 272 <xml/>
adamc@964 273 else
adamc@964 274 let
adamc@964 275 val numPages = avail / plen
adamc@964 276 val numPages = if numPages * plen < avail then
adamc@964 277 numPages + 1
adamc@964 278 else
adamc@964 279 numPages
adamc@964 280
adamc@964 281 fun pages n =
adamc@964 282 if n * plen >= avail then
adamc@964 283 <xml/>
adamc@964 284 else
adamc@964 285 <xml>
adamc@964 286 <dyn signal={pos <- signal grid.Position;
adamc@964 287 return (if n * plen = pos then
adamc@964 288 <xml><b>{[n + 1]}</b></xml>
adamc@964 289 else
adamc@964 290 <xml>
adamc@964 291 <button value={show (n + 1)}
adamc@964 292 onclick={set grid.Position
adamc@964 293 (n * plen)
adamc@964 294 }/></xml>)}/>
adamc@964 295 {if (n + 1) * plen >= avail then <xml/> else <xml>|</xml>}
adamc@964 296 {pages (n + 1)}
adamc@964 297 </xml>
adamc@964 298 in
adamc@964 299 <xml><p><b>Pages:</b> {pages 0}</p></xml>
adamc@964 300 end)}/>
adamc@964 301 </xml>}
adamc@915 302
adamc@915 303 <button value="New row" onclick={row <- rpc M.new;
adamc@915 304 addRow grid.Cols grid.Rows row}/>
adamc@915 305 <button value="Refresh" onclick={sync grid}/>
adamc@915 306 </xml>
adamc@940 307
adamc@940 308 fun showSelection grid = grid.Selection
adamc@940 309
adamc@940 310 fun selection grid = Dlist.foldl (fn {Row = rowS, Selected = sd, ...} ls =>
adamc@940 311 sd <- signal sd;
adamc@940 312 if sd then
adamc@940 313 row <- signal rowS;
adamc@940 314 return (row :: ls)
adamc@940 315 else
adamc@940 316 return ls) [] grid.Rows
adamc@915 317 end