Mercurial > urweb

annotate demo/more/grid.ur @ 925:552c989c1601

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change string URLification to avoid using the empty string, which confuses Apache no2slash()
author Adam Chlipala <adamc@hcoop.net>
date Sat, 12 Sep 2009 09:31:50 -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