summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--demo/more/conference.ur9
-rw-r--r--demo/more/conference.urs8
-rw-r--r--demo/more/conference1.ur13
-rw-r--r--demo/more/conferenceFields.ur1
-rw-r--r--demo/more/conferenceFields.urs1
-rw-r--r--demo/more/decision.ur58
-rw-r--r--demo/more/decision.urs3
-rw-r--r--lib/ur/top.ur4
-rw-r--r--lib/ur/top.urs6
9 files changed, 71 insertions, 32 deletions
diff --git a/demo/more/conference.ur b/demo/more/conference.ur
index 8f6dff2a..bf8e364a 100644
--- a/demo/more/conference.ur
+++ b/demo/more/conference.ur
@@ -16,6 +16,11 @@ signature INPUT = sig
table paper : ([Id = paperId, Document = blob] ++ paper)
PRIMARY KEY Id
+ con review :: {Type}
+ constraint [Paper, User] ~ review
+ table review : ([Paper = paperId, User = userId] ++ review)
+ PRIMARY KEY (Paper, User)
+
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}
@@ -63,7 +68,8 @@ functor Make(M : sig
val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper ++ paperPrivate)
-> xml ([Body] ++ ctx) [] []
- functor Make (M : INPUT where con paper = map fst paper ++ paperPrivate)
+ functor Make (M : INPUT where con paper = map fst paper ++ paperPrivate
+ where con review = map fst review)
: OUTPUT where con paper = map fst paper ++ paperPrivate
where con userId = M.userId
where con paperId = M.paperId
@@ -126,6 +132,7 @@ functor Make(M : sig
structure O = M.Make(struct
val user = user
val paper = paper
+ val review = review
val checkLogin = checkLogin
val getLogin = getLogin
val getPcLogin = getPcLogin
diff --git a/demo/more/conference.urs b/demo/more/conference.urs
index 8ecb1692..de35ad05 100644
--- a/demo/more/conference.urs
+++ b/demo/more/conference.urs
@@ -16,6 +16,11 @@ signature INPUT = sig
table paper : ([Id = paperId, Document = blob] ++ paper)
PRIMARY KEY Id
+ con review :: {Type}
+ constraint [Paper, User] ~ review
+ table review : ([Paper = paperId, User = userId] ++ review)
+ PRIMARY KEY (Paper, User)
+
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}
@@ -61,7 +66,8 @@ functor Make(M : sig
val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper ++ paperPrivate)
-> xml ([Body] ++ ctx) [] []
- functor Make (M : INPUT where con paper = map fst paper ++ paperPrivate)
+ functor Make (M : INPUT where con paper = map fst paper ++ paperPrivate
+ where con review = map fst review)
: OUTPUT where con paper = map fst paper ++ paperPrivate
where con userId = M.userId
where con paperId = M.paperId
diff --git a/demo/more/conference1.ur b/demo/more/conference1.ur
index a365efa8..646ba489 100644
--- a/demo/more/conference1.ur
+++ b/demo/more/conference1.ur
@@ -10,16 +10,23 @@ open Conference.Make(struct
val submissionDeadline = readError "2009-11-22 23:59:59"
fun summarizePaper [ctx] [[Body] ~ ctx] r = txt r.Title
+ functor Make (M : Conference.INPUT where con paper = _
+ where con review = _) = struct
+ open M
+
+ fun status [ctx] [[Body] ~ ctx] r =
+ queryX (SELECT review.Rating
+ FROM review
+ WHERE review.Paper = {[r.Id]})
+ (fn r => <xml>{[r.Review.Rating]}; </xml>)
- functor Make (M : Conference.INPUT where con paper = _) = struct
open Conference.Join(struct
structure O1 = Bid.Make(M)
structure O2 = Decision.Make(struct
con paperOther = _
open M
- fun status [ctx] [[Body] ~ ctx]
- r = <xml>!</xml>
+ val status = @@status
end)
end)
end
diff --git a/demo/more/conferenceFields.ur b/demo/more/conferenceFields.ur
index d22bd877..18387c96 100644
--- a/demo/more/conferenceFields.ur
+++ b/demo/more/conferenceFields.ur
@@ -22,3 +22,4 @@ fun dropdown name opts = {Nam = name,
Parse = charIn,
Inject = _}
+val dropdown_show = _
diff --git a/demo/more/conferenceFields.urs b/demo/more/conferenceFields.urs
index 04cf902f..3a034770 100644
--- a/demo/more/conferenceFields.urs
+++ b/demo/more/conferenceFields.urs
@@ -4,3 +4,4 @@ val commentsForAuthors : Meta.meta (string, string)
con dropdown :: (Type * Type)
val dropdown : string -> list char -> Meta.meta dropdown
+val dropdown_show : show dropdown.1
diff --git a/demo/more/decision.ur b/demo/more/decision.ur
index b93658ee..efd1b9c7 100644
--- a/demo/more/decision.ur
+++ b/demo/more/decision.ur
@@ -12,37 +12,53 @@ functor Make(M : sig
include Conference.INPUT
where con paper = [Decision = option bool] ++ paperOther
- val status : ctx ::: {Unit} -> [[Body] ~ ctx] => $paperOther -> xml ([Body] ++ ctx) [] []
+ val status : ctx ::: {Unit} -> [[Body] ~ ctx] => $([Id = paperId] ++ paperOther)
+ -> transaction (xml ([Body] ++ ctx) [] [])
end) = struct
open M
val linksForChair =
let
fun makeDecisions () =
- ps <- queryX (SELECT paper.Id, paper.Decision, paper.{{M.paperOther}}
- FROM paper
- ORDER BY paper.Id)
- (fn r => <xml><tr>
- <td>{useMore (summarizePaper (r.Paper -- #Id))}</td>
- <td>{useMore (status (r.Paper -- #Id -- #Decision))}</td>
- <td><entry>
- <hidden{#Paper} value={show r.Paper.Id}/>
- <select{#Decision}>
- <option selected={r.Paper.Decision = None}>?</option>
- <option selected={r.Paper.Decision = Some True}>Accept</option>
- <option selected={r.Paper.Decision = Some False}>Reject</option>
- </select></entry></td>
- </tr></xml>);
+ ps <- queryX' (SELECT paper.Id, paper.Decision, paper.{{M.paperOther}}
+ FROM paper
+ ORDER BY paper.Id)
+ (fn r => st <- status (r.Paper -- #Decision);
+ return <xml><tr>
+ <td>{useMore (summarizePaper (r.Paper -- #Id))}</td>
+ <td>{useMore st}</td>
+ <td><entry>
+ <hidden{#Paper} value={show r.Paper.Id}/>
+ <select{#Decision}>
+ <option selected={r.Paper.Decision = None}>?</option>
+ <option selected={r.Paper.Decision = Some True}>Accept</option>
+ <option selected={r.Paper.Decision = Some False}>Reject</option>
+ </select></entry></td>
+ </tr></xml>);
return <xml><body>
<h1>Make acceptance decisions</h1>
- <form><subforms{#Papers}>
- <table>
- <tr> <th>Paper</th> <th>Status</th> <th>Decision</th> </tr>
- {ps}
- </table>
- </subforms></form>
+ <form>
+ <subforms{#Papers}>
+ <table>
+ <tr> <th>Paper</th> <th>Status</th> <th>Decision</th> </tr>
+ {ps}
+ </table>
+ </subforms>
+ <submit value="Save" action={saveDecisions}/>
+ </form>
</body></xml>
+
+ and saveDecisions r =
+ List.app (fn {Paper = pid, Decision = dec} =>
+ dml (UPDATE paper
+ SET Decision = {[case dec of
+ "?" => None
+ | "Accept" => Some True
+ | "Reject" => Some False
+ | _ => error <xml>Invalid decision code</xml>]}
+ WHERE Id = {[readError pid]})) r.Papers;
+ makeDecisions ()
in
<xml>
<li><a link={makeDecisions ()}>Make acceptance decisions</a></li>
diff --git a/demo/more/decision.urs b/demo/more/decision.urs
index 9ae585b0..e33403cb 100644
--- a/demo/more/decision.urs
+++ b/demo/more/decision.urs
@@ -6,7 +6,8 @@ functor Make (M : sig
include Conference.INPUT
where con paper = [Decision = option bool] ++ paperOther
- val status : ctx ::: {Unit} -> [[Body] ~ ctx] => $paperOther -> xml ([Body] ++ ctx) [] []
+ val status : ctx ::: {Unit} -> [[Body] ~ ctx] => $([Id = paperId] ++ paperOther)
+ -> transaction (xml ([Body] ++ ctx) [] [])
end) : Conference.OUTPUT where con paper = [Decision = option bool] ++ M.paperOther
where con userId = M.userId
where con paperId = M.paperId
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index 10b3f711..423507b5 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -224,10 +224,10 @@ fun queryX [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Ty
(fn fs acc => return <xml>{acc}{f fs}</xml>)
<xml/>
-fun queryX' [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}]
+fun queryX' [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}]
[tables ~ exps] (q : sql_query tables exps)
(f : $(exps ++ map (fn fields :: {Type} => $fields) tables)
- -> transaction (xml ctx [] [])) =
+ -> transaction (xml ctx inp [])) =
query q
(fn fs acc =>
r <- f fs;
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index 80d402b1..6470d7d7 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -132,12 +132,12 @@ val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> inp :::
-> xml ctx inp [])
-> transaction (xml ctx inp [])
-val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
+val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type}
-> [tables ~ exps] =>
sql_query tables exps
-> ($(exps ++ map (fn fields :: {Type} => $fields) tables)
- -> transaction (xml ctx [] []))
- -> transaction (xml ctx [] [])
+ -> transaction (xml ctx inp []))
+ -> transaction (xml ctx inp [])
val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type}
-> [tables ~ exps] =>
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 21:38:23 +0000