Mercurial > urweb
changeset 1025:7facf72aaf0a
Initial form for paper assignment
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 01 Nov 2009 14:26:20 -0500 |
| parents | 93415bcf54c0 |
| children | c1f49f6ba856 |
| files | demo/more/bid.ur demo/more/checkGroup.ur demo/more/checkGroup.urs demo/more/conference.ur demo/more/conference.urp demo/more/conference.urs demo/more/expandable.ur demo/more/expandable.urs include/urweb.h src/c/urweb.c src/jscomp.sml src/monoize.sml |
| diffstat | 12 files changed, 186 insertions(+), 12 deletions(-) [+] |
line wrap: on
line diff
--- a/demo/more/bid.ur Sun Nov 01 10:31:18 2009 -0500 +++ b/demo/more/bid.ur Sun Nov 01 14:26:20 2009 -0500 @@ -7,6 +7,79 @@ table assignment : {User : userId, Paper : paperId} PRIMARY KEY (User, Paper) + fun intOut ch = + case ch of + #"_" => "Maybe" + | #"-" => "No" + | #"+" => "Yes" + | _ => error <xml>Bid: Invalid Interest code</xml> + + val linksForChair = + let + fun assignPapers () = + tup <- query (SELECT paper.Id, paper.{{M.paper}}, user.Id, user.Nam, bid.Interest + FROM paper JOIN bid ON bid.Paper = paper.Id + JOIN user ON bid.User = user.Id + ORDER BY paper.Id, bid.Interest, user.Nam) + (fn r (pid, int, acc, ints, papers) => + if pid = Some r.Paper.Id then + if int = r.Bid.Interest then + return (pid, int, (r.User.Id, r.User.Nam) :: acc, ints, papers) + else + return (pid, r.Bid.Interest, (r.User.Id, r.User.Nam) :: [], + (int, acc) :: ints, papers) + else + return (Some r.Paper.Id, r.Bid.Interest, + (r.User.Id, r.User.Nam) :: [], [], + case pid of + None => papers + | Some pid => (pid, (int, acc) :: ints) :: papers)) + (None, #" ", [], [], []); + let + val papersL = case tup.1 of + Some pid => (pid, (tup.2, tup.3) :: tup.4) :: tup.5 + | _ => [] + + fun makePapers () = List.mapM (fn (pid, ints) => + ints <- List.mapM (fn (int, users) => + cg <- CheckGroup.create + (List.mp + (fn (id, nam) => (id, txt nam, + False)) + users); + ex <- Expandable.create + (CheckGroup.render cg); + return (int, cg, ex)) ints; + return (pid, ints)) papersL + in + papers <- source []; + + return <xml><body onload={papersL <- makePapers (); + set papers papersL}> + <h1>Assign papers</h1> + + <dyn signal={papers <- signal papers; + return (List.mapX (fn (pid, ints) => <xml> + <hr/> + Paper #{[pid]}: + <dyn signal={n <- List.foldl (fn (_, cg, _) total => + this <- CheckGroup.selected cg; + total <- total; + return (List.length this + total)) (return 0) ints; + return (txt n)}/><br/> + + {List.mapX (fn (int, _, ex) => <xml> + {[intOut int]}: {Expandable.render ex} + </xml>) ints} + </xml>) papers)}/> + </body></xml> + end + in + <xml> + <li><a link={assignPapers ()}> Assign papers to people</a></li> + </xml> + end + val linksForPc = let fun yourBids () = @@ -14,16 +87,15 @@ 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>); + (fn r => <xml><tr> + <td>{useMore (summarizePaper (r.Paper -- #Id))}</td> + <td><entry> + <hidden{#Paper} value={show r.Paper.Id}/> + <select{#Bid}> + {useMore (Select.selectChar ((#"-", "No") :: (#"_", "Maybe") :: (#"+", "Yes") :: []) + r.Bid.Interest)} + </select></entry></td> + </tr></xml>); return <xml><body> <h1>Bid on papers</h1>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/checkGroup.ur Sun Nov 01 14:26:20 2009 -0500 @@ -0,0 +1,15 @@ +con t ctx data = list (data * xml ctx [] [] * source bool) + +fun create [ctx] [data] (items : list (data * xml ctx [] [] * bool)) = + List.mapM (fn (d, x, b) => s <- source b; return (d, x, s)) items + +fun render [ctx] [data] [[Body] ~ ctx] (t : t ([Body] ++ ctx) data) = + List.mapX (fn (_, x, s) => <xml><ccheckbox source={s}/> {x}<br/></xml>) t + +fun selected [ctx] [data] (t : t ctx data) = + List.foldlM (fn (d, _, s) ls => + s <- signal s; + return (if s then + d :: ls + else + ls)) [] t
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/checkGroup.urs Sun Nov 01 14:26:20 2009 -0500 @@ -0,0 +1,5 @@ +con t :: {Unit} -> Type -> Type + +val create : ctx ::: {Unit} -> data ::: Type -> list (data * xml ctx [] [] * bool) -> transaction (t ctx data) +val render : ctx ::: {Unit} -> data ::: Type -> [[Body] ~ ctx] => t ([Body] ++ ctx) data -> xml ([Body] ++ ctx) [] [] +val selected : ctx ::: {Unit} -> data ::: Type -> t ctx data -> signal (list data)
--- a/demo/more/conference.ur Sun Nov 01 10:31:18 2009 -0500 +++ b/demo/more/conference.ur Sun Nov 01 14:26:20 2009 -0500 @@ -12,12 +12,14 @@ val paperId_inj : sql_injectable_prim paperId val paperId_show : show paperId val paperId_read : read paperId + val paperId_eq : eq 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 checkChair : transaction unit val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $paper -> xml ([Body] ++ ctx) [] [] end @@ -27,6 +29,7 @@ type paperId val linksForPc : xbody + val linksForChair : xbody con yourPaperTables :: {{Type}} constraint [Paper] ~ yourPaperTables @@ -105,12 +108,20 @@ else error <xml>You are not on the PC.</xml> + val checkChair = + r <- getLogin; + if r.Chair then + return () + else + error <xml>You are not a chair.</xml> + structure O = M.Make(struct val user = user val paper = paper val checkLogin = checkLogin val getLogin = getLogin val getPcLogin = getPcLogin + val checkChair = checkChair val summarizePaper = @@M.summarizePaper end) @@ -203,7 +214,10 @@ <div>Welcome, {[me.Nam]}!</div> {if me.Chair then - <xml><li><a link={Users.main ()}>Manage users</a></li></xml> + <xml> + <li><a link={Users.main ()}>Manage users</a></li> + {O.linksForChair} + </xml> else <xml/>}
--- a/demo/more/conference.urp Sun Nov 01 10:31:18 2009 -0500 +++ b/demo/more/conference.urp Sun Nov 01 14:26:20 2009 -0500 @@ -9,4 +9,6 @@ conference conferenceFields select +checkGroup +expandable bid
--- a/demo/more/conference.urs Sun Nov 01 10:31:18 2009 -0500 +++ b/demo/more/conference.urs Sun Nov 01 14:26:20 2009 -0500 @@ -12,12 +12,14 @@ val paperId_inj : sql_injectable_prim paperId val paperId_show : show paperId val paperId_read : read paperId + val paperId_eq : eq 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 checkChair : transaction unit val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $paper -> xml ([Body] ++ ctx) [] [] end @@ -27,6 +29,7 @@ type paperId val linksForPc : xbody + val linksForChair : xbody con yourPaperTables :: {{Type}} constraint [Paper] ~ yourPaperTables
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/expandable.ur Sun Nov 01 14:26:20 2009 -0500 @@ -0,0 +1,23 @@ +con t ctx = source bool * xml ctx [] [] + +fun create [ctx] (x : xml ctx [] []) = + s <- source False; + return (s, x) + +fun expand [ctx] (t : t ctx) = + set t.1 True + +fun collapse [ctx] (t : t ctx) = + set t.1 False + +fun render [ctx] [[Body] ~ ctx] (t : t ([Body] ++ ctx)) = + <xml><dyn signal={b <- signal t.1; + return (if b then + <xml> + <button value="-" onclick={collapse t}/><br/> + {t.2} + </xml> + else + <xml> + <button value="+" onclick={expand t}/><br/> + </xml>)}/></xml>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/expandable.urs Sun Nov 01 14:26:20 2009 -0500 @@ -0,0 +1,6 @@ +con t :: {Unit} -> Type + +val create : ctx ::: {Unit} -> xml ctx [] [] -> transaction (t ctx) +val render : ctx ::: {Unit} -> [[Body] ~ ctx] => t ([Body] ++ ctx) -> xml ([Body] ++ ctx) [] [] +val expand : ctx ::: {Unit} -> t ctx -> transaction unit +val collapse : ctx ::: {Unit} -> t ctx -> transaction unit
--- a/include/urweb.h Sun Nov 01 10:31:18 2009 -0500 +++ b/include/urweb.h Sun Nov 01 14:26:20 2009 -0500 @@ -153,6 +153,7 @@ char *uw_Basis_ensqlBool(uw_Basis_bool); char *uw_Basis_jsifyString(uw_context, uw_Basis_string); +char *uw_Basis_jsifyChar(uw_context, uw_Basis_char); char *uw_Basis_jsifyChannel(uw_context, uw_Basis_channel); uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int);
--- a/src/c/urweb.c Sun Nov 01 10:31:18 2009 -0500 +++ b/src/c/urweb.c Sun Nov 01 14:26:20 2009 -0500 @@ -1232,6 +1232,37 @@ return r; } +uw_Basis_string uw_Basis_jsifyChar(uw_context ctx, uw_Basis_char c) { + char *r, *s2; + + uw_check_heap(ctx, 6); + + r = s2 = ctx->heap.front; + *s2++ = '"'; + + switch (c) { + case '"': + strcpy(s2, "\\\""); + s2 += 2; + break; + case '\\': + strcpy(s2, "\\\\"); + s2 += 2; + break; + default: + if (isprint(c)) + *s2++ = c; + else { + sprintf(s2, "\\%3o", c); + s2 += 4; + } + } + + strcpy(s2, "\""); + ctx->heap.front = s2 + 2; + return r; +} + uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) { char *r, *s2;
--- a/src/jscomp.sml Sun Nov 01 10:31:18 2009 -0500 +++ b/src/jscomp.sml Sun Nov 01 14:26:20 2009 -0500 @@ -122,6 +122,7 @@ end | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st) + | TFfi ("Basis", "char") => ((EFfiApp ("Basis", "jsifyChar", [e]), loc), st) | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [e]), loc), st) | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [e]), loc), st) | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [e]), loc), st) @@ -307,6 +308,7 @@ end | TFfi ("Basis", "string") => ("uu(t[i++])", st) + | TFfi ("Basis", "char") => ("uu(t[i++])", st) | TFfi ("Basis", "int") => ("parseInt(t[i++])", st) | TFfi ("Basis", "float") => ("parseFloat(t[i++])", st) | TFfi ("Basis", "channel") => ("(t[i++].length > 0 ? parseInt(t[i]) : null)", st)
--- a/src/monoize.sml Sun Nov 01 10:31:18 2009 -0500 +++ b/src/monoize.sml Sun Nov 01 14:26:20 2009 -0500 @@ -3006,7 +3006,7 @@ action in - ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc), + ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"get\""), loc), (L'.EStrcat (action, (L'.EPrim (Prim.String ">"), loc)), loc)), loc), (L'.EStrcat (xml,