# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1257194886 18000
# Node ID 6bcc1020d5cd1c0a25f81fc0127d323cb5dc7c99
# Parent  53a22f46f3776bb670e9148ebe18e6bdf7263722
Start of Decision

diff -r 53a22f46f377 -r 6bcc1020d5cd demo/more/bid.ur
--- a/demo/more/bid.ur	Mon Nov 02 14:22:29 2009 -0500
+++ b/demo/more/bid.ur	Mon Nov 02 15:48:06 2009 -0500
@@ -1,3 +1,5 @@
+con fields userId paperId = [User = userId, Paper = paperId]
+
 functor Make(M : Conference.INPUT) = struct
     open M
 
diff -r 53a22f46f377 -r 6bcc1020d5cd demo/more/bid.urs
--- a/demo/more/bid.urs	Mon Nov 02 14:22:29 2009 -0500
+++ b/demo/more/bid.urs	Mon Nov 02 15:48:06 2009 -0500
@@ -1,3 +1,7 @@
+con fields :: Type -> Type -> {Type}
+
 functor Make (M : Conference.INPUT) : Conference.OUTPUT where con paper = M.paper
                                                         where con userId = M.userId
                                                         where con paperId = M.paperId
+                                                        where con yourPaperTables = [Assignment
+                                                                                     = fields M.userId M.paperId]
diff -r 53a22f46f377 -r 6bcc1020d5cd demo/more/conference.ur
--- a/demo/more/conference.ur	Mon Nov 02 14:22:29 2009 -0500
+++ b/demo/more/conference.ur	Mon Nov 02 15:48:06 2009 -0500
@@ -45,19 +45,26 @@
 functor Make(M : sig
                  con paper :: {(Type * Type)}
                  constraint [Id, Document, Authors] ~ paper
-                 val paper : $(map meta paper)
+                 val paper : $(map Meta.meta paper)
                  val paperFolder : folder paper
 
+                 con paperPrivate :: {Type}
+                 constraint [Id, Document, Authors] ~ paperPrivate
+                 constraint paper ~ paperPrivate
+                 val paperPrivate : $(map Meta.private paperPrivate)
+                 val paperPrivateFolder : folder paperPrivate
+
                  con review :: {(Type * Type)}
                  constraint [Paper, User] ~ review
-                 val review : $(map meta review)
+                 val review : $(map Meta.meta review)
                  val reviewFolder : folder review
 
                  val submissionDeadline : time
-                 val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper) -> xml ([Body] ++ ctx) [] []
+                 val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper ++ paperPrivate)
+                                                                          -> xml ([Body] ++ ctx) [] []
 
-                 functor Make (M : INPUT where con paper = map fst paper)
-                         : OUTPUT where con paper = map fst paper
+                 functor Make (M : INPUT where con paper = map fst paper ++ paperPrivate)
+                         : OUTPUT where con paper = map fst paper ++ paperPrivate
                                   where con userId = M.userId
                                   where con paperId = M.paperId
              end) = struct
@@ -67,7 +74,7 @@
           CONSTRAINT Nam UNIQUE Nam
     sequence userId
 
-    con paper = [Id = int, Document = blob] ++ map fst M.paper
+    con paper = [Id = int, Document = blob] ++ map fst M.paper ++ M.paperPrivate
     table paper : paper
           PRIMARY KEY Id
     sequence paperId
@@ -254,7 +261,8 @@
                 else
                     id <- nextval paperId;
                     dml (insert paper ({Id = sql_inject id, Document = sql_inject (fileData r.Document)}
-                                           ++ ensql M.paper (r -- #Authors -- #Document) M.paperFolder));
+                                           ++ ensql M.paper (r -- #Authors -- #Document) M.paperFolder
+                                           ++ initialize M.paperPrivate M.paperPrivateFolder));
                     List.app (fn uid =>
                                  case uid of
                                      None => error <xml>Impossible empty uid!</xml>
@@ -287,10 +295,12 @@
             </body></xml>
         end
 
-    and listPapers [tabs] [[Paper] ~ tabs] (q : sql_query ([Paper = [Id = int] ++ map fst M.paper] ++ tabs) []) =
+    and listPapers [tabs] [[Paper] ~ tabs]
+                   (q : sql_query ([Paper = [Id = int] ++ map fst M.paper ++ M.paperPrivate] ++ tabs) []) =
         checkOnPc;
         ps <- queryX q
-                     (fn r => <xml><li><a link={one r.Paper.Id}>{M.summarizePaper (r.Paper -- #Id)}</a></li></xml>);
+                     (fn r => <xml><li><a link={one r.Paper.Id}>{M.summarizePaper (r.Paper -- #Id)}</a>
+                     </li></xml>);
         return <xml><body>
           <h1>All Papers</h1>
           
@@ -301,7 +311,7 @@
 
     and all () =
         checkOnPc;
-        listPapers (SELECT paper.Id, paper.{{map fst M.paper}} FROM paper)
+        listPapers (SELECT paper.Id, paper.{{map fst M.paper ++ M.paperPrivate}} FROM paper)
 
     and your () =
         me <- getLogin;
@@ -310,7 +320,10 @@
                                                   Where = (WHERE TRUE),
                                                   GroupBy = sql_subset_all [_],
                                                   Having = (WHERE TRUE),
-                                                  SelectFields = sql_subset [[Paper = ([Id = _] ++ map fst M.paper, _)]
+                                                  SelectFields = sql_subset [[Paper =
+                                                                              ([Id = _]
+                                                                                   ++ map fst M.paper
+                                                                                   ++ M.paperPrivate, _)]
                                                                                  ++ map (fn ts => ([], ts))
                                                                                             O.yourPaperTables],
                                                   SelectExps = {}},
@@ -412,3 +425,28 @@
           | Some r => returnBlob r.Paper.Document (blessMime "application/pdf")
 
 end
+
+
+functor Join(M : sig
+                 structure O1 : OUTPUT
+
+                 structure O2 : OUTPUT where con paper = O1.paper
+                                       where con userId = O1.userId
+                                       where con paperId = O1.paperId
+
+                 constraint O1.yourPaperTables ~ O2.yourPaperTables
+             end)
+        = struct
+            open M
+            open O1
+
+            val linksForPc = <xml>{O1.linksForPc}{O2.linksForPc}</xml>
+            val linksForChair = <xml>{O1.linksForChair}{O2.linksForChair}</xml>
+
+            con yourPaperTables = O1.yourPaperTables ++ O2.yourPaperTables
+            constraint [Paper] ~ yourPaperTables
+
+            fun joinYourPaper [tabs] [paper] [[Paper] ~ tabs] [[Paper] ~ _] [tabs ~ yourPaperTables] [[Id] ~ paper]
+                              uid (fi : sql_from_items ([Paper = [Id = paperId] ++ paper] ++ tabs)) =
+                O2.joinYourPaper uid (O1.joinYourPaper uid fi)
+        end
diff -r 53a22f46f377 -r 6bcc1020d5cd demo/more/conference.urp
--- a/demo/more/conference.urp	Mon Nov 02 14:22:29 2009 -0500
+++ b/demo/more/conference.urp	Mon Nov 02 15:48:06 2009 -0500
@@ -12,3 +12,4 @@
 checkGroup
 expandable
 bid
+decision
diff -r 53a22f46f377 -r 6bcc1020d5cd demo/more/conference.urs
--- a/demo/more/conference.urs	Mon Nov 02 14:22:29 2009 -0500
+++ b/demo/more/conference.urs	Mon Nov 02 15:48:06 2009 -0500
@@ -46,16 +46,23 @@
                  val paper : $(map Meta.meta paper)
                  val paperFolder : folder paper
 
+                 con paperPrivate :: {Type}
+                 constraint [Id, Document, Authors] ~ paperPrivate
+                 constraint paper ~ paperPrivate
+                 val paperPrivate : $(map Meta.private paperPrivate)
+                 val paperPrivateFolder : folder paperPrivate
+
                  con review :: {(Type * Type)}
                  constraint [Paper, User] ~ review
                  val review : $(map Meta.meta review)
                  val reviewFolder : folder review
 
                  val submissionDeadline : time
-                 val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper) -> xml ([Body] ++ ctx) [] []
+                 val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper ++ paperPrivate)
+                                                                          -> xml ([Body] ++ ctx) [] []
 
-                 functor Make (M : INPUT where con paper = map fst paper)
-                         : OUTPUT where con paper = map fst paper
+                 functor Make (M : INPUT where con paper = map fst paper ++ paperPrivate)
+                         : OUTPUT where con paper = map fst paper ++ paperPrivate
                                   where con userId = M.userId
                                   where con paperId = M.paperId
              end) : sig
@@ -63,3 +70,16 @@
     val main : unit -> transaction page
 
 end
+
+functor Join(M : sig
+                 structure O1 : OUTPUT
+
+                 structure O2 : OUTPUT where con paper = O1.paper
+                                       where con userId = O1.userId
+                                       where con paperId = O1.paperId
+
+                 constraint O1.yourPaperTables ~ O2.yourPaperTables
+             end) : OUTPUT where con paper = M.O1.paper
+                           where con userId = M.O1.userId
+                           where con paperId = M.O1.paperId
+                           where con yourPaperTables = M.O1.yourPaperTables ++ M.O2.yourPaperTables
diff -r 53a22f46f377 -r 6bcc1020d5cd demo/more/conference1.ur
--- a/demo/more/conference1.ur	Mon Nov 02 14:22:29 2009 -0500
+++ b/demo/more/conference1.ur	Mon Nov 02 15:48:06 2009 -0500
@@ -3,14 +3,21 @@
 open Conference.Make(struct
                          val paper = {Title = title,
                                       Abstract = abstract}
+                         val paperPrivate = {Decision = Decision.decision}
                          val review = {Rating = dropdown "Rating" (#"A" :: #"B" :: #"C" :: #"D" :: []),
                                        CommentsForAuthors = commentsForAuthors}
 
                          val submissionDeadline = readError "2009-11-22 23:59:59"
 
-                         fun summarizePaper [ctx] [[Body] ~ ctx] r = cdata r.Title
+                         fun summarizePaper [ctx] [[Body] ~ ctx] r = txt r.Title
 
-                         functor Make (M : Conference.INPUT where con paper = [Title = string, Abstract = string]) = struct
-                             open Bid.Make(M)
+                         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
+                                                                                   end)
+                                                  end)
                          end
                      end)
diff -r 53a22f46f377 -r 6bcc1020d5cd demo/more/decision.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/demo/more/decision.ur	Mon Nov 02 15:48:06 2009 -0500
@@ -0,0 +1,55 @@
+val decision = {Nam = "Decision",
+                Initialize = None,
+                Show = fn bo => cdata (case bo of
+                                           None => "?"
+                                         | Some True => "Accept"
+                                         | Some False => "Reject"),
+                Inject = _}
+
+functor Make(M : sig
+                 con paperOther :: {Type}
+                 constraint [Id, Decision] ~ paperOther
+                 include Conference.INPUT
+                         where con paper = [Decision = option bool] ++ paperOther
+             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><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>Decision</th> </tr>
+                      {ps}
+                    </table>
+                  </subforms></form>
+                </body></xml>
+        in
+            <xml>
+              <li><a link={makeDecisions ()}>Make acceptance decisions</a></li>
+            </xml>
+        end
+
+    val linksForPc = <xml/>
+
+    con yourPaperTables = []
+    constraint [Paper] ~ yourPaperTables
+    fun joinYourPaper [tabs] [paper] [[Paper] ~ tabs] [[Paper] ~ _] [tabs ~ yourPaperTables] [[Id] ~ paper]
+        uid (fi : sql_from_items ([Paper = [Id = paperId] ++ paper] ++ tabs)) = fi
+end
diff -r 53a22f46f377 -r 6bcc1020d5cd demo/more/decision.urs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/demo/more/decision.urs	Mon Nov 02 15:48:06 2009 -0500
@@ -0,0 +1,11 @@
+val decision : Meta.private (option bool)
+
+functor Make (M : sig
+                  con paperOther :: {Type}
+                  constraint [Id, Decision] ~ paperOther
+                  include Conference.INPUT
+                          where con paper = [Decision = option bool] ++ paperOther
+              end) : Conference.OUTPUT where con paper = [Decision = option bool] ++ M.paperOther
+                                       where con userId = M.userId
+                                       where con paperId = M.paperId
+                                       where con yourPaperTables = []
diff -r 53a22f46f377 -r 6bcc1020d5cd demo/more/meta.ur
--- a/demo/more/meta.ur	Mon Nov 02 14:22:29 2009 -0500
+++ b/demo/more/meta.ur	Mon Nov 02 15:48:06 2009 -0500
@@ -80,3 +80,12 @@
     map2 [meta] [snd] [fn ts :: (Type * Type) => sql_exp avail [] [] ts.1]
          (fn [ts] meta v => @sql_inject meta.Inject (meta.Parse v))
          [_] fl r vs
+
+con private = fn t :: Type =>
+                 {Nam : string,
+                  Initialize : t,
+                  Show : t -> xbody,
+                  Inject : sql_injectable t}
+
+fun initialize [ts] (r : $(map private ts)) (fl : folder ts) =
+    mp [private] [sql_exp [] [] []] (fn [t] r => @sql_inject r.Inject r.Initialize) [_] fl r
diff -r 53a22f46f377 -r 6bcc1020d5cd demo/more/meta.urs
--- a/demo/more/meta.urs	Mon Nov 02 14:22:29 2009 -0500
+++ b/demo/more/meta.urs	Mon Nov 02 15:48:06 2009 -0500
@@ -26,3 +26,11 @@
 
 val ensql : avail ::: {{Type}} -> ts ::: {(Type * Type)} -> $(map meta ts) -> $(map snd ts) -> folder ts
             -> $(map (sql_exp avail [] []) (map fst ts))
+
+con private = fn t :: Type =>
+                 {Nam : string,
+                  Initialize : t,
+                  Show : t -> xbody,
+                  Inject : sql_injectable t}
+
+val initialize : ts ::: {Type} -> $(map private ts) -> folder ts -> $(map (sql_exp [] [] []) ts)
diff -r 53a22f46f377 -r 6bcc1020d5cd src/elaborate.sml
--- a/src/elaborate.sml	Mon Nov 02 14:22:29 2009 -0500
+++ b/src/elaborate.sml	Mon Nov 02 15:48:06 2009 -0500
@@ -1996,14 +1996,30 @@
                                                    (strerror, sgnerror))
                                         | SOME sgn => ((L'.StrProj (str, m), loc), sgn))
                                   ((L'.StrVar n, loc), sgn) strs
-                            
-            val cso = E.projectConstraints env {sgn = sgn, str = st}
+
+            fun collect first (st, sgn) =
+                case E.projectConstraints env {sgn = sgn, str = st} of
+                    NONE => (if first then
+                                 strError env (UnboundStr (loc, str))
+                             else
+                               ();
+                             [])
+                  | SOME cs =>
+                    case #1 (hnormSgn env sgn) of
+                        L'.SgnConst sgis =>
+                        foldl (fn (sgi, cs) =>
+                                  case #1 sgi of
+                                      L'.SgiStr (x, _, _) =>
+                                      (case E.projectStr env {sgn = sgn, str = st, field = x} of
+                                           NONE => raise Fail "Elaborate: projectStr in collect"
+                                         | SOME sgn' =>
+                                           List.revAppend (collect false ((L'.StrProj (st, x), loc), sgn'),
+                                                           cs))
+                                    | _ => cs) cs sgis
+                      | _ => cs
         in
-            case cso of
-                NONE => (strError env (UnboundStr (loc, str));
-                         denv)
-              | SOME cs => foldl (fn ((c1, c2), denv) =>
-                                     D.assert env denv (c1, c2)) denv cs
+            foldl (fn ((c1, c2), denv) =>
+                      D.assert env denv (c1, c2)) denv (collect true (st, sgn))
         end
 
 fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
@@ -3445,12 +3461,14 @@
                               ([], (env, denv, gs)))
                    | SOME (n, sgn) =>
                      let
-                         val (_, sgn) = foldl (fn (m, (str, sgn)) =>
-                                                  case E.projectStr env {str = str, sgn = sgn, field = m} of
-                                                      NONE => (strError env (UnboundStr (loc, m));
-                                                               (strerror, sgnerror))
-                                                    | SOME sgn => ((L'.StrProj (str, m), loc), sgn))
-                                              ((L'.StrVar n, loc), sgn) ms
+                         val (str, sgn) = foldl (fn (m, (str, sgn)) =>
+                                                    case E.projectStr env {str = str, sgn = sgn, field = m} of
+                                                        NONE => (strError env (UnboundStr (loc, m));
+                                                                 (strerror, sgnerror))
+                                                      | SOME sgn => ((L'.StrProj (str, m), loc), sgn))
+                                                ((L'.StrVar n, loc), sgn) ms
+
+                         val sgn = selfifyAt env {str = str, sgn = sgn}
 
                          val (ds, env') = dopen env {str = n, strs = ms, sgn = sgn}
                          val denv' = dopenConstraints (loc, env', denv) {str = m, strs = ms}