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,