Mercurial > urweb

annotate demo/more/grid.ur @ 960:6f34950825b6

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