# HG changeset patch # User Adam Chlipala # Date 1226018628 18000 # Node ID 20fab0e96217adba4b3f9b7a423b5806ab94113b # Parent 7cb418e9714f4d52a9cf7300aa12dd945c7e0fd3 Tree demo working (and other assorted regressions fixed) diff -r 7cb418e9714f -r 20fab0e96217 demo/crud.ur --- 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

Inserted with ID {[id]}.

@@ -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

Saved!

@@ -131,7 +131,7 @@ 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 Not found! | Some fs => return and delete (id : int) = - dml (DELETE FROM tab WHERE Id = {id}); + dml (DELETE FROM tab WHERE Id = {[id]}); ls <- list (); return

The deed is done.

diff -r 7cb418e9714f -r 20fab0e96217 demo/prose --- 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 @@

This example showcases code reuse by applying the same functor as in the last example. The Metaform2 module mixes pages from the functor with some new pages of its own.

+tree.urp + +

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.

+ crud1.urp

This example pulls together much of what we have seen so far. It involves a generic "admin interface" builder. That is, we have the Crud.Make functor, which takes in a description of a table and outputs a sub-application for viewing and editing that table.

diff -r 7cb418e9714f -r 20fab0e96217 demo/refFun.ur --- 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 You already deleted that ref! | 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 diff -r 7cb418e9714f -r 20fab0e96217 demo/sql.ur --- 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

Row added.

@@ -37,7 +37,7 @@ and delete a = dml (DELETE FROM t - WHERE t.A = {a}); + WHERE t.A = {[a]}); xml <- list (); return

Row deleted.

diff -r 7cb418e9714f -r 20fab0e96217 demo/tree.ur --- 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 = - #{[r.Id]}: {[r.Nam]} + #{[r.Id]}: {[r.Nam]} [Delete] + + -fun main () = +and main () = xml <- tree row None; return {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 () diff -r 7cb418e9714f -r 20fab0e96217 demo/tree.urp --- 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 diff -r 7cb418e9714f -r 20fab0e96217 demo/treeFun.ur --- 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 diff -r 7cb418e9714f -r 20fab0e96217 lib/top.ur --- 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) diff -r 7cb418e9714f -r 20fab0e96217 src/cjr_print.sml --- 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 diff -r 7cb418e9714f -r 20fab0e96217 src/elab_env.sig --- 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 diff -r 7cb418e9714f -r 20fab0e96217 src/elab_env.sml --- 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 diff -r 7cb418e9714f -r 20fab0e96217 src/elaborate.sml --- 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 diff -r 7cb418e9714f -r 20fab0e96217 src/monoize.sml --- 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)) diff -r 7cb418e9714f -r 20fab0e96217 src/urweb.grm --- 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),