Mercurial > urweb

comparison demo/more/dbgrid.ur @ 930:51bc7681c47e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Nullable columns *might* be working, but too much JS is generated for the page to load in finite time
author Adam Chlipala <adamc@hcoop.net>
date Sat, 12 Sep 2009 15:08:16 -0400
parents 5e8b6fa5b48f
children 2422360c78a3
comparison
equal deleted inserted replaced
929:095df8f710e0 930:51bc7681c47e
13 con colMeta = fn (row :: {Type}) (global_t :: (Type * Type)) => 13 con colMeta = fn (row :: {Type}) (global_t :: (Type * Type)) =>
14 {Initialize : transaction global_t.1, 14 {Initialize : transaction global_t.1,
15 Handlers : global_t.1 -> colMeta' row global_t.2} 15 Handlers : global_t.1 -> colMeta' row global_t.2}
16 16
17 structure Direct = struct 17 structure Direct = struct
18 con metaBase = fn actual_input :: (Type * Type) =>
19 {Display : actual_input.2 -> xbody,
20 Edit : actual_input.2 -> xbody,
21 Initialize : actual_input.1 -> transaction actual_input.2,
22 Parse : actual_input.2 -> signal (option actual_input.1)}
23
24 datatype metaBoth actual input =
25 NonNull of metaBase (actual, input) * metaBase (option actual, input)
26 | Nullable of metaBase (actual, input)
27
18 con meta = fn global_actual_input :: (Type * Type * Type) => 28 con meta = fn global_actual_input :: (Type * Type * Type) =>
19 {Initialize : transaction global_actual_input.1, 29 {Initialize : transaction global_actual_input.1,
20 Handlers : global_actual_input.1 30 Handlers : global_actual_input.1
21 -> {Display : global_actual_input.3 -> xbody, 31 -> metaBoth global_actual_input.2 global_actual_input.3}
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 32
26 con editableState (ts :: (Type * Type * Type)) = (ts.1, ts.3) 33 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) 34 fun editable [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest)
28 (editableState ts) = 35 (editableState ts) =
29 {Initialize = m.Initialize, 36 let
30 Handlers = fn data => {Header = name, 37 fun doMr mr = {Header = name,
31 Project = fn r => (m.Handlers data).Initialize r.nm, 38 Project = fn r => mr.Initialize r.nm,
32 Update = fn r s => 39 Update = fn r s =>
33 vo <- current ((m.Handlers data).Parse s); 40 vo <- current (mr.Parse s);
34 return (case vo of 41 return (case vo of
35 None => r 42 None => r
36 | Some v => r -- nm ++ {nm = v}), 43 | Some v => r -- nm ++ {nm = v}),
37 Display = (m.Handlers data).Display, 44 Display = mr.Display,
38 Edit = (m.Handlers data).Edit, 45 Edit = mr.Edit,
39 Validate = fn s => vo <- (m.Handlers data).Parse s; return (Option.isSome vo)}} 46 Validate = fn s => vo <- mr.Parse s; return (Option.isSome vo)}
47 in
48 {Initialize = m.Initialize,
49 Handlers = fn data => case m.Handlers data of
50 NonNull (mr, _) => doMr mr
51 | Nullable mr => doMr mr}
52 end
40 53
41 con readOnlyState (ts :: (Type * Type * Type)) = (ts.1, ts.3) 54 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) 55 fun readOnly [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest)
43 (readOnlyState ts) = 56 (readOnlyState ts) =
44 {Initialize = m.Initialize, 57 let
45 Handlers = fn data => {Header = name, 58 fun doMr mr = {Header = name,
46 Project = fn r => (m.Handlers data).Initialize r.nm, 59 Project = fn r => mr.Initialize r.nm,
47 Update = fn r _ => return r, 60 Update = fn r _ => return r,
48 Display = (m.Handlers data).Display, 61 Display = mr.Display,
49 Edit = (m.Handlers data).Display, 62 Edit = mr.Display,
50 Validate = fn _ => return True}} 63 Validate = fn _ => return True}
64 in
65 {Initialize = m.Initialize,
66 Handlers = fn data => case m.Handlers data of
67 NonNull (mr, _) => doMr mr
68 | Nullable mr => doMr mr}
69 end
51 70
52 con metaBasic = fn actual_input :: (Type * Type) => 71 con metaBasic = fn actual_input :: (Type * Type) =>
53 {Display : actual_input.2 -> xbody, 72 {Display : actual_input.2 -> xbody,
54 Edit : source actual_input.2 -> xbody, 73 Edit : source actual_input.2 -> xbody,
55 Initialize : actual_input.1 -> actual_input.2, 74 Initialize : actual_input.1 -> actual_input.2,
56 Parse : actual_input.2 -> option actual_input.1} 75 InitializeNull : actual_input.2,
76 IsNull : actual_input.2 -> bool,
77 Parse : actual_input.2 -> option actual_input.1}
57 78
58 con basicState = source 79 con basicState = source
59 fun basic [ts ::: (Type * Type)] (m : metaBasic ts) : meta (unit, ts.1, basicState ts.2) = 80 fun basic [ts ::: (Type * Type)] (m : metaBasic ts) : meta (unit, ts.1, basicState ts.2) =
60 {Initialize = return (), 81 {Initialize = return (),
61 Handlers = fn () => {Display = fn s => <xml><dyn signal={v <- signal s; return (m.Display v)}/></xml>, 82 Handlers = fn () => NonNull (
83 {Display = fn s => <xml><dyn signal={v <- signal s; return (m.Display v)}/></xml>,
62 Edit = m.Edit, 84 Edit = m.Edit,
63 Initialize = fn v => source (m.Initialize v), 85 Initialize = fn v => source (m.Initialize v),
64 Parse = fn s => v <- signal s; return (m.Parse v)}} 86 Parse = fn s => v <- signal s; return (m.Parse v)},
87 {Display = fn s => <xml><dyn signal={v <- signal s; return (m.Display v)}/></xml>,
88 Edit = m.Edit,
89 Initialize = fn v => source (case v of
90 None => m.InitializeNull
91 | Some v => m.Initialize v),
92 Parse = fn s => v <- signal s;
93 return (if m.IsNull v then
94 Some None
95 else
96 case m.Parse v of
97 None => None
98 | Some v' => Some (Some v'))})}
99
100 fun nullable [global] [actual] [input] (m : meta (global, actual, input)) =
101 {Initialize = m.Initialize,
102 Handlers = fn d => case m.Handlers d of
103 Nullable _ => error <xml>Don't stack calls to Direct.nullable!</xml>
104 | NonNull (_, ho) => Nullable ho}
65 105
66 type intGlobal = unit 106 type intGlobal = unit
67 type intInput = basicState string 107 type intInput = basicState string
68 val int : meta (intGlobal, int, intInput) = 108 val int : meta (intGlobal, int, intInput) =
69 basic {Display = fn s => <xml>{[s]}</xml>, 109 basic {Display = fn s => <xml>{[s]}</xml>,
70 Edit = fn s => <xml><ctextbox source={s}/></xml>, 110 Edit = fn s => <xml><ctextbox source={s}/></xml>,
71 Initialize = fn n => show n, 111 Initialize = fn n => show n,
112 InitializeNull = "",
113 IsNull = eq "",
72 Parse = fn v => read v} 114 Parse = fn v => read v}
73 115
74 type stringGlobal = unit 116 type stringGlobal = unit
75 type stringInput = basicState string 117 type stringInput = basicState string
76 val string : meta (stringGlobal, string, stringInput) = 118 val string : meta (stringGlobal, string, stringInput) =
77 basic {Display = fn s => <xml>{[s]}</xml>, 119 basic {Display = fn s => <xml>{[s]}</xml>,
78 Edit = fn s => <xml><ctextbox source={s}/></xml>, 120 Edit = fn s => <xml><ctextbox source={s}/></xml>,
79 Initialize = fn s => s, 121 Initialize = fn s => s,
122 InitializeNull = "",
123 IsNull = eq "",
80 Parse = fn s => Some s} 124 Parse = fn s => Some s}
81 125
82 type boolGlobal = unit 126 type boolGlobal = unit
83 type boolInput = basicState bool 127 type boolInput = basicState bool
84 val bool : meta (boolGlobal, bool, boolInput) = 128 val bool : meta (boolGlobal, bool, boolInput) =
85 basic {Display = fn b => <xml>{[b]}</xml>, 129 basic {Display = fn b => <xml>{[b]}</xml>,
86 Edit = fn s => <xml><ccheckbox source={s}/></xml>, 130 Edit = fn s => <xml><ccheckbox source={s}/></xml>,
87 Initialize = fn b => b, 131 Initialize = fn b => b,
132 InitializeNull = False,
133 IsNull = fn _ => False,
88 Parse = fn b => Some b} 134 Parse = fn b => Some b}
89 135
90 functor Foreign (M : sig 136 functor Foreign (M : sig
91 con row :: {Type} 137 con row :: {Type}
92 con t :: Type 138 con t :: Type
100 val render : $([nm = t] ++ row) -> string 146 val render : $([nm = t] ++ row) -> string
101 end) = struct 147 end) = struct
102 open M 148 open M
103 149
104 con global = list (t * string) 150 con global = list (t * string)
105 con input = source string * t * $row 151 con input = source string * option (t * $row)
106 152
107 val getChoices = List.mapQuery (SELECT * FROM tab AS T) 153 val getChoices = List.mapQuery (SELECT * FROM tab AS T)
108 (fn r => (r.T.nm, render r.T)) 154 (fn r => (r.T.nm, render r.T))
109 155
110 fun getChoice k = 156 fun getChoice k =
111 r <- oneRow (SELECT T.{{row}} FROM tab AS T WHERE T.{nm} = {[k]}); 157 r <- oneRow (SELECT T.{{row}} FROM tab AS T WHERE T.{nm} = {[k]});
112 return r.T 158 return r.T
113 159
114 val meta = 160 val meta : meta (global, M.t, input) =
115 {Initialize = getChoices, 161 {Initialize = getChoices,
116 Handlers = fn choices => 162 Handlers = fn choices =>
117 {Display = fn (_, k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>, 163 NonNull (
118 Edit = fn (s, k, _) => 164 {Display = fn (_, kr) => case kr of
165 None => error <xml>Unexpected Foreign null</xml>
166 | Some (k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>,
167 Edit = fn (s, kr) =>
119 <xml><cselect source={s}> 168 <xml><cselect source={s}>
120 {List.mapX (fn (k', rend) => 169 {List.mapX (fn (k', rend) =>
121 <xml><coption value={show k'} selected={k' = k}>{[rend]}</coption> 170 <xml><coption value={show k'} selected={case kr of
171 None => False
172 | Some (k, _) =>
173 k' = k}>{[rend]}</coption>
122 </xml>) 174 </xml>)
123 choices} 175 choices}
124 </cselect></xml>, 176 </cselect></xml>,
125 Initialize = fn k => s <- source (show k); 177 Initialize = fn k => s <- source (show k);
126 r <- rpc (getChoice k); 178 r <- rpc (getChoice k);
127 return (s, k, r), 179 return (s, Some (k, r)),
128 Parse = fn (s, _, _) => k <- signal s; return (read k)}} 180 Parse = fn (s, _) => k <- signal s; return (read k : option t)},
181 {Display = fn (_, kr) => case kr of
182 None => <xml>NULL</xml>
183 | Some (k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>,
184 Edit = fn (s, kr) =>
185 <xml><cselect source={s}>
186 <coption value="" selected={case kr of
187 None => True
188 | _ => False}>NULL</coption>
189 {List.mapX (fn (k', rend) =>
190 <xml><coption value={show k'} selected={case kr of
191 None => False
192 | Some (k, _) =>
193 k' = k}>{[rend]}</coption>
194 </xml>)
195 choices}
196 </cselect></xml>,
197 Initialize = fn k => case k of
198 None =>
199 s <- source "";
200 return (s, None)
201 | Some k =>
202 s <- source (show k);
203 r <- rpc (getChoice k);
204 return (s, Some (k, r)),
205 Parse = fn (s, _) => ks <- signal s;
206 return (case ks of
207 "" => Some None
208 | _ => case read ks : option t of
209 None => None
210 | Some k => Some (Some k))})}
129 end 211 end
130 end 212 end
131 213
132 con computedState = (unit, xbody) 214 con computedState = (unit, xbody)
133 fun computed [row] [t] (_ : show t) name (f : $row -> t) : colMeta row computedState = 215 fun computed [row] [t] (_ : show t) name (f : $row -> t) : colMeta row computedState =