summaryrefslogtreecommitdiff
path: root/demo
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-11-01 10:20:20 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-11-01 10:20:20 -0500
commite20e964083a048ad4cbb88cc1af3790694f51dfa (patch)
tree09a704610f44afd4ad023245a9f59d901c3c4345 /demo
parent1be7e54fa70a40b16164f69e7153ada0e4935994 (diff)
Bidding interface
Diffstat (limited to 'demo')
-rw-r--r--demo/more/bid.ur53
-rw-r--r--demo/more/bid.urs3
-rw-r--r--demo/more/conference.ur26
-rw-r--r--demo/more/conference.urp1
-rw-r--r--demo/more/conference.urs16
-rw-r--r--demo/more/conference1.ur4
-rw-r--r--demo/more/select.ur3
-rw-r--r--demo/more/select.urs1
8 files changed, 82 insertions, 25 deletions
diff --git a/demo/more/bid.ur b/demo/more/bid.ur
index 5bcaea3a..692f8e14 100644
--- a/demo/more/bid.ur
+++ b/demo/more/bid.ur
@@ -7,22 +7,51 @@ functor Make(M : Conference.INPUT) = struct
table assignment : {User : userId, Paper : paperId}
PRIMARY KEY (User, Paper)
- fun isOnPc id =
- ro <- oneOrNoRows1 (SELECT user.OnPc
- FROM user
- WHERE user.Id = {[id]});
- return (case ro of
- None => False
- | Some r => r.OnPc)
-
val linksForPc =
let
- fun bid () =
- me <- getLogin;
- return <xml>Bidding time!</xml>
+ fun yourBids () =
+ me <- getPcLogin;
+ ps <- queryX (SELECT paper.Id, paper.{{M.paper}}, bid.Interest
+ FROM paper LEFT JOIN bid ON bid.Paper = paper.Id
+ AND bid.User = {[me.Id]})
+ (fn r => <xml><entry>
+ <hidden{#Paper} value={show r.Paper.Id}/>
+ {useMore <xml><tr>
+ <td>{summarizePaper (r.Paper -- #Id)}</td>
+ <td><select{#Bid}>
+ {Select.selectChar ((#"-", "No") :: (#"_", "Maybe") :: (#"+", "Yes") :: [])
+ r.Bid.Interest}
+ </select></td>
+ </tr></xml>}
+ </entry></xml>);
+ return <xml><body>
+ <h1>Bid on papers</h1>
+
+ <form>
+ <subforms{#Papers}><table>
+ <tr> <th>Paper</th> <th>Your Bid</th> </tr>
+ {ps}
+ </table></subforms>
+ <submit value="Change" action={changeBids}/>
+ </form>
+ </body></xml>
+
+ and changeBids r =
+ me <- getPcLogin;
+ List.app (fn {Paper = p, Bid = b} =>
+ case b of
+ "" => return ()
+ | _ => let
+ val p = readError p
+ in
+ (dml (DELETE FROM bid WHERE Paper = {[p]} AND User = {[me.Id]});
+ dml (INSERT INTO bid (Paper, User, Interest)
+ VALUES ({[p]}, {[me.Id]}, {[String.sub b 0]})))
+ end) r.Papers;
+ yourBids ()
in
<xml>
- <li> <a link={bid ()}>Bid on papers</a></li>
+ <li> <a link={yourBids ()}>Bid on papers</a></li>
</xml>
end
diff --git a/demo/more/bid.urs b/demo/more/bid.urs
index 976d1ab6..f731f9ba 100644
--- a/demo/more/bid.urs
+++ b/demo/more/bid.urs
@@ -1,2 +1,3 @@
-functor Make (M : Conference.INPUT) : Conference.OUTPUT where con userId = M.userId
+functor Make (M : Conference.INPUT) : Conference.OUTPUT where con paper = M.paper
+ where con userId = M.userId
where con paperId = M.paperId
diff --git a/demo/more/conference.ur b/demo/more/conference.ur
index a80f1ab1..e810043b 100644
--- a/demo/more/conference.ur
+++ b/demo/more/conference.ur
@@ -1,5 +1,5 @@
signature INPUT = sig
- con paper :: {(Type * Type)}
+ con paper :: {Type}
constraint [Id, Document] ~ paper
type userId
@@ -10,14 +10,19 @@ signature INPUT = sig
type paperId
val paperId_inj : sql_injectable_prim paperId
- table paper : ([Id = paperId, Document = blob] ++ map fst paper)
+ val paperId_show : show paperId
+ val paperId_read : read paperId
+ table paper : ([Id = paperId, Document = blob] ++ paper)
PRIMARY KEY Id
val checkLogin : transaction (option {Id : userId, Nam : string, Chair : bool, OnPc : bool})
val getLogin : transaction {Id : userId, Nam : string, Chair : bool, OnPc : bool}
+ val getPcLogin : transaction {Id : userId, Nam : string, Chair : bool}
+ val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $paper -> xml ([Body] ++ ctx) [] []
end
signature OUTPUT = sig
+ con paper :: {Type}
type userId
type paperId
@@ -45,10 +50,11 @@ functor Make(M : sig
val reviewFolder : folder review
val submissionDeadline : time
- val summarizePaper : $(map fst paper) -> xbody
+ val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper) -> xml ([Body] ++ ctx) [] []
- functor Make (M : INPUT where con paper = paper)
- : OUTPUT where con userId = M.userId
+ functor Make (M : INPUT where con paper = map fst paper)
+ : OUTPUT where con paper = map fst paper
+ where con userId = M.userId
where con paperId = M.paperId
end) = struct
@@ -92,11 +98,20 @@ functor Make(M : sig
None => error <xml>You must be logged in to do that.</xml>
| Some r => return r
+ val getPcLogin =
+ r <- getLogin;
+ if r.OnPc then
+ return (r -- #OnPc)
+ else
+ error <xml>You are not on the PC.</xml>
+
structure O = M.Make(struct
val user = user
val paper = paper
val checkLogin = checkLogin
val getLogin = getLogin
+ val getPcLogin = getPcLogin
+ val summarizePaper = @@M.summarizePaper
end)
val checkOnPc =
@@ -195,6 +210,7 @@ functor Make(M : sig
{if me.OnPc then
<xml>
<li><a link={all ()}>All papers</a></li>
+ <li><a link={your ()}>Your papers</a></li>
{O.linksForPc}
</xml>
else
diff --git a/demo/more/conference.urp b/demo/more/conference.urp
index 3bc9156c..844baed9 100644
--- a/demo/more/conference.urp
+++ b/demo/more/conference.urp
@@ -8,4 +8,5 @@ bulkEdit
dnat
conference
conferenceFields
+select
bid
diff --git a/demo/more/conference.urs b/demo/more/conference.urs
index 226e9768..f9729851 100644
--- a/demo/more/conference.urs
+++ b/demo/more/conference.urs
@@ -1,5 +1,5 @@
signature INPUT = sig
- con paper :: {(Type * Type)}
+ con paper :: {Type}
constraint [Id, Document] ~ paper
type userId
@@ -10,14 +10,19 @@ signature INPUT = sig
type paperId
val paperId_inj : sql_injectable_prim paperId
- table paper : ([Id = paperId, Document = blob] ++ map fst paper)
+ val paperId_show : show paperId
+ val paperId_read : read paperId
+ table paper : ([Id = paperId, Document = blob] ++ paper)
PRIMARY KEY Id
val checkLogin : transaction (option {Id : userId, Nam : string, Chair : bool, OnPc : bool})
val getLogin : transaction {Id : userId, Nam : string, Chair : bool, OnPc : bool}
+ val getPcLogin : transaction {Id : userId, Nam : string, Chair : bool}
+ val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $paper -> xml ([Body] ++ ctx) [] []
end
signature OUTPUT = sig
+ con paper :: {Type}
type userId
type paperId
@@ -43,10 +48,11 @@ functor Make(M : sig
val reviewFolder : folder review
val submissionDeadline : time
- val summarizePaper : $(map fst paper) -> xbody
+ val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper) -> xml ([Body] ++ ctx) [] []
- functor Make (M : INPUT where con paper = paper)
- : OUTPUT where con userId = M.userId
+ functor Make (M : INPUT where con paper = map fst paper)
+ : OUTPUT where con paper = map fst paper
+ where con userId = M.userId
where con paperId = M.paperId
end) : sig
diff --git a/demo/more/conference1.ur b/demo/more/conference1.ur
index c51904e5..f8272b4f 100644
--- a/demo/more/conference1.ur
+++ b/demo/more/conference1.ur
@@ -7,9 +7,9 @@ open Conference.Make(struct
val submissionDeadline = readError "2009-11-22 23:59:59"
- fun summarizePaper r = cdata r.Title
+ fun summarizePaper [ctx] [[Body] ~ ctx] r = cdata r.Title
- functor Make (M : Conference.INPUT where con paper = _) = struct
+ functor Make (M : Conference.INPUT where con paper = [Title = string, Abstract = string]) = struct
open Bid.Make(M)
end
end)
diff --git a/demo/more/select.ur b/demo/more/select.ur
new file mode 100644
index 00000000..17cff4dd
--- /dev/null
+++ b/demo/more/select.ur
@@ -0,0 +1,3 @@
+fun selectChar choices current =
+ List.mapX (fn (ch, label) =>
+ <xml><option value={String.str ch} selected={current = Some ch}>{[label]}</option></xml>) choices
diff --git a/demo/more/select.urs b/demo/more/select.urs
new file mode 100644
index 00000000..f9208b91
--- /dev/null
+++ b/demo/more/select.urs
@@ -0,0 +1 @@
+val selectChar : list (char * string) -> option char -> xml select [] []
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-28 05:15:37 +0000