Mercurial > urweb

annotate demo/more/bid.ur @ 1261:04e9885cbe56

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