Mercurial > urweb

comparison demo/more/dbgrid.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 51bc7681c47e
comparison
equal deleted inserted replaced
914:782f0b4eea67 915:5e8b6fa5b48f
1 con rawMeta = fn t :: Type =>
2 {New : transaction t,
3 Inj : sql_injectable t}
4
5 con colMeta' = fn (row :: {Type}) (t :: Type) =>
6 {Header : string,
7 Project : $row -> transaction t,
8 Update : $row -> t -> transaction ($row),
9 Display : t -> xbody,
10 Edit : t -> xbody,
11 Validate : t -> signal bool}
12
13 con colMeta = fn (row :: {Type}) (global_t :: (Type * Type)) =>
14 {Initialize : transaction global_t.1,
15 Handlers : global_t.1 -> colMeta' row global_t.2}
16
17 structure Direct = struct
18 con meta = fn global_actual_input :: (Type * Type * Type) =>
19 {Initialize : transaction global_actual_input.1,
20 Handlers : global_actual_input.1
21 -> {Display : global_actual_input.3 -> xbody,
22 Edit : global_actual_input.3 -> xbody,
23 Initialize : global_actual_input.2 -> transaction global_actual_input.3,
24 Parse : global_actual_input.3 -> signal (option global_actual_input.2)}}
25
26 con editableState (ts :: (Type * Type * Type)) = (ts.1, ts.3)
27 fun editable [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest)
28 (editableState ts) =
29 {Initialize = m.Initialize,
30 Handlers = fn data => {Header = name,
31 Project = fn r => (m.Handlers data).Initialize r.nm,
32 Update = fn r s =>
33 vo <- current ((m.Handlers data).Parse s);
34 return (case vo of
35 None => r
36 | Some v => r -- nm ++ {nm = v}),
37 Display = (m.Handlers data).Display,
38 Edit = (m.Handlers data).Edit,
39 Validate = fn s => vo <- (m.Handlers data).Parse s; return (Option.isSome vo)}}
40
41 con readOnlyState (ts :: (Type * Type * Type)) = (ts.1, ts.3)
42 fun readOnly [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest)
43 (readOnlyState ts) =
44 {Initialize = m.Initialize,
45 Handlers = fn data => {Header = name,
46 Project = fn r => (m.Handlers data).Initialize r.nm,
47 Update = fn r _ => return r,
48 Display = (m.Handlers data).Display,
49 Edit = (m.Handlers data).Display,
50 Validate = fn _ => return True}}
51
52 con metaBasic = fn actual_input :: (Type * Type) =>
53 {Display : actual_input.2 -> xbody,
54 Edit : source actual_input.2 -> xbody,
55 Initialize : actual_input.1 -> actual_input.2,
56 Parse : actual_input.2 -> option actual_input.1}
57
58 con basicState = source
59 fun basic [ts ::: (Type * Type)] (m : metaBasic ts) : meta (unit, ts.1, basicState ts.2) =
60 {Initialize = return (),
61 Handlers = fn () => {Display = fn s => <xml><dyn signal={v <- signal s; return (m.Display v)}/></xml>,
62 Edit = m.Edit,
63 Initialize = fn v => source (m.Initialize v),
64 Parse = fn s => v <- signal s; return (m.Parse v)}}
65
66 type intGlobal = unit
67 type intInput = basicState string
68 val int : meta (intGlobal, int, intInput) =
69 basic {Display = fn s => <xml>{[s]}</xml>,
70 Edit = fn s => <xml><ctextbox source={s}/></xml>,
71 Initialize = fn n => show n,
72 Parse = fn v => read v}
73
74 type stringGlobal = unit
75 type stringInput = basicState string
76 val string : meta (stringGlobal, string, stringInput) =
77 basic {Display = fn s => <xml>{[s]}</xml>,
78 Edit = fn s => <xml><ctextbox source={s}/></xml>,
79 Initialize = fn s => s,
80 Parse = fn s => Some s}
81
82 type boolGlobal = unit
83 type boolInput = basicState bool
84 val bool : meta (boolGlobal, bool, boolInput) =
85 basic {Display = fn b => <xml>{[b]}</xml>,
86 Edit = fn s => <xml><ccheckbox source={s}/></xml>,
87 Initialize = fn b => b,
88 Parse = fn b => Some b}
89
90 functor Foreign (M : sig
91 con row :: {Type}
92 con t :: Type
93 val show_t : show t
94 val read_t : read t
95 val eq_t : eq t
96 val inj_t : sql_injectable t
97 con nm :: Name
98 constraint [nm] ~ row
99 table tab : ([nm = t] ++ row)
100 val render : $([nm = t] ++ row) -> string
101 end) = struct
102 open M
103
104 con global = list (t * string)
105 con input = source string * t * $row
106
107 val getChoices = List.mapQuery (SELECT * FROM tab AS T)
108 (fn r => (r.T.nm, render r.T))
109
110 fun getChoice k =
111 r <- oneRow (SELECT T.{{row}} FROM tab AS T WHERE T.{nm} = {[k]});
112 return r.T
113
114 val meta =
115 {Initialize = getChoices,
116 Handlers = fn choices =>
117 {Display = fn (_, k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>,
118 Edit = fn (s, k, _) =>
119 <xml><cselect source={s}>
120 {List.mapX (fn (k', rend) =>
121 <xml><coption value={show k'} selected={k' = k}>{[rend]}</coption>
122 </xml>)
123 choices}
124 </cselect></xml>,
125 Initialize = fn k => s <- source (show k);
126 r <- rpc (getChoice k);
127 return (s, k, r),
128 Parse = fn (s, _, _) => k <- signal s; return (read k)}}
129 end
130 end
131
132 con computedState = (unit, xbody)
133 fun computed [row] [t] (_ : show t) name (f : $row -> t) : colMeta row computedState =
134 {Initialize = return (),
135 Handlers = fn () => {Header = name,
136 Project = fn r => return <xml>{[f r]}</xml>,
137 Update = fn r _ => return r,
138 Display = fn x => x,
139 Edit = fn _ => <xml>...</xml>,
140 Validate = fn _ => return True}}
141 fun computedHtml [row] name (f : $row -> xbody) : colMeta row computedState =
142 {Initialize = return (),
143 Handlers = fn () => {Header = name,
144 Project = fn r => return (f r),
145 Update = fn r _ => return r,
146 Display = fn x => x,
147 Edit = fn _ => <xml>...</xml>,
148 Validate = fn _ => return True}}
149
150 functor Make(M : sig
151 con key :: {Type}
152 con row :: {Type}
153 constraint key ~ row
154 table tab : (key ++ row)
155
156 val raw : $(map rawMeta (key ++ row))
157
158 con cols :: {(Type * Type)}
159 val cols : $(map (colMeta (key ++ row)) cols)
160
161 val keyFolder : folder key
162 val rowFolder : folder row
163 val colsFolder : folder cols
164 end) = struct
165 open Grid.Make(struct
166 val list = query (SELECT * FROM {{M.tab}} AS T) (fn r rs => return (r.T :: rs)) []
167
168 val wholeRow = @Folder.concat ! M.keyFolder M.rowFolder
169
170 fun ensql [env] (r : $(M.key ++ M.row)) =
171 map2 [rawMeta] [id] [sql_exp env [] []]
172 (fn [t] meta v => @sql_inject meta.Inj v)
173 [_] wholeRow M.raw r
174
175 val new =
176 row <- Monad.mapR [rawMeta] [id]
177 (fn [nm :: Name] [t :: Type] meta => meta.New)
178 [_] wholeRow M.raw;
179 dml (insert M.tab (ensql row));
180 return row
181
182 fun selector (r : $(M.key ++ M.row)) : sql_exp [T = M.key ++ M.row] [] [] bool =
183 foldR2 [rawMeta] [id]
184 [fn key => rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool]
185 (fn [nm :: Name] [t :: Type] [key :: {Type}] [[nm] ~ key]
186 (meta : rawMeta t) (v : t)
187 (exp : rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool)
188 [rest :: {Type}] [rest ~ [nm = t] ++ key] =>
189 (WHERE T.{nm} = {@sql_inject meta.Inj v} AND {exp [[nm = t] ++ rest] !}))
190 (fn [rest :: {Type}] [rest ~ []] => (WHERE TRUE))
191 [_] M.keyFolder (M.raw --- map rawMeta M.row) (r --- M.row)
192 [_] !
193
194 fun save {Old = row, New = row'} =
195 dml (update [M.key ++ M.row] !
196 (ensql row')
197 M.tab
198 (selector row))
199
200 fun delete row =
201 dml (Basis.delete M.tab (selector row))
202
203 val cols = M.cols
204
205 val folder = M.colsFolder
206 end)
207 end