Mercurial > urweb
changeset 1030:6bcc1020d5cd
Start of Decision
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Mon, 02 Nov 2009 15:48:06 -0500 |
| parents | 53a22f46f377 |
| children | 5dccff15fa62 |
| files | demo/more/bid.ur demo/more/bid.urs demo/more/conference.ur demo/more/conference.urp demo/more/conference.urs demo/more/conference1.ur demo/more/decision.ur demo/more/decision.urs demo/more/meta.ur demo/more/meta.urs src/elaborate.sml |
| diffstat | 11 files changed, 203 insertions(+), 30 deletions(-) [+] |
line wrap: on
line diff
--- 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
--- 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]
--- 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
--- 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
--- 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
--- 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)
--- /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
--- /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 = []
--- 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
--- 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)
--- 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}