Mercurial > urweb

comparison demo/more/grid.ur @ 915:5e8b6fa5b48f

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