Mercurial > urweb

annotate demo/more/grid.ur @ 931:be6585b4058b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Have nullable columns working with Dbgrid
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Sep 2009 12:00:34 -0400
parents 5e8b6fa5b48f
children 2422360c78a3
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@915 13 functor Make(M : sig
adamc@915 14 type row
adamc@915 15 val list : transaction (list row)
adamc@915 16 val new : transaction row
adamc@915 17 val save : {Old : row, New : row} -> transaction unit
adamc@915 18 val delete : row -> transaction unit
adamc@915 19
adamc@915 20 con cols :: {(Type * Type)}
adamc@915 21 val cols : $(map (colMeta row) cols)
adamc@915 22
adamc@915 23 val folder : folder cols
adamc@915 24 end) = struct
adamc@915 25 style tabl
adamc@915 26 style tr
adamc@915 27 style th
adamc@915 28 style td
adamc@915 29
adamc@915 30 fun make (row : M.row) [t] (m : colMeta' M.row t) : transaction t = m.Project row
adamc@915 31
adamc@915 32 fun makeAll cols row = @@Monad.exec [transaction] _ [map snd M.cols]
adamc@915 33 (map2 [fst] [colMeta M.row] [fn p :: (Type * Type) => transaction p.2]
adamc@915 34 (fn [p] data meta => make row [_] (meta.Handlers data))
adamc@915 35 [_] M.folder cols M.cols)
adamc@915 36 (@@Folder.mp [_] [_] M.folder)
adamc@915 37
adamc@915 38 fun addRow cols rows row =
adamc@915 39 rowS <- source row;
adamc@915 40 cols <- makeAll cols row;
adamc@915 41 colsS <- source cols;
adamc@915 42 ud <- source False;
adamc@915 43 Monad.ignore (Dlist.append rows {Row = rowS,
adamc@915 44 Cols = colsS,
adamc@915 45 Updating = ud})
adamc@915 46
adamc@915 47 type grid = {Cols : $(map fst M.cols),
adamc@915 48 Rows : Dlist.dlist {Row : source M.row, Cols : source ($(map snd M.cols)), Updating : source bool}}
adamc@915 49
adamc@915 50 val createMetas = Monad.mapR [colMeta M.row] [fst]
adamc@915 51 (fn [nm :: Name] [p :: (Type * Type)] meta => meta.Initialize)
adamc@915 52 [_] M.folder M.cols
adamc@915 53
adamc@915 54 val grid =
adamc@915 55 cols <- createMetas;
adamc@915 56 rows <- Dlist.create;
adamc@915 57 return {Cols = cols, Rows = rows}
adamc@915 58
adamc@915 59 fun sync {Cols = cols, Rows = rows} =
adamc@915 60 Dlist.clear rows;
adamc@915 61 init <- rpc M.list;
adamc@915 62 List.app (addRow cols rows) init
adamc@915 63
adamc@915 64 fun render grid = <xml>
adamc@915 65 <table class={tabl}>
adamc@915 66 <tr class={tr}>
adamc@915 67 <th/> <th/>
adamc@915 68 {foldRX2 [fst] [colMeta M.row] [_]
adamc@915 69 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest]
adamc@915 70 data (meta : colMeta M.row p) =>
adamc@915 71 <xml><th class={th}>{[(meta.Handlers data).Header]}</th></xml>)
adamc@915 72 [_] M.folder grid.Cols M.cols}
adamc@915 73 </tr>
adamc@915 74
adamc@915 75 {Dlist.render (fn {Row = rowS, Cols = colsS, Updating = ud} pos =>
adamc@915 76 let
adamc@915 77 val delete =
adamc@915 78 Dlist.delete pos;
adamc@915 79 row <- get rowS;
adamc@915 80 rpc (M.delete row)
adamc@915 81
adamc@915 82 val update = set ud True
adamc@915 83
adamc@915 84 val cancel =
adamc@915 85 set ud False;
adamc@915 86 row <- get rowS;
adamc@915 87 cols <- makeAll grid.Cols row;
adamc@915 88 set colsS cols
adamc@915 89
adamc@915 90 val save =
adamc@915 91 cols <- get colsS;
adamc@915 92 errors <- Monad.foldR3 [fst] [colMeta M.row] [snd] [fn _ => option string]
adamc@915 93 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@915 94 [[nm] ~ rest] data meta v errors =>
adamc@915 95 b <- current ((meta.Handlers data).Validate v);
adamc@915 96 return (if b then
adamc@915 97 errors
adamc@915 98 else
adamc@915 99 case errors of
adamc@915 100 None => Some ((meta.Handlers data).Header)
adamc@915 101 | Some s => Some ((meta.Handlers data).Header
adamc@915 102 ^ ", " ^ s)))
adamc@915 103 None [_] M.folder grid.Cols M.cols cols;
adamc@915 104
adamc@915 105 case errors of
adamc@915 106 Some s => alert ("Can't save because the following columns have invalid values:\n"
adamc@915 107 ^ s)
adamc@915 108 | None =>
adamc@915 109 set ud False;
adamc@915 110 row <- get rowS;
adamc@915 111 row' <- Monad.foldR3 [fst] [colMeta M.row] [snd] [fn _ => M.row]
adamc@915 112 (fn [nm :: Name] [t :: (Type * Type)]
adamc@915 113 [rest :: {(Type * Type)}]
adamc@915 114 [[nm] ~ rest] data meta v row' =>
adamc@915 115 (meta.Handlers data).Update row' v)
adamc@915 116 row [_] M.folder grid.Cols M.cols cols;
adamc@915 117 rpc (M.save {Old = row, New = row'});
adamc@915 118 set rowS row';
adamc@915 119
adamc@915 120 cols <- makeAll grid.Cols row';
adamc@915 121 set colsS cols
adamc@915 122 in
adamc@915 123 <xml><tr class={tr}>
adamc@915 124 <td>
adamc@915 125 <dyn signal={b <- signal ud;
adamc@915 126 return (if b then
adamc@915 127 <xml><button value="Save" onclick={save}/></xml>
adamc@915 128 else
adamc@915 129 <xml><button value="Update" onclick={update}/></xml>)}/>
adamc@915 130 </td>
adamc@915 131 <td><dyn signal={b <- signal ud;
adamc@915 132 return (if b then
adamc@915 133 <xml><button value="Cancel" onclick={cancel}/></xml>
adamc@915 134 else
adamc@915 135 <xml><button value="Delete" onclick={delete}/></xml>)}/>
adamc@915 136 </td>
adamc@915 137
adamc@915 138 <dyn signal={cols <- signal colsS;
adamc@915 139 return (foldRX3 [fst] [colMeta M.row] [snd] [_]
adamc@915 140 (fn [nm :: Name] [t :: (Type * Type)]
adamc@915 141 [rest :: {(Type * Type)}]
adamc@915 142 [[nm] ~ rest] data meta v =>
adamc@915 143 <xml><td class={td}>
adamc@915 144 <dyn signal={b <- signal ud;
adamc@915 145 return (if b then
adamc@915 146 (meta.Handlers data).Edit v
adamc@915 147 else
adamc@915 148 (meta.Handlers data).Display
adamc@915 149 v)}/>
adamc@915 150 <dyn signal={b <- signal ud;
adamc@915 151 if b then
adamc@915 152 valid <-
adamc@915 153 (meta.Handlers data).Validate v;
adamc@915 154 return (if valid then
adamc@915 155 <xml/>
adamc@915 156 else
adamc@915 157 <xml>!</xml>)
adamc@915 158 else
adamc@915 159 return <xml/>}/>
adamc@915 160 </td></xml>)
adamc@915 161 [_] M.folder grid.Cols M.cols cols)}/>
adamc@915 162 </tr></xml>
adamc@915 163 end) grid.Rows}
adamc@915 164 </table>
adamc@915 165
adamc@915 166 <button value="New row" onclick={row <- rpc M.new;
adamc@915 167 addRow grid.Cols grid.Rows row}/>
adamc@915 168 <button value="Refresh" onclick={sync grid}/>
adamc@915 169 </xml>
adamc@915 170 end