Mercurial > urweb

annotate demo/more/bid.ur @ 1028:8b7971e74335

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Preload current assignment status
author Adam Chlipala <adamc@hcoop.net>
date Mon, 02 Nov 2009 14:14:32 -0500
parents be1aec7333a5
children 6bcc1020d5cd
rev   line source
adamc@1022 1 functor Make(M : Conference.INPUT) = struct
adamc@1022 2 open M
adamc@1022 3
adamc@1022 4 table bid : {User : userId, Paper : paperId, Interest : char}
adamc@1022 5 PRIMARY KEY (User, Paper)
adamc@1022 6
adamc@1022 7 table assignment : {User : userId, Paper : paperId}
adamc@1022 8 PRIMARY KEY (User, Paper)
adamc@1022 9
adamc@1025 10 fun intOut ch =
adamc@1025 11 case ch of
adamc@1025 12 #"_" => "Maybe"
adamc@1025 13 | #"-" => "No"
adamc@1025 14 | #"+" => "Yes"
adamc@1025 15 | _ => error <xml>Bid: Invalid Interest code</xml>
adamc@1025 16
adamc@1025 17 val linksForChair =
adamc@1025 18 let
adamc@1025 19 fun assignPapers () =
adamc@1028 20 tup <- query (SELECT paper.Id, paper.{{M.paper}}, user.Id, user.Nam, bid.Interest, assignment.User
adamc@1025 21 FROM paper JOIN bid ON bid.Paper = paper.Id
adamc@1025 22 JOIN user ON bid.User = user.Id
adamc@1028 23 LEFT JOIN assignment ON assignment.Paper = paper.Id AND assignment.User = user.Id
adamc@1025 24 ORDER BY paper.Id, bid.Interest, user.Nam)
adamc@1027 25 (fn r (paper, int, acc, ints, papers) =>
adamc@1027 26 if (case paper of None => False | Some r' => r'.Id = r.Paper.Id) then
adamc@1025 27 if int = r.Bid.Interest then
adamc@1028 28 return (paper, int, (r.User.Id, r.User.Nam, Option.isSome r.Assignment.User) :: acc,
adamc@1028 29 ints, papers)
adamc@1025 30 else
adamc@1028 31 return (paper, r.Bid.Interest, (r.User.Id, r.User.Nam,
adamc@1028 32 Option.isSome r.Assignment.User) :: [],
adamc@1025 33 (int, acc) :: ints, papers)
adamc@1025 34 else
adamc@1027 35 return (Some r.Paper, r.Bid.Interest,
adamc@1028 36 (r.User.Id, r.User.Nam, Option.isSome r.Assignment.User) :: [], [],
adamc@1027 37 case paper of
adamc@1025 38 None => papers
adamc@1027 39 | Some r => (r.Id, r -- #Id, (int, acc) :: ints) :: papers))
adamc@1025 40 (None, #" ", [], [], []);
adamc@1025 41 let
adamc@1025 42 val papersL = case tup.1 of
adamc@1027 43 Some r => (r.Id, r -- #Id, (tup.2, tup.3) :: tup.4) :: tup.5
adamc@1027 44 | None => []
adamc@1025 45
adamc@1027 46 fun makePapers () = List.mapM (fn (pid, extra, ints) =>
adamc@1025 47 ints <- List.mapM (fn (int, users) =>
adamc@1025 48 cg <- CheckGroup.create
adamc@1025 49 (List.mp
adamc@1028 50 (fn (id, nam, sel) =>
adamc@1028 51 (id, txt nam, sel))
adamc@1025 52 users);
adamc@1025 53 ex <- Expandable.create
adamc@1025 54 (CheckGroup.render cg);
adamc@1025 55 return (int, cg, ex)) ints;
adamc@1027 56 return (pid, extra, ints)) papersL
adamc@1027 57
adamc@1027 58 fun saveAssignment ls =
adamc@1027 59 dml (DELETE FROM assignment WHERE TRUE);
adamc@1027 60 List.app (fn (pid, uids) =>
adamc@1027 61 List.app (fn uid => dml (INSERT INTO assignment (Paper, User)
adamc@1027 62 VALUES ({[pid]}, {[uid]}))) uids) ls
adamc@1025 63 in
adamc@1025 64 papers <- source [];
adamc@1025 65
adamc@1025 66 return <xml><body onload={papersL <- makePapers ();
adamc@1025 67 set papers papersL}>
adamc@1025 68 <h1>Assign papers</h1>
adamc@1025 69
adamc@1025 70 <dyn signal={papers <- signal papers;
adamc@1027 71 return (List.mapX (fn (pid, extra, ints) => <xml>
adamc@1025 72 <hr/>
adamc@1027 73 #{[pid]}: {summarizePaper extra}:
adamc@1025 74 <dyn signal={n <- List.foldl (fn (_, cg, _) total =>
adamc@1025 75 this <- CheckGroup.selected cg;
adamc@1025 76 total <- total;
adamc@1025 77 return (List.length this + total)) (return 0) ints;
adamc@1025 78 return (txt n)}/><br/>
adamc@1025 79
adamc@1025 80 {List.mapX (fn (int, _, ex) => <xml>
adamc@1025 81 {[intOut int]}: {Expandable.render ex}
adamc@1025 82 </xml>) ints}
adamc@1025 83 </xml>) papers)}/>
adamc@1027 84
adamc@1027 85 <br/>
adamc@1027 86 <button value="Save" onclick={papers <- get papers;
adamc@1027 87 ls <- List.mapM (fn (pid, _, ints) =>
adamc@1027 88 ints <- List.mapM (fn (_, cg, _) =>
adamc@1027 89 current
adamc@1027 90 (CheckGroup.selected cg))
adamc@1027 91 ints;
adamc@1027 92 return (pid, List.foldl List.append [] ints))
adamc@1027 93 papers;
adamc@1027 94 rpc (saveAssignment ls)}/>
adamc@1025 95 </body></xml>
adamc@1025 96 end
adamc@1025 97 in
adamc@1025 98 <xml>
adamc@1025 99 <li><a link={assignPapers ()}> Assign papers to people</a></li>
adamc@1025 100 </xml>
adamc@1025 101 end
adamc@1025 102
adamc@1022 103 val linksForPc =
adamc@1022 104 let
adamc@1023 105 fun yourBids () =
adamc@1023 106 me <- getPcLogin;
adamc@1023 107 ps <- queryX (SELECT paper.Id, paper.{{M.paper}}, bid.Interest
adamc@1023 108 FROM paper LEFT JOIN bid ON bid.Paper = paper.Id
adamc@1023 109 AND bid.User = {[me.Id]})
adamc@1025 110 (fn r => <xml><tr>
adamc@1025 111 <td>{useMore (summarizePaper (r.Paper -- #Id))}</td>
adamc@1025 112 <td><entry>
adamc@1025 113 <hidden{#Paper} value={show r.Paper.Id}/>
adamc@1025 114 <select{#Bid}>
adamc@1025 115 {useMore (Select.selectChar ((#"-", "No") :: (#"_", "Maybe") :: (#"+", "Yes") :: [])
adamc@1025 116 r.Bid.Interest)}
adamc@1025 117 </select></entry></td>
adamc@1025 118 </tr></xml>);
adamc@1023 119 return <xml><body>
adamc@1023 120 <h1>Bid on papers</h1>
adamc@1023 121
adamc@1023 122 <form>
adamc@1023 123 <subforms{#Papers}><table>
adamc@1023 124 <tr> <th>Paper</th> <th>Your Bid</th> </tr>
adamc@1023 125 {ps}
adamc@1023 126 </table></subforms>
adamc@1023 127 <submit value="Change" action={changeBids}/>
adamc@1023 128 </form>
adamc@1023 129 </body></xml>
adamc@1023 130
adamc@1023 131 and changeBids r =
adamc@1023 132 me <- getPcLogin;
adamc@1023 133 List.app (fn {Paper = p, Bid = b} =>
adamc@1023 134 case b of
adamc@1023 135 "" => return ()
adamc@1023 136 | _ => let
adamc@1023 137 val p = readError p
adamc@1023 138 in
adamc@1023 139 (dml (DELETE FROM bid WHERE Paper = {[p]} AND User = {[me.Id]});
adamc@1023 140 dml (INSERT INTO bid (Paper, User, Interest)
adamc@1023 141 VALUES ({[p]}, {[me.Id]}, {[String.sub b 0]})))
adamc@1023 142 end) r.Papers;
adamc@1023 143 yourBids ()
adamc@1022 144 in
adamc@1022 145 <xml>
adamc@1023 146 <li> <a link={yourBids ()}>Bid on papers</a></li>
adamc@1022 147 </xml>
adamc@1022 148 end
adamc@1022 149
adamc@1022 150 con yourPaperTables = [Assignment = _]
adamc@1022 151 constraint [Paper] ~ yourPaperTables
adamc@1022 152 fun joinYourPaper [tabs] [paper] [[Paper] ~ tabs] [[Paper] ~ _] [tabs ~ yourPaperTables] [[Id] ~ paper]
adamc@1027 153 (uid : userId) (fi : sql_from_items ([Paper = [Id = paperId] ++ paper] ++ tabs)) =
adamc@1027 154 sql_inner_join fi (sql_from_table [#Assignment] assignment)
adamc@1027 155 (WHERE Paper.Id = Assignment.Paper AND Assignment.User = {[uid]})
adamc@1022 156 end