-
Notifications
You must be signed in to change notification settings - Fork 16
/
choicesFromPreferences.ur
270 lines (253 loc) · 15.5 KB
/
choicesFromPreferences.ur
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
open Bootstrap
functor Make(M : sig
con choice :: Name
type choiceT
con choiceR :: {Type}
constraint [choice] ~ choiceR
table choice : ([choice = choiceT] ++ choiceR)
val show_choiceT : show choiceT
val read_choiceT : read choiceT
val eq_choiceT : eq choiceT
val inj_choiceT : sql_injectable_prim choiceT
con user :: Name
con slot :: Name
con preferred :: Name
constraint [user] ~ [slot]
constraint [user, slot] ~ [preferred]
table pref : {user : string, slot : choiceT, preferred : bool}
con item :: Name
type itemT
con ichoice :: Name
con users :: {Unit}
con itemR :: {(Type * Type)}
constraint [item] ~ [ichoice]
constraint [item, ichoice] ~ users
constraint [item, ichoice] ~ itemR
constraint users ~ itemR
table item : ([item = itemT, ichoice = option choiceT] ++ mapU (option string) users ++ map fst itemR)
val fl : folder users
val show_itemT : show itemT
val eq_itemT : eq itemT
val inj_itemT : sql_injectable_prim itemT
val nullify_itemR : $(map (fn p => nullify p.1 p.2) itemR)
val labels : $(mapU string users)
val authorize : transaction bool
end) = struct
open M
type a = {Choices : list (choiceT * source int),
Items : list {Item : itemT,
Users : $(mapU (option string) users),
Choices : list {Choice : choiceT,
Preferred : int,
Available : int,
NowChosen : source int
(* How many times is it used so far? *)},
Choice : option choiceT}}
(* Helper function to build an SQL expression indicating that one column
* equals at least one of another sets of columns *)
fun multijoin [r1 ::: {Type}] [r2 ::: {Type}] [r ::: {{Type}}]
[agg ::: {{Type}}] [exps ::: {Type}] [t ::: Type]
[t1 :: Name] [col :: Name] [t2 :: Name] [cols :: {Unit}]
[[col] ~ r1] [cols ~ r2] [[t1] ~ [t2]] [[t1, t2] ~ r]
(fl : folder cols) (_ : sql_injectable_prim t)
: sql_exp ([t1 = [col = t] ++ r1,
t2 = mapU (option t) cols ++ r2] ++ r) agg exps bool =
@fold [fn cols => others :: {Unit} -> [cols ~ others] => [cols ++ others ~ r2]
=> sql_exp ([t1 = [col = t] ++ r1,
t2 = mapU (option t) (cols ++ others) ++ r2]
++ r) agg exps bool]
(fn [nm ::_] [u ::_] [rest ::_] [[nm] ~ rest]
(acc : others :: {Unit} -> [rest ~ others] => [rest ++ others ~ r2]
=> sql_exp ([t1 = [col = t] ++ r1,
t2 = mapU (option t) (rest ++ others) ++ r2]
++ r) agg exps bool)
[others :: {Unit}] [[nm = u] ++ rest ~ others] [[nm = u] ++ rest ++ others ~ r2] =>
(WHERE {acc [[nm = u] ++ others]}
OR {sql_nullable (SQL {{t1}}.{col})} = {{t2}}.{nm}))
(fn [others ::_] [[] ~ others] [others ~ r2] => (WHERE FALSE)) fl [[]] ! !
type a0 = list {Item : itemT,
Users : $(mapU (option string) users),
Choice : option choiceT,
Choices : list {Choice : choiceT,
Available : int,
Preferred : int}}
val create =
let
fun items r (cs : a0) =
return (case cs of
[] =>
{Item = r.Item.item,
Users = r.Item -- item -- ichoice,
Choice = r.Item.ichoice,
Choices = {Choice = r.Pref.slot,
Available = 1,
Preferred = if r.Pref.preferred then 1 else 0} :: []} :: []
| c :: cs' =>
if c.Item = r.Item.item then
{Item = c.Item,
Users = r.Item -- item -- ichoice,
Choice = c.Choice,
Choices = case c.Choices of
[] => error <xml>Accumulator has choice-free item!</xml>
| ch :: chs =>
if ch.Choice = r.Pref.slot then
{Choice = ch.Choice,
Available = ch.Available + 1,
Preferred = if r.Pref.preferred then
ch.Preferred + 1
else
ch.Preferred} :: chs
else
{Choice = r.Pref.slot,
Available = 1,
Preferred = if r.Pref.preferred then 1 else 0}
:: c.Choices} :: cs'
else
{Item = r.Item.item,
Users = r.Item -- item -- ichoice,
Choice = r.Item.ichoice,
Choices = {Choice = r.Pref.slot,
Available = 1,
Preferred = if r.Pref.preferred then 1 else 0} :: []} :: cs)
in
items <- query (SELECT item.{item}, item.{{mapU (option string) users}}, item.{ichoice}, pref.{slot}, pref.{preferred}
FROM item JOIN pref
ON {@multijoin [#Pref] [user]
[#Item] [users] ! ! ! ! fl _}
ORDER BY item.{item} DESC, pref.{preferred}, pref.{slot} DESC)
items [];
choices <- List.mapQueryM (SELECT choice.{choice}, COUNT(item.{item}) AS Count
FROM {{@@sql_left_join [[]] [[Choice = _]]
[[Item = [item = (itemT, option itemT), ichoice = (option choiceT, option choiceT)]
++ mapU (option string, option string) users ++ itemR]]
! ! !
{Item = nullify_itemR
++ @map0 [fn _ => nullify (option string) (option string)]
(fn [u ::_] => _) fl
++ _}
(FROM choice) (FROM item)
(WHERE item.{ichoice} = {sql_nullable (SQL choice.{choice})})}}
GROUP BY choice.{choice})
(fn r =>
c <- source r.Count;
return (r.Choice.choice, c));
return {Choices = choices,
Items = List.mp (fn r =>
r -- #Choices
++ {Choices = List.mp (fn ch =>
ch ++ {NowChosen =
case List.assoc ch.Choice choices of
None => error <xml>Missing choice in initialization!</xml>
| Some s => s})
(List.sort (fn ch1 ch2 => ch1.Preferred < ch2.Preferred
|| (ch1.Preferred = ch2.Preferred
&& ch1.Available < ch2.Available)) r.Choices)})
items}
end
fun onload _ = return ()
fun stars n =
if n <= 0 then
""
else
"*" ^ stars (n - 1)
val numUsers = @fold [fn _ => int]
(fn [nm ::_] [u ::_] [r ::_] [[nm] ~ r] acc => acc + 1)
0 fl
fun save cs =
auth <- authorize;
if not auth then
error <xml>Access denied</xml>
else
List.app (fn (i, c) => dml (UPDATE item
SET {ichoice} = {[c]}
WHERE T.{item} = {[i]})) cs
fun render _ a = <xml>
<active code={items <- List.mapM (fn i =>
s <- source (case i.Choice of
None => ""
| Some v => show v);
st <- source i.Choice;
return (i -- #Choice ++ {Choice = s, StashedChoice = st})) a.Items;
return <xml>
<button class="btn btn-primary"
onclick={fn _ =>
cs <- List.mapPartialM (fn i =>
c <- get i.Choice;
return (if c = "" then
None
else
Some (i.Item, readError c)))
items;
rpc (save cs)}>
Save
</button>
<table class="bs-table">
<thead><tr>
<th/>
{@mapUX [string] [tr]
(fn [nm ::_] [r ::_] [[nm] ~ r] l => <xml><th>{[l]}</th></xml>)
fl labels}
<th>Choice</th>
</tr></thead>
<tbody>
{List.mapX (fn i => <xml><tr>
<td>{[i.Item]}</td>
{@mapUX [option string] [tr]
(fn [nm ::_] [r ::_] [[nm] ~ r] l => <xml><td>{[l]}</td></xml>)
fl i.Users}
<td><dyn signal={chs <- List.mapM (fn ch =>
chosen <- signal ch.NowChosen;
return (ch.Choice,
show ch.Choice
^ stars ch.Preferred
^ (if ch.Available < numUsers then
" (" ^ show (numUsers - ch.Available) ^ " unavailable!)"
else
"")
^ (if chosen = 0 then
""
else
" [chosen for " ^ show chosen ^ "]"))) i.Choices;
return <xml>
<cselect source={i.Choice}
onchange={old <- get i.StashedChoice;
new <- get i.Choice;
new <- return (case new of
"" => None
| _ => Some (readError new));
set i.StashedChoice new;
(case old of
None => return ()
| Some old =>
List.app (fn (ch, c) =>
if ch = old then
n <- get c;
set c (n - 1)
else
return ()) a.Choices);
(case new of
None => return ()
| Some new =>
List.app (fn (ch, c) =>
if ch = new then
n <- get c;
set c (n + 1)
else
return ()) a.Choices)}>
<coption value="">unchosen</coption>
{List.mapX (fn (ch, s) => <xml><coption value={show ch}>{[s]}</coption></xml>) chs}
</cselect>
</xml>}/></td>
</tr></xml>) items}
</tbody>
</table>
</xml>}/>
</xml>
fun notification _ _ = <xml></xml>
fun buttons _ _ = <xml></xml>
val ui = {Create = create,
Onload = onload,
Render = render,
Notification = notification,
Buttons = buttons}
end