Mercurial > urweb

annotate demo/more/grid.ur @ 943:e2194a6793ae

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix JavaScript char literals; don't generate demo links to nonexistent files
author Adam Chlipala <adamc@hcoop.net>
date Tue, 15 Sep 2009 13:07:57 -0400
parents b8d7a47b8e0c
children da3ec6014d2f
rev   line source
adamc@915 1 con colMeta' = fn (row :: Type) (t :: Type) =>
adamc@915 2 {Header : string,
adamc@915 3 Project : row -> transaction t,
adamc@915 4 Update : row -> t -> transaction row,
adamc@915 5 Display : t -> xbody,
adamc@915 6 Edit : t -> xbody,
adamc@915 7 Validate : t -> signal bool}
adamc@915 8
adamc@915 9 con colMeta = fn (row :: Type) (global_t :: (Type * Type)) =>
adamc@915 10 {Initialize : transaction global_t.1,
adamc@915 11 Handlers : global_t.1 -> colMeta' row global_t.2}
adamc@915 12
adamc@935 13 con aggregateMeta = fn (row :: Type) (acc :: Type) =>
adamc@935 14 {Initial : acc,
adamc@935 15 Step : row -> acc -> acc,
adamc@935 16 Display : acc -> xbody}
adamc@935 17
adamc@915 18 functor Make(M : sig
adamc@915 19 type row
adamc@936 20 type key
adamc@936 21 val keyOf : row -> key
adamc@936 22
adamc@915 23 val list : transaction (list row)
adamc@915 24 val new : transaction row
adamc@936 25 val save : key -> row -> transaction unit
adamc@936 26 val delete : key -> transaction unit
adamc@915 27
adamc@915 28 con cols :: {(Type * Type)}
adamc@915 29 val cols : $(map (colMeta row) cols)
adamc@915 30
adamc@915 31 val folder : folder cols
adamc@935 32
adamc@935 33 con aggregates :: {Type}
adamc@935 34 val aggregates : $(map (aggregateMeta row) aggregates)
adamc@937 35 val aggFolder : folder aggregates
adamc@915 36 end) = struct
adamc@915 37 style tabl
adamc@915 38 style tr
adamc@915 39 style th
adamc@915 40 style td
adamc@937 41 style agg
adamc@915 42
adamc@915 43 fun make (row : M.row) [t] (m : colMeta' M.row t) : transaction t = m.Project row
adamc@915 44
adamc@915 45 fun makeAll cols row = @@Monad.exec [transaction] _ [map snd M.cols]
adamc@915 46 (map2 [fst] [colMeta M.row] [fn p :: (Type * Type) => transaction p.2]
adamc@915 47 (fn [p] data meta => make row [_] (meta.Handlers data))
adamc@915 48 [_] M.folder cols M.cols)
adamc@915 49 (@@Folder.mp [_] [_] M.folder)
adamc@915 50
adamc@940 51 type grid = {Cols : $(map fst M.cols),
adamc@940 52 Rows : Dlist.dlist {Row : source M.row,
adamc@940 53 Cols : source ($(map snd M.cols)),
adamc@940 54 Updating : source bool,
adamc@940 55 Selected : source bool},
adamc@940 56 Selection : source bool}
adamc@940 57
adamc@915 58 fun addRow cols rows row =
adamc@915 59 rowS <- source row;
adamc@915 60 cols <- makeAll cols row;
adamc@915 61 colsS <- source cols;
adamc@915 62 ud <- source False;
adamc@940 63 sd <- source False;
adamc@915 64 Monad.ignore (Dlist.append rows {Row = rowS,
adamc@915 65 Cols = colsS,
adamc@940 66 Updating = ud,
adamc@940 67 Selected = sd})
adamc@915 68
adamc@915 69 val createMetas = Monad.mapR [colMeta M.row] [fst]
adamc@915 70 (fn [nm :: Name] [p :: (Type * Type)] meta => meta.Initialize)
adamc@915 71 [_] M.folder M.cols
adamc@915 72
adamc@915 73 val grid =
adamc@915 74 cols <- createMetas;
adamc@915 75 rows <- Dlist.create;
adamc@940 76 sel <- source False;
adamc@940 77 return {Cols = cols, Rows = rows, Selection = sel}
adamc@915 78
adamc@940 79 fun sync {Cols = cols, Rows = rows, ...} =
adamc@915 80 Dlist.clear rows;
adamc@915 81 init <- rpc M.list;
adamc@915 82 List.app (addRow cols rows) init
adamc@915 83
adamc@915 84 fun render grid = <xml>
adamc@915 85 <table class={tabl}>
adamc@915 86 <tr class={tr}>
adamc@943 87 <th/> <th/> <th/>
adamc@915 88 {foldRX2 [fst] [colMeta M.row] [_]
adamc@937 89 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest]
adamc@937 90 data (meta : colMeta M.row p) =>
adamc@937 91 <xml><th class={th}>{[(meta.Handlers data).Header]}</th></xml>)
adamc@937 92 [_] M.folder grid.Cols M.cols}
adamc@937 93 </tr>
adamc@915 94
adamc@940 95 {Dlist.render (fn {Row = rowS, Cols = colsS, Updating = ud, Selected = sd} pos =>
adamc@937 96 let
adamc@937 97 val delete =
adamc@937 98 Dlist.delete pos;
adamc@937 99 row <- get rowS;
adamc@937 100 rpc (M.delete (M.keyOf row))
adamc@915 101
adamc@937 102 val update = set ud True
adamc@915 103
adamc@937 104 val cancel =
adamc@937 105 set ud False;
adamc@937 106 row <- get rowS;
adamc@937 107 cols <- makeAll grid.Cols row;
adamc@937 108 set colsS cols
adamc@937 109
adamc@937 110 val save =
adamc@937 111 cols <- get colsS;
adamc@937 112 errors <- Monad.foldR3 [fst] [colMeta M.row] [snd] [fn _ => option string]
adamc@937 113 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@937 114 [[nm] ~ rest] data meta v errors =>
adamc@937 115 b <- current ((meta.Handlers data).Validate v);
adamc@937 116 return (if b then
adamc@937 117 errors
adamc@937 118 else
adamc@937 119 case errors of
adamc@937 120 None => Some ((meta.Handlers data).Header)
adamc@937 121 | Some s => Some ((meta.Handlers data).Header
adamc@937 122 ^ ", " ^ s)))
adamc@937 123 None [_] M.folder grid.Cols M.cols cols;
adamc@915 124
adamc@937 125 case errors of
adamc@937 126 Some s => alert ("Can't save because the following columns have invalid values:\n"
adamc@937 127 ^ s)
adamc@937 128 | None =>
adamc@937 129 set ud False;
adamc@937 130 row <- get rowS;
adamc@937 131 row' <- Monad.foldR3 [fst] [colMeta M.row] [snd] [fn _ => M.row]
adamc@937 132 (fn [nm :: Name] [t :: (Type * Type)]
adamc@937 133 [rest :: {(Type * Type)}]
adamc@937 134 [[nm] ~ rest] data meta v row' =>
adamc@937 135 (meta.Handlers data).Update row' v)
adamc@937 136 row [_] M.folder grid.Cols M.cols cols;
adamc@937 137 rpc (M.save (M.keyOf row) row');
adamc@937 138 set rowS row';
adamc@937 139
adamc@937 140 cols <- makeAll grid.Cols row';
adamc@937 141 set colsS cols
adamc@937 142 in
adamc@937 143 <xml><tr class={tr}>
adamc@937 144 <td>
adamc@940 145 <dyn signal={b <- signal grid.Selection;
adamc@941 146 return (if b then
adamc@940 147 <xml><ccheckbox source={sd}/></xml>
adamc@940 148 else
adamc@941 149 <xml/>)}/>
adamc@940 150 </td>
adamc@940 151
adamc@940 152 <td>
adamc@937 153 <dyn signal={b <- signal ud;
adamc@937 154 return (if b then
adamc@937 155 <xml><button value="Save" onclick={save}/></xml>
adamc@937 156 else
adamc@937 157 <xml><button value="Update" onclick={update}/></xml>)}/>
adamc@937 158 </td>
adamc@937 159
adamc@937 160 <td><dyn signal={b <- signal ud;
adamc@937 161 return (if b then
adamc@937 162 <xml><button value="Cancel" onclick={cancel}/></xml>
adamc@937 163 else
adamc@937 164 <xml><button value="Delete" onclick={delete}/></xml>)}/>
adamc@937 165 </td>
adamc@937 166
adamc@937 167 <dyn signal={cols <- signal colsS;
adamc@937 168 return (foldRX3 [fst] [colMeta M.row] [snd] [_]
adamc@915 169 (fn [nm :: Name] [t :: (Type * Type)]
adamc@915 170 [rest :: {(Type * Type)}]
adamc@937 171 [[nm] ~ rest] data meta v =>
adamc@937 172 <xml><td class={td}>
adamc@937 173 <dyn signal={b <- signal ud;
adamc@937 174 return (if b then
adamc@937 175 (meta.Handlers data).Edit v
adamc@937 176 else
adamc@937 177 (meta.Handlers data).Display
adamc@937 178 v)}/>
adamc@937 179 <dyn signal={b <- signal ud;
adamc@937 180 if b then
adamc@937 181 valid <-
adamc@937 182 (meta.Handlers data).Validate v;
adamc@937 183 return (if valid then
adamc@937 184 <xml/>
adamc@937 185 else
adamc@937 186 <xml>!</xml>)
adamc@937 187 else
adamc@937 188 return <xml/>}/>
adamc@937 189 </td></xml>)
adamc@937 190 [_] M.folder grid.Cols M.cols cols)}/>
adamc@937 191 </tr></xml>
adamc@937 192 end) grid.Rows}
adamc@915 193
adamc@937 194 <dyn signal={rows <- Dlist.foldl (fn row => Monad.mapR2 [aggregateMeta M.row] [id] [id]
adamc@937 195 (fn [nm :: Name] [t :: Type] meta acc =>
adamc@937 196 Monad.mp (fn v => meta.Step v acc)
adamc@937 197 (signal row.Row))
adamc@937 198 [_] M.aggFolder M.aggregates)
adamc@937 199 (mp [aggregateMeta M.row] [id]
adamc@937 200 (fn [t] meta => meta.Initial)
adamc@937 201 [_] M.aggFolder M.aggregates) grid.Rows;
adamc@937 202 return <xml><tr>
adamc@941 203 <th colspan={3}>Aggregates</th>
adamc@937 204 {foldRX2 [aggregateMeta M.row] [id] [_]
adamc@937 205 (fn [nm :: Name] [t :: Type] [rest :: {Type}] [[nm] ~ rest] meta acc =>
adamc@937 206 <xml><td class={agg}>{meta.Display acc}</td></xml>)
adamc@937 207 [_] M.aggFolder M.aggregates rows}
adamc@937 208 </tr></xml>}/>
adamc@915 209 </table>
adamc@915 210
adamc@915 211 <button value="New row" onclick={row <- rpc M.new;
adamc@915 212 addRow grid.Cols grid.Rows row}/>
adamc@915 213 <button value="Refresh" onclick={sync grid}/>
adamc@915 214 </xml>
adamc@940 215
adamc@940 216 fun showSelection grid = grid.Selection
adamc@940 217
adamc@940 218 fun selection grid = Dlist.foldl (fn {Row = rowS, Selected = sd, ...} ls =>
adamc@940 219 sd <- signal sd;
adamc@940 220 if sd then
adamc@940 221 row <- signal rowS;
adamc@940 222 return (row :: ls)
adamc@940 223 else
adamc@940 224 return ls) [] grid.Rows
adamc@915 225 end