Saving paper decisions

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] =>