Mercurial > urweb

annotate demo/more/grid.ur @ 1839:d8c260bcc1f9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix determination of MySQL timestamp hour fields (may still be wrong once DST bit flips)
author Adam Chlipala <adam@chlipala.net>
date Thu, 13 Dec 2012 17:51:34 -0500
parents be0c4e2e488a
children
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@1002 12
adamc@1002 13 con colMeta = fn (row :: Type) (global :: Type, input :: Type, filter :: Type) =>
adamc@1002 14 {Initialize : transaction global,
adamc@1002 15 Handlers : global -> colMeta' row input filter}
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
adam@1833 43 style tab
adam@1833 44 style row
adam@1833 45 style header
adam@1833 46 style data
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]
adam@1304 52 (@map2 [fst3] [colMeta M.row] [fn p => transaction (snd3 p)]
adam@1304 53 (fn [p] data meta => make row (meta.Handlers data))
adam@1304 54 M.folder cols M.cols)
adam@1304 55 (@@Folder.mp [_] [_] M.folder)
adam@1304 56
adam@1304 57 type listT = {Row : source M.row,
adam@1304 58 Cols : source ($(map snd3 M.cols)),
adam@1304 59 Updating : source bool,
adam@1304 60 Selected : source bool}
adamc@915 61
adamc@944 62 type grid = {Cols : $(map fst3 M.cols),
adam@1304 63 Rows : Dlist.dlist listT,
adamc@944 64 Selection : source bool,
adamc@960 65 Filters : $(map thd3 M.cols),
adamc@964 66 Sort : source (option (M.row -> M.row -> bool)),
adamc@964 67 Position : source int}
adamc@940 68
adamc@954 69 fun newRow cols row =
adamc@915 70 rowS <- source row;
adamc@915 71 cols <- makeAll cols row;
adamc@915 72 colsS <- source cols;
adamc@915 73 ud <- source False;
adamc@940 74 sd <- source False;
adamc@954 75 return {Row = rowS,
adamc@954 76 Cols = colsS,
adamc@954 77 Updating = ud,
adamc@954 78 Selected = sd}
adamc@954 79
adamc@954 80 fun addRow cols rows row =
adamc@954 81 r <- newRow cols row;
adamc@954 82 Monad.ignore (Dlist.append rows r)
adamc@915 83
adamc@944 84 val grid =
adamc@1093 85 cols <- @Monad.mapR _ [colMeta M.row] [fst3]
adamc@1093 86 (fn [nm :: Name] [p :: (Type * Type * Type)] meta => meta.Initialize)
adamc@1093 87 M.folder M.cols;
adamc@915 88
adamc@1093 89 filters <- @Monad.mapR2 _ [colMeta M.row] [fst3] [thd3]
adamc@1093 90 (fn [nm :: Name] [p :: (Type * Type * Type)] meta state =>
adamc@1093 91 (meta.Handlers state).CreateFilter)
adamc@1093 92 M.folder M.cols cols;
adamc@944 93
adamc@951 94 rows <- Dlist.create;
adamc@940 95 sel <- source False;
adamc@960 96 sort <- source None;
adamc@964 97 pos <- source 0;
adamc@951 98
adamc@951 99 return {Cols = cols,
adamc@951 100 Rows = rows,
adamc@951 101 Selection = sel,
adamc@960 102 Filters = filters,
adamc@964 103 Sort = sort,
adamc@964 104 Position = pos}
adamc@915 105
adamc@940 106 fun sync {Cols = cols, Rows = rows, ...} =
adamc@915 107 Dlist.clear rows;
adamc@915 108 init <- rpc M.list;
adamc@954 109 rs <- List.mapM (newRow cols) init;
adamc@954 110 Dlist.replace rows rs
adamc@915 111
adamc@965 112 fun myFilter grid all =
adamc@965 113 row <- signal all.Row;
adamc@1093 114 @foldR3 [colMeta M.row] [fst3] [thd3] [fn _ => M.row -> signal bool]
adamc@1093 115 (fn [nm :: Name] [p :: (Type * Type * Type)]
adamc@1093 116 [rest :: {(Type * Type * Type)}] [[nm] ~ rest]
adamc@1093 117 meta state filter combinedFilter row =>
adamc@1093 118 previous <- combinedFilter row;
adamc@1093 119 this <- (meta.Handlers state).Filter filter row;
adamc@1093 120 return (previous && this))
adamc@1093 121 (fn _ => return True)
adamc@1093 122 M.folder M.cols grid.Cols grid.Filters row
adamc@965 123
adamc@961 124 fun render (grid : grid) = <xml>
adam@1833 125 <table class={tab}>
adam@1833 126 <tr class={row}>
adam@1784 127 <th/> <th/> <th><button value="No sort" onclick={fn _ => set grid.Sort None}/></th>
adam@1641 128 {@mapX2 [fst3] [colMeta M.row] [tr]
adamc@1093 129 (fn [nm :: Name] [p :: (Type * Type * Type)] [rest :: {(Type * Type * Type)}] [[nm] ~ rest]
adamc@1093 130 data (meta : colMeta M.row p) =>
adam@1833 131 <xml><th class={header}>
adamc@1093 132 {case (meta.Handlers data).Sort of
adamc@1093 133 None => txt (meta.Handlers data).Header
adamc@1093 134 | sort => <xml><button value={(meta.Handlers data).Header}
adam@1784 135 onclick={fn _ => set grid.Sort sort}/></xml>}
adamc@1093 136 </th></xml>)
adamc@1093 137 M.folder grid.Cols M.cols}
adamc@937 138 </tr>
adamc@915 139
adamc@940 140 {Dlist.render (fn {Row = rowS, Cols = colsS, Updating = ud, Selected = sd} pos =>
adamc@937 141 let
adamc@937 142 val delete =
adamc@937 143 Dlist.delete pos;
adamc@937 144 row <- get rowS;
adamc@937 145 rpc (M.delete (M.keyOf row))
adamc@915 146
adamc@937 147 val update = set ud True
adamc@915 148
adamc@937 149 val cancel =
adamc@937 150 set ud False;
adamc@937 151 row <- get rowS;
adamc@937 152 cols <- makeAll grid.Cols row;
adamc@937 153 set colsS cols
adamc@937 154
adamc@937 155 val save =
adamc@937 156 cols <- get colsS;
adamc@1093 157 errors <- @Monad.foldR3 _ [fst3] [colMeta M.row] [snd3] [fn _ => option string]
adamc@1093 158 (fn [nm :: Name] [p :: (Type * Type * Type)] [rest :: {(Type * Type * Type)}]
adamc@1093 159 [[nm] ~ rest] data meta v errors =>
adamc@1093 160 b <- current ((meta.Handlers data).Validate v);
adamc@1093 161 return (if b then
adamc@1093 162 errors
adamc@1093 163 else
adamc@1093 164 case errors of
adamc@1093 165 None => Some ((meta.Handlers data).Header)
adamc@1093 166 | Some s => Some ((meta.Handlers data).Header
adamc@1093 167 ^ ", " ^ s)))
adamc@1093 168 None M.folder grid.Cols M.cols cols;
adamc@915 169
adamc@937 170 case errors of
adamc@937 171 Some s => alert ("Can't save because the following columns have invalid values:\n"
adamc@937 172 ^ s)
adamc@937 173 | None =>
adamc@937 174 set ud False;
adamc@937 175 row <- get rowS;
adamc@1093 176 row' <- @Monad.foldR3 _ [fst3] [colMeta M.row] [snd3] [fn _ => M.row]
adamc@1093 177 (fn [nm :: Name] [t :: (Type * Type * Type)]
adamc@1093 178 [rest :: {(Type * Type * Type)}]
adamc@1093 179 [[nm] ~ rest] data meta v row' =>
adamc@1093 180 (meta.Handlers data).Update row' v)
adamc@1093 181 row M.folder grid.Cols M.cols cols;
adamc@937 182 rpc (M.save (M.keyOf row) row');
adamc@937 183 set rowS row';
adamc@937 184
adamc@937 185 cols <- makeAll grid.Cols row';
adamc@937 186 set colsS cols
adamc@937 187 in
adam@1833 188 <xml><tr class={row}>
adamc@937 189 <td>
adamc@940 190 <dyn signal={b <- signal grid.Selection;
adamc@941 191 return (if b then
adamc@940 192 <xml><ccheckbox source={sd}/></xml>
adamc@940 193 else
adamc@941 194 <xml/>)}/>
adamc@940 195 </td>
adamc@940 196
adamc@940 197 <td>
adamc@937 198 <dyn signal={b <- signal ud;
adamc@937 199 return (if b then
adam@1784 200 <xml><button value="Save" onclick={fn _ => save}/></xml>
adamc@937 201 else
adam@1784 202 <xml><button value="Update" onclick={fn _ => update}/></xml>)}/>
adamc@937 203 </td>
adamc@937 204
adamc@937 205 <td><dyn signal={b <- signal ud;
adamc@937 206 return (if b then
adam@1784 207 <xml><button value="Cancel" onclick={fn _ => cancel}/></xml>
adamc@937 208 else
adam@1784 209 <xml><button value="Delete" onclick={fn _ => delete}/></xml>)}/>
adamc@937 210 </td>
adamc@937 211
adamc@937 212 <dyn signal={cols <- signal colsS;
adamc@1172 213 return (@mapX3 [fst3] [colMeta M.row] [snd3] [_]
adamc@1093 214 (fn [nm :: Name] [t :: (Type * Type * Type)]
adamc@1093 215 [rest :: {(Type * Type * Type)}]
adam@1833 216 [[nm] ~ rest] dat meta v =>
adam@1833 217 <xml><td class={data}>
adamc@1093 218 <dyn signal={b <- signal ud;
adamc@1093 219 return (if b then
adam@1833 220 (meta.Handlers dat).Edit v
adamc@1093 221 else
adam@1833 222 (meta.Handlers dat).Display
adamc@1093 223 v)}/>
adamc@1093 224 <dyn signal={b <- signal ud;
adamc@1093 225 if b then
adamc@1093 226 valid <-
adam@1833 227 (meta.Handlers dat).Validate v;
adamc@1093 228 return (if valid then
adamc@1093 229 <xml/>
adamc@1093 230 else
adamc@1093 231 <xml>!</xml>)
adamc@1093 232 else
adamc@1093 233 return <xml/>}/>
adamc@1093 234 </td></xml>)
adamc@1093 235 M.folder grid.Cols M.cols cols)}/>
adamc@937 236 </tr></xml>
adamc@951 237 end)
adamc@965 238 {StartPosition = case M.pageLength of
adamc@965 239 None => return None
adamc@965 240 | Some len =>
adamc@965 241 avail <- Dlist.numPassing (myFilter grid) grid.Rows;
adamc@965 242 pos <- signal grid.Position;
adamc@965 243 return (Some (if pos >= avail then
adamc@965 244 0
adamc@965 245 else
adamc@965 246 pos)),
adamc@964 247 MaxLength = return M.pageLength,
adamc@965 248 Filter = myFilter grid,
adamc@960 249 Sort = f <- signal grid.Sort;
adamc@960 250 return (Option.mp (fn f r1 r2 => r1 <- signal r1.Row;
adamc@960 251 r2 <- signal r2.Row;
adamc@960 252 return (f r1 r2)) f)}
adamc@951 253 grid.Rows}
adamc@915 254
adam@1304 255 <dyn signal={rows <- Dlist.foldl (fn row : listT =>
adam@1649 256 @Monad.mapR2 _ [aggregateMeta M.row] [ident] [ident]
adam@1304 257 (fn [nm :: Name] [t :: Type] meta acc =>
adam@1304 258 Monad.mp (fn v => meta.Step v acc)
adam@1304 259 (signal row.Row))
adam@1304 260 M.aggFolder M.aggregates)
adam@1649 261 (@mp [aggregateMeta M.row] [ident]
adamc@937 262 (fn [t] meta => meta.Initial)
adamc@1093 263 M.aggFolder M.aggregates) grid.Rows;
adamc@937 264 return <xml><tr>
adamc@941 265 <th colspan={3}>Aggregates</th>
adam@1649 266 {@mapX2 [aggregateMeta M.row] [ident] [_]
adamc@1093 267 (fn [nm :: Name] [t :: Type] [rest :: {Type}] [[nm] ~ rest] meta acc =>
adamc@1093 268 <xml><td class={agg}>{meta.Display acc}</td></xml>)
adamc@1093 269 M.aggFolder M.aggregates rows}
adamc@937 270 </tr></xml>}/>
adamc@944 271
adamc@944 272 <tr><th colspan={3}>Filters</th>
adamc@1172 273 {@mapX3 [colMeta M.row] [fst3] [thd3] [_]
adamc@1093 274 (fn [nm :: Name] [p :: (Type * Type * Type)] [rest :: {(Type * Type * Type)}] [[nm] ~ rest]
adamc@1093 275 meta state filter => <xml><td>{(meta.Handlers state).DisplayFilter filter}</td></xml>)
adamc@1093 276 M.folder M.cols grid.Cols grid.Filters}
adamc@944 277 </tr>
adamc@915 278 </table>
adamc@964 279
adamc@964 280 {case M.pageLength of
adamc@964 281 None => <xml/>
adamc@964 282 | Some plen => <xml>
adamc@965 283 <dyn signal={avail <- Dlist.numPassing (myFilter grid) grid.Rows;
adamc@964 284 return (if avail <= plen then
adamc@964 285 <xml/>
adamc@964 286 else
adamc@964 287 let
adamc@964 288 val numPages = avail / plen
adamc@964 289 val numPages = if numPages * plen < avail then
adamc@964 290 numPages + 1
adamc@964 291 else
adamc@964 292 numPages
adamc@964 293
adamc@964 294 fun pages n =
adamc@964 295 if n * plen >= avail then
adamc@964 296 <xml/>
adamc@964 297 else
adamc@964 298 <xml>
adamc@964 299 <dyn signal={pos <- signal grid.Position;
adamc@964 300 return (if n * plen = pos then
adamc@964 301 <xml><b>{[n + 1]}</b></xml>
adamc@964 302 else
adamc@964 303 <xml>
adamc@964 304 <button value={show (n + 1)}
adam@1784 305 onclick={fn _ => set grid.Position
adam@1784 306 (n * plen)
adamc@964 307 }/></xml>)}/>
adamc@964 308 {if (n + 1) * plen >= avail then <xml/> else <xml>|</xml>}
adamc@964 309 {pages (n + 1)}
adamc@964 310 </xml>
adamc@964 311 in
adamc@964 312 <xml><p><b>Pages:</b> {pages 0}</p></xml>
adamc@964 313 end)}/>
adamc@964 314 </xml>}
adamc@915 315
adam@1784 316 <button value="New row" onclick={fn _ => row <- rpc M.new;
adam@1784 317 addRow grid.Cols grid.Rows row}/>
adam@1784 318 <button value="Refresh" onclick={fn _ => sync grid}/>
adamc@915 319 </xml>
adamc@940 320
adamc@940 321 fun showSelection grid = grid.Selection
adamc@940 322
adamc@940 323 fun selection grid = Dlist.foldl (fn {Row = rowS, Selected = sd, ...} ls =>
adamc@940 324 sd <- signal sd;
adamc@940 325 if sd then
adamc@940 326 row <- signal rowS;
adamc@940 327 return (row :: ls)
adamc@940 328 else
adamc@940 329 return ls) [] grid.Rows
adamc@915 330 end