changeset 471:20fab0e96217

Tree demo working (and other assorted regressions fixed)
author Adam Chlipala <adamc@hcoop.net>
date Thu, 06 Nov 2008 19:43:48 -0500
parents 7cb418e9714f
children 0f128cbc2758
files demo/crud.ur demo/prose demo/refFun.ur demo/sql.ur demo/tree.ur demo/tree.urp demo/treeFun.ur lib/top.ur src/cjr_print.sml src/elab_env.sig src/elab_env.sml src/elaborate.sml src/monoize.sml src/urweb.grm
diffstat 14 files changed, 109 insertions(+), 24 deletions(-) [+]
line wrap: on
line diff
--- a/demo/crud.ur	Thu Nov 06 18:49:38 2008 -0500
+++ b/demo/crud.ur	Thu Nov 06 19:43:48 2008 -0500
@@ -102,7 +102,7 @@
                                                [[nm] ~ rest] =>
                                fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)})
                               {} [M.cols] inputs M.cols
-                     ++ {Id = (SQL {id})}));
+                     ++ {Id = (SQL {[id]})}));
         ls <- list ();
         return <xml><body>
           <p>Inserted with ID {[id]}.</p>
@@ -122,7 +122,7 @@
                                fn input col acc => acc ++ {nm =
                                                            @sql_inject col.Inject (col.Parse input)})
                               {} [M.cols] inputs M.cols)
-                    tab (WHERE T.Id = {id}));
+                    tab (WHERE T.Id = {[id]}));
         ls <- list ();
         return <xml><body>
           <p>Saved!</p>
@@ -131,7 +131,7 @@
         </body></xml>
 
     and upd (id : int) =
-        fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {id});
+        fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {[id]});
         case fso : (Basis.option {Tab : $(mapT2T fstTT M.cols)}) of
             None => return <xml><body>Not found!</body></xml>
           | Some fs => return <xml><body><form>
@@ -150,7 +150,7 @@
           </form></body></xml>
 
     and delete (id : int) =
-        dml (DELETE FROM tab WHERE Id = {id});
+        dml (DELETE FROM tab WHERE Id = {[id]});
         ls <- list ();
         return <xml><body>
           <p>The deed is done.</p>
--- a/demo/prose	Thu Nov 06 18:49:38 2008 -0500
+++ b/demo/prose	Thu Nov 06 19:43:48 2008 -0500
@@ -132,6 +132,10 @@
 
 <p>This example showcases code reuse by applying the same functor as in the last example.  The <tt>Metaform2</tt> module mixes pages from the functor with some new pages of its own.</p>
 
+tree.urp
+
+<p>Here we see how we can abstract over common patterns of SQL queries.  In particular, since standard SQL does not help much with queries over trees, we write a function for traversing an SQL tree, building an HTML representation, based on a user-provided function for rendering individual rows.</p>
+
 crud1.urp
 
 <p>This example pulls together much of what we have seen so far.  It involves a generic "admin interface" builder.  That is, we have the <tt>Crud.Make</tt> functor, which takes in a description of a table and outputs a sub-application for viewing and editing that table.</p>
--- a/demo/refFun.ur	Thu Nov 06 18:49:38 2008 -0500
+++ b/demo/refFun.ur	Thu Nov 06 19:43:48 2008 -0500
@@ -10,19 +10,19 @@
 
     fun new d =
         id <- nextval s;
-        dml (INSERT INTO t (Id, Data) VALUES ({id}, {d}));
+        dml (INSERT INTO t (Id, Data) VALUES ({[id]}, {[d]}));
         return id
 
     fun read r =
-        o <- oneOrNoRows (SELECT t.Data FROM t WHERE t.Id = {r});
+        o <- oneOrNoRows (SELECT t.Data FROM t WHERE t.Id = {[r]});
         return (case o of
             None => error <xml>You already deleted that ref!</xml>
           | Some r => r.T.Data)
 
     fun write r d =
-        dml (UPDATE t SET Data = {d} WHERE Id = {r})
+        dml (UPDATE t SET Data = {[d]} WHERE Id = {[r]})
 
     fun delete r =
-        dml (DELETE FROM t WHERE Id = {r})
+        dml (DELETE FROM t WHERE Id = {[r]})
 
 end
--- a/demo/sql.ur	Thu Nov 06 18:49:38 2008 -0500
+++ b/demo/sql.ur	Thu Nov 06 19:43:48 2008 -0500
@@ -27,7 +27,7 @@
 
 and add r =
     dml (INSERT INTO t (A, B, C, D)
-         VALUES ({readError r.A}, {readError r.B}, {r.C}, {r.D}));
+         VALUES ({[readError r.A]}, {[readError r.B]}, {[r.C]}, {[r.D]}));
     xml <- list ();
     return <xml><body>
       <p>Row added.</p>
@@ -37,7 +37,7 @@
 
 and delete a =
     dml (DELETE FROM t
-         WHERE t.A = {a});
+         WHERE t.A = {[a]});
     xml <- list ();
     return <xml><body>
       <p>Row deleted.</p>
--- a/demo/tree.ur	Thu Nov 06 18:49:38 2008 -0500
+++ b/demo/tree.ur	Thu Nov 06 19:43:48 2008 -0500
@@ -1,3 +1,4 @@
+sequence s
 table t : { Id : int, Parent : option int, Nam : string }
 
 open TreeFun.Make(struct
@@ -5,11 +6,28 @@
                   end)
 
 fun row r = <xml>
-  #{[r.Id]}: {[r.Nam]}
+  #{[r.Id]}: {[r.Nam]} <a link={del r.Id}>[Delete]</a>
+
+  <form>
+    Add child: <textbox{#Nam}/> <submit action={add (Some r.Id)}/>
+  </form>
 </xml>
 
-fun main () =
+and main () =
     xml <- tree row None;
     return <xml><body>
       {xml}
+
+      <form>
+        Add a top-level node: <textbox{#Nam}/> <submit action={add None}/>
+      </form>
     </body></xml>
+
+and add parent r =
+    id <- nextval s;
+    dml (INSERT INTO t (Id, Parent, Nam) VALUES ({[id]}, {[parent]}, {[r.Nam]}));
+    main ()
+
+and del id =
+    dml (DELETE FROM t WHERE Id = {[id]});
+    main ()
--- a/demo/tree.urp	Thu Nov 06 18:49:38 2008 -0500
+++ b/demo/tree.urp	Thu Nov 06 19:43:48 2008 -0500
@@ -1,5 +1,5 @@
 debug
-database dbname=tree
+database dbname=test
 sql tree.sql
 
 treeFun
--- a/demo/treeFun.ur	Thu Nov 06 18:49:38 2008 -0500
+++ b/demo/treeFun.ur	Thu Nov 06 19:43:48 2008 -0500
@@ -18,7 +18,7 @@
              (root : option M.key) =
         let
             fun recurse (root : option key) =
-                queryX' (SELECT * FROM tab WHERE {[eqNullable' (SQL tab.{parent}) root]})
+                queryX' (SELECT * FROM tab WHERE {eqNullable' (SQL tab.{parent}) root})
                         (fn r =>
                             children <- recurse (Some r.Tab.id);
                             return <xml>
--- a/lib/top.ur	Thu Nov 06 18:49:38 2008 -0500
+++ b/lib/top.ur	Thu Nov 06 19:43:48 2008 -0500
@@ -230,12 +230,12 @@
     (t ::: Type) (_ : sql_injectable (option t))
     (e1 : sql_exp tables agg exps (option t))
     (e2 : sql_exp tables agg exps (option t)) =
-    (SQL ({[e1]} IS NULL AND {[e2]} IS NULL) OR {[e1]} = {[e2]})
+    (SQL ({e1} IS NULL AND {e2} IS NULL) OR {e1} = {e2})
 
 fun eqNullable' (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type})
     (t ::: Type) (inj : sql_injectable (option t))
     (e1 : sql_exp tables agg exps (option t))
     (e2 : option t) =
     case e2 of
-        None => (SQL {[e1]} IS NULL)
+        None => (SQL {e1} IS NULL)
       | Some _ => sql_comparison sql_eq e1 (@sql_inject inj e2)
--- a/src/cjr_print.sml	Thu Nov 06 18:49:38 2008 -0500
+++ b/src/cjr_print.sml	Thu Nov 06 19:43:48 2008 -0500
@@ -799,6 +799,43 @@
                              string "})"]
                     end
 
+              | TOption t =>
+                box [string "(request[0] == '/' ? ++request : request, ",
+                     string "((!strncmp(request, \"None\", 4) ",
+                     string "&& (request[4] == 0 || request[4] == '/')) ",
+                     string "? (request += 4, NULL) ",
+                     string ": ((!strncmp(request, \"Some\", 4) ",
+                     string "&& request[4] == '/') ",
+                     string "? (request += 5, ",
+                     if isUnboxable  t then
+                         unurlify' rf (#1 t)
+                     else
+                         box [string "({",
+                              newline,
+                              p_typ env t,
+                              space,
+                              string "*tmp",
+                              space,
+                              string "=",
+                              space,
+                              string "uw_malloc(ctx, sizeof(",
+                              p_typ env t,
+                              string "));",
+                              newline,
+                              string "*tmp",
+                              space,
+                              string "=",
+                              space,
+                              unurlify' rf (#1 t),
+                              string ";",
+                              newline,
+                              string "tmp;",
+                              newline,
+                              string "})"],
+                     string ") :",
+                     space,
+                     string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"]
+
               | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
                       space)
     in
--- a/src/elab_env.sig	Thu Nov 06 18:49:38 2008 -0500
+++ b/src/elab_env.sig	Thu Nov 06 19:43:48 2008 -0500
@@ -74,6 +74,7 @@
     val pushENamed : env -> string -> Elab.con -> env * int
     val pushENamedAs : env -> string -> int -> Elab.con -> env
     val lookupENamed : env -> int -> string * Elab.con
+    val checkENamed : env -> int -> bool
 
     val lookupE : env -> string -> Elab.con var
 
--- a/src/elab_env.sml	Thu Nov 06 18:49:38 2008 -0500
+++ b/src/elab_env.sml	Thu Nov 06 19:43:48 2008 -0500
@@ -542,6 +542,9 @@
         NONE => raise UnboundNamed n
       | SOME x => x
 
+fun checkENamed (env : env) n =
+    Option.isSome (IM.find (#namedE env, n))
+
 fun lookupE (env : env) x =
     case SM.find (#renameE env, x) of
         NONE => NotBound
--- a/src/elaborate.sml	Thu Nov 06 18:49:38 2008 -0500
+++ b/src/elaborate.sml	Thu Nov 06 19:43:48 2008 -0500
@@ -2282,9 +2282,15 @@
                                         let
                                             val env = case #1 h of
                                                           L'.SgiCon (x, n, k, c) =>
-                                                          E.pushCNamedAs env x n k (SOME c)
+                                                          if E.checkENamed env n then
+                                                              env
+                                                          else
+                                                              E.pushCNamedAs env x n k (SOME c)
                                                         | L'.SgiConAbs (x, n, k) =>
-                                                          E.pushCNamedAs env x n k NONE
+                                                          if E.checkENamed env n then
+                                                              env
+                                                          else
+                                                              E.pushCNamedAs env x n k NONE
                                                         | _ => env
                                         in
                                             seek (E.sgiBinds env h, sgiBindsD (env, denv) h) t
@@ -2391,12 +2397,12 @@
 
                                              fun good () =
                                                  let
-                                                     val env = E.sgiBinds env sgi2All
+                                                     val env = E.sgiBinds env sgi1All
                                                      val env = if n1 = n2 then
                                                                    env
                                                                else
-                                                                   E.pushCNamedAs env x n1 k'
-                                                                                  (SOME (L'.CNamed n2, loc))
+                                                                   E.pushCNamedAs env x n2 k'
+                                                                                  (SOME (L'.CNamed n1, loc))
                                                  in
                                                      SOME (env, denv)
                                                  end
--- a/src/monoize.sml	Thu Nov 06 18:49:38 2008 -0500
+++ b/src/monoize.sml	Thu Nov 06 19:43:48 2008 -0500
@@ -390,6 +390,22 @@
                         ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
                     end
 
+                  | L'.TOption t =>
+                    let
+                        val (body, fm) = fooify fm ((L'.ERel 0, loc), t)
+                    in
+                        ((L'.ECase (e,
+                                    [((L'.PNone t, loc),
+                                      (L'.EPrim (Prim.String "None"), loc)),
+                                     
+                                     ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
+                                      (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc),
+                                                   body), loc))],
+                                    {disc = tAll,
+                                     result = (L'.TFfi ("Basis", "string"), loc)}), loc),
+                         fm)
+                    end
+
                   | _ => (E.errorAt loc "Don't know how to encode attribute type";
                           Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
                           (dummyExp, fm))
--- a/src/urweb.grm	Thu Nov 06 18:49:38 2008 -0500
+++ b/src/urweb.grm	Thu Nov 06 19:43:48 2008 -0500
@@ -1236,7 +1236,7 @@
                                                   end
                                           end)
 
-       | LBRACE LBRACK eexp RBRACK RBRACE       (eexp)
+       | LBRACE eexp RBRACE             (eexp)
 
        | sqlexp EQ sqlexp               (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
        | sqlexp NE sqlexp               (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
@@ -1256,8 +1256,8 @@
                                                     sqlexp), loc)
                                          end)
 
-       | LBRACE eexp RBRACE             (sql_inject (#1 eexp,
-                                                     s (LBRACEleft, RBRACEright)))
+       | LBRACE LBRACK eexp RBRACK RBRACE  (sql_inject (#1 eexp,
+                                                        s (LBRACEleft, RBRACEright)))
        | LPAREN sqlexp RPAREN           (sqlexp)
 
        | NULL                           (sql_inject ((EVar (["Basis"], "None", Infer),