Mercurial > urweb

annotate demo/more/grid.ur @ 2010:403f0cc65b9c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
New lessSafeFfi
author Adam Chlipala <adam@chlipala.net>
date Fri, 02 May 2014 19:19:09 -0400
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